diff --git a/.gitignore b/.gitignore index f5eb6ae4e8..a2ec7dd080 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,21 @@ lapack-3.4.2.tgz lapack-netlib/make.inc lapack-netlib/lapacke/include/lapacke_mangling.h lapack-netlib/TESTING/testing_results.txt +lapack-netlib/INSTALL/test* +lapack-netlib/TESTING/xeigtstc +lapack-netlib/TESTING/xeigtstd +lapack-netlib/TESTING/xeigtsts +lapack-netlib/TESTING/xeigtstz +lapack-netlib/TESTING/xlintstc +lapack-netlib/TESTING/xlintstd +lapack-netlib/TESTING/xlintstds +lapack-netlib/TESTING/xlintstrfc +lapack-netlib/TESTING/xlintstrfd +lapack-netlib/TESTING/xlintstrfs +lapack-netlib/TESTING/xlintstrfz +lapack-netlib/TESTING/xlintsts +lapack-netlib/TESTING/xlintstz +lapack-netlib/TESTING/xlintstzc *.so *.so.* *.a @@ -69,3 +84,6 @@ test/zblat3 build build.* *.swp +benchmark/*.goto +benchmark/smallscaling + diff --git a/CMakeLists.txt b/CMakeLists.txt index ff42643fac..a379f549a4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,16 +2,19 @@ ## Author: Hank Anderson ## -cmake_minimum_required(VERSION 2.8.4) +cmake_minimum_required(VERSION 2.8.5) project(OpenBLAS) set(OpenBLAS_MAJOR_VERSION 0) set(OpenBLAS_MINOR_VERSION 2) -set(OpenBLAS_PATCH_VERSION 19) +set(OpenBLAS_PATCH_VERSION 20) set(OpenBLAS_VERSION "${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION}.${OpenBLAS_PATCH_VERSION}") enable_language(ASM) enable_language(C) +# Adhere to GNU filesystem layout conventions +include(GNUInstallDirs) + if(MSVC) set(OpenBLAS_LIBNAME libopenblas) else() @@ -30,10 +33,20 @@ set(NO_LAPACK 1) set(NO_LAPACKE 1) endif() -if(BUILD_DEBUG) -set(CMAKE_BUILD_TYPE Debug) +if(CMAKE_CONFIGURATION_TYPES) # multiconfig generator? + set(CMAKE_CONFIGURATION_TYPES "Debug;Release" CACHE STRING "" FORCE) + set(CMAKE_BUILD_TYPE + Debug Debug + Release Release + ) else() -set(CMAKE_BUILD_TYPE Release) + if( NOT CMAKE_BUILD_TYPE ) + if(BUILD_DEBUG) + set(CMAKE_BUILD_TYPE Debug) + else() + set(CMAKE_BUILD_TYPE Release) + endif() + endif() endif() if(BUILD_WITHOUT_CBLAS) @@ -107,9 +120,12 @@ if (${NO_STATIC} AND ${NO_SHARED}) endif () #Set default output directory -set( CMAKE_LIBRARY_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/lib ) -set( CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/lib ) - +set( CMAKE_LIBRARY_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/lib) +set( CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/lib) +if(MSVC) +set( CMAKE_LIBRARY_OUTPUT_DIRECTORY_DEBUG ${PROJECT_BINARY_DIR}/lib/Debug) +set( CMAKE_ARCHIVE_OUTPUT_DIRECTORY_RELEASE ${PROJECT_BINARY_DIR}/lib/Release) +endif () # get obj vars into format that add_library likes: $ (see http://www.cmake.org/cmake/help/v3.0/command/add_library.html) set(TARGET_OBJS "") foreach (SUBDIR ${SUBDIRS}) @@ -129,9 +145,12 @@ if (NOT NO_LAPACKE) endif () endif () -#Only generate .def for dll on MSVC +# Only generate .def for dll on MSVC and always produce pdb files for debug and release if(MSVC) set(OpenBLAS_DEF_FILE "${PROJECT_BINARY_DIR}/openblas.def") +set(CMAKE_CXX_FLAGS_RELEASE "${CMAKE_CXX_FLAGS_RELEASE} /Zi") +set(CMAKE_C_FLAGS_RELEASE "${CMAKE_C_FLAGS_RELEASE} /Zi") +set(CMAKE_SHARED_LINKER_FLAGS_RELEASE "${CMAKE_SHARED_LINKER_FLAGS_RELEASE} /DEBUG /OPT:REF /OPT:ICF") endif() # add objects to the openblas lib @@ -141,25 +160,29 @@ include("${PROJECT_SOURCE_DIR}/cmake/export.cmake") # Set output for libopenblas set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR}/lib) +set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES LIBRARY_OUTPUT_NAME_DEBUG "${OpenBLAS_LIBNAME}_d") + foreach (OUTPUTCONFIG ${CMAKE_CONFIGURATION_TYPES}) string( TOUPPER ${OUTPUTCONFIG} OUTPUTCONFIG ) - set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES RUNTIME_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib) - set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES LIBRARY_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib) - set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES ARCHIVE_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib) + + set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES RUNTIME_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib/${OUTPUTCONFIG} ) + set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES LIBRARY_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib/${OUTPUTCONFIG} ) + set_target_properties( ${OpenBLAS_LIBNAME} PROPERTIES ARCHIVE_OUTPUT_DIRECTORY_${OUTPUTCONFIG} ${PROJECT_BINARY_DIR}/lib/${OUTPUTCONFIG} ) endforeach() enable_testing() add_subdirectory(utest) -if(NOT MSVC) -#only build shared library for MSVC -add_library(${OpenBLAS_LIBNAME}_static STATIC ${LA_SOURCES} ${LAPACKE_SOURCES} ${TARGET_OBJS}) -set_target_properties(${OpenBLAS_LIBNAME}_static PROPERTIES OUTPUT_NAME ${OpenBLAS_LIBNAME}) -set_target_properties(${OpenBLAS_LIBNAME}_static PROPERTIES CLEAN_DIRECT_OUTPUT 1) - -if(SMP) -target_link_libraries(${OpenBLAS_LIBNAME} pthread) -target_link_libraries(${OpenBLAS_LIBNAME}_static pthread) +if (NOT MSVC) + #only build shared library for MSVC + + add_library(${OpenBLAS_LIBNAME}_static STATIC ${LA_SOURCES} ${LAPACKE_SOURCES} ${TARGET_OBJS}) + set_target_properties(${OpenBLAS_LIBNAME}_static PROPERTIES OUTPUT_NAME ${OpenBLAS_LIBNAME}) + set_target_properties(${OpenBLAS_LIBNAME}_static PROPERTIES CLEAN_DIRECT_OUTPUT 1) + + if(SMP) + target_link_libraries(${OpenBLAS_LIBNAME} pthread) + target_link_libraries(${OpenBLAS_LIBNAME}_static pthread) endif() #build test and ctest @@ -198,3 +221,73 @@ set_target_properties(${OpenBLAS_LIBNAME} PROPERTIES #endif # @touch lib.grd +# Install project + +# Install libraries +install(TARGETS ${OpenBLAS_LIBNAME} + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} ) + +# Install include files + set (GENCONFIG_BIN ${CMAKE_BINARY_DIR}/gen_config_h${CMAKE_EXECUTABLE_SUFFIX}) + ADD_CUSTOM_COMMAND( + OUTPUT ${CMAKE_BINARY_DIR}/openblas_config.h + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/config.h + COMMAND ${GENCONFIG_BIN} ${CMAKE_CURRENT_SOURCE_DIR}/config.h ${CMAKE_CURRENT_SOURCE_DIR}/openblas_config_template.h > ${CMAKE_BINARY_DIR}/openblas_config.h + ) + + ADD_CUSTOM_TARGET(genconfig + ALL + DEPENDS openblas_config.h + ) + add_dependencies(genconfig ${OpenBLAS_LIBNAME}) + + install (FILES ${CMAKE_BINARY_DIR}/openblas_config.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) + + message(STATUS "Generating f77blas.h in ${CMAKE_INSTALL_INCLUDEDIR}") + + ADD_CUSTOM_TARGET(genf77blas + ALL + COMMAND ${AWK} 'BEGIN{print \"\#ifndef OPENBLAS_F77BLAS_H\" \; print \"\#define OPENBLAS_F77BLAS_H\" \; print \"\#include \\"openblas_config.h\\" \"}; NF {print}; END{print \"\#endif\"}' ${CMAKE_CURRENT_SOURCE_DIR}/common_interface.h > ${CMAKE_BINARY_DIR}/f77blas.h + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/config.h + ) + add_dependencies(genf77blas ${OpenBLAS_LIBNAME}) + + install (FILES ${CMAKE_BINARY_DIR}/f77blas.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) + +if(NOT NO_CBLAS) + message (STATUS "Generating cblas.h in ${CMAKE_INSTALL_INCLUDEDIR}") + + ADD_CUSTOM_TARGET(gencblas + ALL + COMMAND ${SED} 's/common/openblas_config/g' ${CMAKE_CURRENT_SOURCE_DIR}/cblas.h > "${CMAKE_BINARY_DIR}/cblas.tmp" + COMMAND cp "${CMAKE_BINARY_DIR}/cblas.tmp" "${CMAKE_BINARY_DIR}/cblas.h" + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/cblas.h + ) + add_dependencies(gencblas ${OpenBLAS_LIBNAME}) + + install (FILES ${CMAKE_BINARY_DIR}/cblas.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) +endif() + +if(NOT NO_LAPACKE) + message (STATUS "Copying LAPACKE header files to ${CMAKE_INSTALL_INCLUDEDIR}") + add_dependencies( ${OpenBLAS_LIBNAME} genlapacke) + FILE(GLOB_RECURSE INCLUDE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/lapack-netlib/LAPACKE/*.h") + install (FILES ${INCLUDE_FILES} DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) + + ADD_CUSTOM_TARGET(genlapacke + COMMAND cp ${CMAKE_CURRENT_SOURCE_DIR}/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h.in "${CMAKE_BINARY_DIR}/lapacke_mangling.h" + ) + install (FILES ${CMAKE_BINARY_DIR}/lapacke_mangling.h DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) +endif() + +if(NOT MSVC) + install (TARGETS ${OpenBLAS_LIBNAME}_static DESTINATION ${CMAKE_INSTALL_LIBDIR}) +endif() + +include(FindPkgConfig QUIET) +if(PKG_CONFIG_FOUND) + configure_file(${PROJECT_SOURCE_DIR}/cmake/openblas.pc.in ${PROJECT_BINARY_DIR}/openblas.pc @ONLY) + install (FILES ${PROJECT_BINARY_DIR}/openblas.pc DESTINATION ${CMAKE_INSTALL_LIBDIR}/pkgconfig/) +endif() diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 5ecf32b914..a960708efe 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -161,3 +161,10 @@ In chronological order: * Kaustubh Raste * [2016-05-09] DTRSM optimization for MIPS P5600 and I6400 using MSA * [2016-05-20] STRSM optimization for MIPS P5600 and I6400 using MSA + +* Abdelrauf + * [2017-01-01] dgemm and dtrmm kernels for IBM z13 + * [2017-02-26] ztrmm kernel for IBM z13 + * [2017-03-13] strmm and ctrmm kernel for IBM z13 + + diff --git a/Changelog.txt b/Changelog.txt index 2eb27ab04b..cb6fee70a4 100644 --- a/Changelog.txt +++ b/Changelog.txt @@ -1,4 +1,45 @@ OpenBLAS ChangeLog +==================================================================== +Version 0.2.20 +24-Jul-2017 + +common: + * Improved CMake support + * Fixed several thread race and locking bugs + * Fixed default LAPACK optimization level + * Updated LAPACK to 3.7.0 + * Added ReLAPACK (https://github.com/HPAC/ReLAPACK, make BUILD_RELAPACK=1) + +POWER: + * Optimizations for Power9 + * Fixed several Power8 assembly bugs + +ARM: + * New optimized Vulcan and ThunderX2T99 targets + * Support for ARMV7 SOFT_FP ABI (make ARM_SOFTFP_ABI=1) + * Detect all cpu cores including offline ones + * Fix compilation with CLANG + * Support building a shared library for Android + +MIPS: + * Fixed several threading issues + * Fix compilation with CLANG + +x86_64: + * Detect Intel Bay Trail and Apollo Lake + * Detect Intel Sky Lake and Kaby Lake + * Detect Intel Knights Landing + * Detect AMD A8, A10, A12 and Ryzen + * Support 64bit builds with Visual Studio + * Fix building with Intel and PGI compilers + * Fix building with MINGW and TDM-GCC + * Fix cmake builds for Haswell and related cpus + * Fix building for Sandybridge with CLANG 3.9 + * Add support for the FLANG compiler + +IBM Z: + * New target z13 with BLAS3 optimizations + ==================================================================== Version 0.2.19 1-Sep-2016 diff --git a/Makefile b/Makefile index 2ae0047989..1b9bcb118b 100644 --- a/Makefile +++ b/Makefile @@ -16,14 +16,19 @@ ifneq ($(NO_LAPACK), 1) SUBDIRS += lapack endif +RELA = +ifeq ($(BUILD_RELAPACK), 1) +RELA = re_lapack +endif + LAPACK_NOOPT := $(filter-out -O0 -O1 -O2 -O3 -Ofast,$(LAPACK_FFLAGS)) SUBDIRS_ALL = $(SUBDIRS) test ctest utest exports benchmark ../laswp ../bench -.PHONY : all libs netlib test ctest shared install -.NOTPARALLEL : all libs prof lapack-test install blas-test +.PHONY : all libs netlib $(RELA) test ctest shared install +.NOTPARALLEL : all libs $(RELA) prof lapack-test install blas-test -all :: libs netlib tests shared +all :: libs netlib $(RELA) tests shared @echo @echo " OpenBLAS build complete. ($(LIB_COMPONENTS))" @echo @@ -81,7 +86,7 @@ endif shared : ifndef NO_SHARED -ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS)) +ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS Android)) @$(MAKE) -C exports so @ln -fs $(LIBSONAME) $(LIBPREFIX).so @ln -fs $(LIBSONAME) $(LIBPREFIX).so.$(MAJOR_VERSION) @@ -215,6 +220,14 @@ ifndef NO_LAPACKE endif endif +ifeq ($(NO_LAPACK), 1) +re_lapack : + +else +re_lapack : + @$(MAKE) -C relapack +endif + prof_lapack : lapack_prebuild @$(MAKE) -C $(NETLIB_LAPACK_DIR) lapack_prof @@ -278,13 +291,13 @@ lapack-timing : large.tgz timing.tgz ifndef NOFORTRAN (cd $(NETLIB_LAPACK_DIR); $(TAR) zxf ../timing.tgz TIMING) (cd $(NETLIB_LAPACK_DIR)/TIMING; $(TAR) zxf ../../large.tgz ) - make -C $(NETLIB_LAPACK_DIR)/TIMING + $(MAKE) -C $(NETLIB_LAPACK_DIR)/TIMING endif lapack-test : (cd $(NETLIB_LAPACK_DIR)/TESTING && rm -f x* *.out) - make -j 1 -C $(NETLIB_LAPACK_DIR)/TESTING xeigtstc xeigtstd xeigtsts xeigtstz xlintstc xlintstd xlintstds xlintstrfd xlintstrfz xlintsts xlintstz xlintstzc xlintstrfs xlintstrfc + $(MAKE) -j 1 -C $(NETLIB_LAPACK_DIR)/TESTING xeigtstc xeigtstd xeigtsts xeigtstz xlintstc xlintstd xlintstds xlintstrfd xlintstrfz xlintsts xlintstz xlintstzc xlintstrfs xlintstrfc ifneq ($(CROSS), 1) ( cd $(NETLIB_LAPACK_DIR)/INSTALL; ./testlsame; ./testslamch; ./testdlamch; \ ./testsecond; ./testdsecnd; ./testieee; ./testversion ) @@ -299,7 +312,7 @@ lapack-runtest: blas-test: (cd $(NETLIB_LAPACK_DIR)/BLAS && rm -f x* *.out) - make -j 1 -C $(NETLIB_LAPACK_DIR) blas_testing + $(MAKE) -j 1 -C $(NETLIB_LAPACK_DIR) blas_testing (cd $(NETLIB_LAPACK_DIR)/BLAS && cat *.out) @@ -326,6 +339,7 @@ endif @touch $(NETLIB_LAPACK_DIR)/make.inc @$(MAKE) -C $(NETLIB_LAPACK_DIR) clean @rm -f $(NETLIB_LAPACK_DIR)/make.inc $(NETLIB_LAPACK_DIR)/lapacke/include/lapacke_mangling.h + @$(MAKE) -C relapack clean @rm -f *.grd Makefile.conf_last config_last.h @(cd $(NETLIB_LAPACK_DIR)/TESTING && rm -f x* *.out testing_results.txt) @echo Done. diff --git a/Makefile.arm b/Makefile.arm index 62bf275b93..eedd39b736 100644 --- a/Makefile.arm +++ b/Makefile.arm @@ -1,31 +1,19 @@ -# ifeq logical or -ifeq ($(CORE), $(filter $(CORE),CORTEXA9 CORTEXA15)) +ifeq ($(CORE), $(filter $(CORE),ARMV7 CORTEXA9 CORTEXA15)) ifeq ($(OSNAME), Android) -CCOMMON_OPT += -marm -mfpu=neon -mfloat-abi=hard -march=armv7-a -FCOMMON_OPT += -marm -mfpu=neon -mfloat-abi=hard -march=armv7-a +CCOMMON_OPT += -mfpu=neon -march=armv7-a +FCOMMON_OPT += -mfpu=neon -march=armv7-a else -CCOMMON_OPT += -marm -mfpu=vfpv3 -mfloat-abi=hard -march=armv7-a -FCOMMON_OPT += -marm -mfpu=vfpv3 -mfloat-abi=hard -march=armv7-a -endif -endif - -ifeq ($(CORE), ARMV7) -ifeq ($(OSNAME), Android) -CCOMMON_OPT += -marm -mfpu=neon -mfloat-abi=hard -march=armv7-a -Wl,--no-warn-mismatch -FCOMMON_OPT += -marm -mfpu=neon -mfloat-abi=hard -march=armv7-a -Wl,--no-warn-mismatch -else -CCOMMON_OPT += -marm -mfpu=vfpv3 -mfloat-abi=hard -march=armv7-a -FCOMMON_OPT += -marm -mfpu=vfpv3 -mfloat-abi=hard -march=armv7-a +CCOMMON_OPT += -mfpu=vfpv3 -march=armv7-a +FCOMMON_OPT += -mfpu=vfpv3 -march=armv7-a endif endif ifeq ($(CORE), ARMV6) -CCOMMON_OPT += -marm -mfpu=vfp -mfloat-abi=hard -march=armv6 -FCOMMON_OPT += -marm -mfpu=vfp -mfloat-abi=hard -march=armv6 +CCOMMON_OPT += -mfpu=vfp -march=armv6 +FCOMMON_OPT += -mfpu=vfp -march=armv6 endif - ifeq ($(CORE), ARMV5) -CCOMMON_OPT += -marm -march=armv5 -FCOMMON_OPT += -marm -march=armv5 +CCOMMON_OPT += -march=armv5 +FCOMMON_OPT += -march=armv5 endif diff --git a/Makefile.arm64 b/Makefile.arm64 index b5170163f7..d19e796a51 100644 --- a/Makefile.arm64 +++ b/Makefile.arm64 @@ -9,3 +9,17 @@ CCOMMON_OPT += -march=armv8-a+crc+crypto+fp+simd -mtune=cortex-a57 FCOMMON_OPT += -march=armv8-a+crc+crypto+fp+simd -mtune=cortex-a57 endif +ifeq ($(CORE), VULCAN) +CCOMMON_OPT += -mtune=vulcan -mcpu=vulcan +FCOMMON_OPT += -mtune=vulcan -mcpu=vulcan +endif + +ifeq ($(CORE), THUNDERX) +CCOMMON_OPT += -mtune=thunderx -mcpu=thunderx +FCOMMON_OPT += -mtune=thunderx -mcpu=thunderx +endif + +ifeq ($(CORE), THUNDERX2T99) +CCOMMON_OPT += -mtune=thunderx2t99 -mcpu=thunderx2t99 +FCOMMON_OPT += -mtune=thunderx2t99 -mcpu=thunderx2t99 +endif diff --git a/Makefile.install b/Makefile.install index 1b9388a8b5..24fe8c820b 100644 --- a/Makefile.install +++ b/Makefile.install @@ -12,6 +12,7 @@ OPENBLAS_BUILD_DIR := $(CURDIR) OPENBLAS_CMAKE_DIR := $(OPENBLAS_LIBRARY_DIR)/cmake/openblas OPENBLAS_CMAKE_CONFIG := OpenBLASConfig.cmake OPENBLAS_CMAKE_CONFIG_VERSION := OpenBLASConfigVersion.cmake +OPENBLAS_PKGCONFIG_DIR := $(OPENBLAS_LIBRARY_DIR)/pkgconfig .PHONY : install .NOTPARALLEL : install @@ -25,6 +26,7 @@ install : lib.grd @-mkdir -p "$(DESTDIR)$(OPENBLAS_LIBRARY_DIR)" @-mkdir -p "$(DESTDIR)$(OPENBLAS_BINARY_DIR)" @-mkdir -p "$(DESTDIR)$(OPENBLAS_CMAKE_DIR)" + @-mkdir -p "$(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)" @echo Generating openblas_config.h in $(DESTDIR)$(OPENBLAS_INCLUDE_DIR) #for inc @echo \#ifndef OPENBLAS_CONFIG_H > "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/openblas_config.h" @@ -50,7 +52,7 @@ ifndef NO_LAPACKE @echo Copying LAPACKE header files to $(DESTDIR)$(OPENBLAS_INCLUDE_DIR) @-install -pm644 $(NETLIB_LAPACK_DIR)/LAPACKE/include/lapacke.h "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/lapacke.h" @-install -pm644 $(NETLIB_LAPACK_DIR)/LAPACKE/include/lapacke_config.h "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/lapacke_config.h" - @-install -pm644 $(NETLIB_LAPACK_DIR)/LAPACKE/include/lapacke_mangling_with_flags.h "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/lapacke_mangling.h" + @-install -pm644 $(NETLIB_LAPACK_DIR)/LAPACKE/include/lapacke_mangling_with_flags.h.in "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/lapacke_mangling.h" @-install -pm644 $(NETLIB_LAPACK_DIR)/LAPACKE/include/lapacke_utils.h "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/lapacke_utils.h" endif @@ -64,7 +66,7 @@ endif #for install shared library ifndef NO_SHARED @echo Copying the shared library to $(DESTDIR)$(OPENBLAS_LIBRARY_DIR) -ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS)) +ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS Android)) @install -pm755 $(LIBSONAME) "$(DESTDIR)$(OPENBLAS_LIBRARY_DIR)" @cd "$(DESTDIR)$(OPENBLAS_LIBRARY_DIR)" ; \ ln -fs $(LIBSONAME) $(LIBPREFIX).so ; \ @@ -91,9 +93,20 @@ ifeq ($(OSNAME), WINNT) @-cp $(LIBDLLNAME).a "$(DESTDIR)$(OPENBLAS_LIBRARY_DIR)" endif ifeq ($(OSNAME), CYGWIN_NT) - @-cp $(LIBDLLNAME) $(OPENBLAS_BINARY_DIR) + @-cp $(LIBDLLNAME) "$(DESTDIR)$(OPENBLAS_BINARY_DIR)" endif endif + + +#Generating openblas.pc + @echo Generating openblas.pc in $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR) + @echo 'libdir='$(OPENBLAS_LIBRARY_DIR) >> $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)/openblas.pc + @echo 'includedir='$(OPENBLAS_INCLUDE_DIR) >> $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)/openblas.pc + @echo 'version='$(VERSION) >> $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)/openblas.pc + @echo 'extralib='$(EXTRALIB) >> $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)/openblas.pc + @cat openblas.pc.in >> $(DESTDIR)$(OPENBLAS_PKGCONFIG_DIR)/openblas.pc + + #Generating OpenBLASConfig.cmake @echo Generating $(OPENBLAS_CMAKE_CONFIG) in $(DESTDIR)$(OPENBLAS_CMAKE_DIR) @echo "SET(OpenBLAS_VERSION \"${VERSION}\")" > "$(DESTDIR)$(OPENBLAS_CMAKE_DIR)/$(OPENBLAS_CMAKE_CONFIG)" diff --git a/Makefile.power b/Makefile.power index 79db83751e..a49372ad73 100644 --- a/Makefile.power +++ b/Makefile.power @@ -43,7 +43,7 @@ endif ifeq ($(USE_MASS), 1) # Path to MASS libs, change it if the libs are installed at any other location -MASSPATH = /opt/ibm/xlmass/8.1.3/lib +MASSPATH = /opt/ibm/xlmass/8.1.5/lib COMMON_OPT += -mveclibabi=mass -ftree-vectorize -funsafe-math-optimizations -DUSE_MASS EXTRALIB += -L$(MASSPATH) -lmass -lmassvp8 -lmass_simdp8 endif diff --git a/Makefile.rule b/Makefile.rule index 5bb9cf0b77..75fba448f0 100644 --- a/Makefile.rule +++ b/Makefile.rule @@ -3,7 +3,7 @@ # # This library's version -VERSION = 0.2.19 +VERSION = 0.2.20 # If you set the suffix, the library name will be libopenblas_$(LIBNAMESUFFIX).a # and libopenblas_$(LIBNAMESUFFIX).so. Meanwhile, the soname in shared library @@ -83,6 +83,9 @@ VERSION = 0.2.19 # Build LAPACK Deprecated functions since LAPACK 3.6.0 BUILD_LAPACK_DEPRECATED = 1 +# Build RecursiveLAPACK on top of LAPACK +# BUILD_RELAPACK = 1 + # If you want to use legacy threaded Level 3 implementation. # USE_SIMPLE_THREADED_LEVEL3 = 1 @@ -97,7 +100,7 @@ BUILD_LAPACK_DEPRECATED = 1 NO_WARMUP = 1 # If you want to disable CPU/Memory affinity on Linux. -NO_AFFINITY = 1 +#NO_AFFINITY = 1 # if you are compiling for Linux and you have more than 16 numa nodes or more than 256 cpus # BIGNUMA = 1 diff --git a/Makefile.system b/Makefile.system index b05177b6c3..bd361a1a20 100644 --- a/Makefile.system +++ b/Makefile.system @@ -68,6 +68,9 @@ endif ifeq ($(TARGET), EXCAVATOR) GETARCH_FLAGS := -DFORCE_BARCELONA endif +ifeq ($(TARGET), ZEN) +GETARCH_FLAGS := -DFORCE_BARCELONA +endif endif @@ -98,6 +101,9 @@ endif ifeq ($(TARGET_CORE), EXCAVATOR) GETARCH_FLAGS := -DFORCE_BARCELONA endif +ifeq ($(TARGET_CORE), ZEN) +GETARCH_FLAGS := -DFORCE_BARCELONA +endif endif @@ -217,7 +223,9 @@ endif # ifeq ($(OSNAME), Darwin) +ifndef MACOSX_DEPLOYMENT_TARGET export MACOSX_DEPLOYMENT_TARGET=10.6 +endif MD5SUM = md5 -r endif @@ -234,6 +242,10 @@ EXTRALIB += -lm NO_EXPRECISION = 1 endif +ifeq ($(OSNAME), Android) +EXTRALIB += -lm +endif + ifeq ($(OSNAME), AIX) EXTRALIB += -lm endif @@ -406,7 +418,6 @@ CCOMMON_OPT += -fopenmp endif ifeq ($(C_COMPILER), CLANG) -$(error OpenBLAS: Clang didn't support OpenMP yet.) CCOMMON_OPT += -fopenmp endif @@ -441,12 +452,13 @@ ifneq ($(NO_AVX), 1) DYNAMIC_CORE += SANDYBRIDGE BULLDOZER PILEDRIVER STEAMROLLER EXCAVATOR endif ifneq ($(NO_AVX2), 1) -DYNAMIC_CORE += HASWELL +DYNAMIC_CORE += HASWELL ZEN endif endif +# If DYNAMIC_CORE is not set, DYNAMIC_ARCH cannot do anything, so force it to empty ifndef DYNAMIC_CORE -DYNAMIC_ARCH = +override DYNAMIC_ARCH= endif endif @@ -474,6 +486,23 @@ endif ifeq ($(ARCH), arm) NO_BINARY_MODE = 1 BINARY_DEFINED = 1 + +CCOMMON_OPT += -marm +FCOMMON_OPT += -marm + +# If softfp abi is mentioned on the command line, force it. +ifeq ($(ARM_SOFTFP_ABI), 1) +CCOMMON_OPT += -mfloat-abi=softfp +FCOMMON_OPT += -mfloat-abi=softfp +endif + +ifeq ($(OSNAME), Android) +ifeq ($(ARM_SOFTFP_ABI), 1) +EXTRALIB += -lm +else +EXTRALIB += -Wl,-lm_hard +endif +endif endif ifeq ($(ARCH), arm64) @@ -575,6 +604,23 @@ endif # Fortran Compiler dependent settings # +ifeq ($(F_COMPILER), FLANG) +CCOMMON_OPT += -DF_INTERFACE_FLANG +ifdef BINARY64 +ifdef INTERFACE64 +ifneq ($(INTERFACE64), 0) +FCOMMON_OPT += -i8 +endif +endif +FCOMMON_OPT += -Wall +else +FCOMMON_OPT += -Wall +endif +ifeq ($(USE_OPENMP), 1) +FCOMMON_OPT += -fopenmp +endif +endif + ifeq ($(F_COMPILER), G77) CCOMMON_OPT += -DF_INTERFACE_G77 FCOMMON_OPT += -Wall @@ -1002,7 +1048,7 @@ endif override CFLAGS += $(COMMON_OPT) $(CCOMMON_OPT) -I$(TOPDIR) override PFLAGS += $(COMMON_OPT) $(CCOMMON_OPT) -I$(TOPDIR) -DPROFILE $(COMMON_PROF) -override FFLAGS += $(FCOMMON_OPT) +override FFLAGS += $(COMMON_OPT) $(FCOMMON_OPT) override FPFLAGS += $(FCOMMON_OPT) $(COMMON_PROF) #MAKEOVERRIDES = @@ -1083,6 +1129,9 @@ LIB_COMPONENTS += LAPACK ifneq ($(NO_LAPACKE), 1) LIB_COMPONENTS += LAPACKE endif +ifeq ($(BUILD_RELAPACK), 1) +LIB_COMPONENTS += ReLAPACK +endif endif ifeq ($(ONLY_CBLAS), 1) diff --git a/Makefile.zarch b/Makefile.zarch new file mode 100644 index 0000000000..9ec9dc79fc --- /dev/null +++ b/Makefile.zarch @@ -0,0 +1,6 @@ + +ifeq ($(CORE), Z13) +CCOMMON_OPT += -march=z13 -mzvector +FCOMMON_OPT += -march=z13 -mzvector +endif + diff --git a/README.md b/README.md index ff55edaa14..06bef97fbe 100644 --- a/README.md +++ b/README.md @@ -51,18 +51,18 @@ The library can be installed as below - * On Ubuntu: - wget -q http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/ubuntu/public.gpg -O- | sudo apt-key add - - echo "deb http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/ubuntu/ trusty main" | sudo tee /etc/apt/sources.list.d/ibm-xl-compiler-eval.list - sudo apt-get update - sudo apt-get install libxlmass-devel.8.1.3 + wget -q http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/ubuntu/public.gpg -O- | sudo apt-key add -
+ echo "deb http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/ubuntu/ trusty main" | sudo tee /etc/apt/sources.list.d/ibm-xl-compiler-eval.list
+ sudo apt-get update
+ sudo apt-get install libxlmass-devel.8.1.5
* On RHEL/CentOS: - wget http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/rhel7/repodata/repomd.xml.key - sudo rpm --import repomd.xml.key - wget http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/rhel7/ibm-xl-compiler-eval.repo - sudo cp ibm-xl-compiler-eval.repo /etc/yum.repos.d/ - sudo yum install libxlmass-devel.8.1.3 + wget http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/rhel7/repodata/repomd.xml.key
+ sudo rpm --import repomd.xml.key
+ wget http://public.dhe.ibm.com/software/server/POWER/Linux/xl-compiler/eval/ppc64le/rhel7/ibm-xl-compiler-eval.repo
+ sudo cp ibm-xl-compiler-eval.repo /etc/yum.repos.d/
+ sudo yum install libxlmass-devel.8.1.5
After installing MASS library, compile openblas with USE_MASS=1. @@ -106,6 +106,10 @@ Please read GotoBLAS_01Readme.txt - **ARMV8**: Experimental - **ARM Cortex-A57**: Experimental +#### IBM zEnterprise System: +- **Z13**: Optimized Level-3 BLAS + + ### Support OS: - **GNU/Linux** - **MingWin or Visual Studio(CMake)/Windows**: Please read . diff --git a/TargetList.txt b/TargetList.txt index 52a60b49cc..743996e94a 100644 --- a/TargetList.txt +++ b/TargetList.txt @@ -34,6 +34,7 @@ BULLDOZER PILEDRIVER STEAMROLLER EXCAVATOR +ZEN c)VIA CPU: SSE_GENERIC @@ -80,4 +81,7 @@ ARMV5 8.ARM 64-bit CPU: ARMV8 CORTEXA57 +VULCAN +THUNDERX +THUNDERX2T99 diff --git a/benchmark/Makefile b/benchmark/Makefile index e801ce4ebe..51e9c64aae 100644 --- a/benchmark/Makefile +++ b/benchmark/Makefile @@ -37,6 +37,18 @@ ESSL=/opt/ibm/lib #LIBESSL = -lesslsmp $(ESSL)/libxlomp_ser.so.1 $(ESSL)/libxlf90_r.so.1 $(ESSL)/libxlfmath.so.1 $(ESSL)/libxlsmp.so.1 /opt/ibm/xlC/13.1.3/lib/libxl.a LIBESSL = -lesslsmp $(ESSL)/libxlf90_r.so.1 $(ESSL)/libxlfmath.so.1 $(ESSL)/libxlsmp.so.1 /opt/ibm/xlC/13.1.3/lib/libxl.a +ifneq ($(NO_LAPACK), 1) +GOTO_LAPACK_TARGETS=slinpack.goto dlinpack.goto clinpack.goto zlinpack.goto \ + scholesky.goto dcholesky.goto ccholesky.goto zcholesky.goto \ + sgesv.goto dgesv.goto cgesv.goto zgesv.goto \ + sgeev.goto dgeev.goto cgeev.goto zgeev.goto \ + csymv.goto zsymv.goto \ + sgetri.goto dgetri.goto cgetri.goto zgetri.goto \ + spotrf.goto dpotrf.goto cpotrf.goto zpotrf.goto +else +GOTO_LAPACK_TARGETS= +endif + ifeq ($(OSNAME), WINNT) goto :: slinpack.goto dlinpack.goto clinpack.goto zlinpack.goto \ @@ -147,9 +159,7 @@ mkl :: slinpack.mkl dlinpack.mkl clinpack.mkl zlinpack.mkl \ else -goto :: slinpack.goto dlinpack.goto clinpack.goto zlinpack.goto \ - scholesky.goto dcholesky.goto ccholesky.goto zcholesky.goto \ - sgemm.goto dgemm.goto cgemm.goto zgemm.goto \ +goto :: sgemm.goto dgemm.goto cgemm.goto zgemm.goto \ strmm.goto dtrmm.goto ctrmm.goto ztrmm.goto \ strsm.goto dtrsm.goto ctrsm.goto ztrsm.goto \ ssyrk.goto dsyrk.goto csyrk.goto zsyrk.goto \ @@ -162,20 +172,16 @@ goto :: slinpack.goto dlinpack.goto clinpack.goto zlinpack.goto \ sswap.goto dswap.goto cswap.goto zswap.goto \ sscal.goto dscal.goto cscal.goto zscal.goto \ sasum.goto dasum.goto casum.goto zasum.goto \ - ssymv.goto dsymv.goto csymv.goto zsymv.goto \ + ssymv.goto dsymv.goto \ chemv.goto zhemv.goto \ chemm.goto zhemm.goto \ cherk.goto zherk.goto \ cher2k.goto zher2k.goto \ sgemv.goto dgemv.goto cgemv.goto zgemv.goto \ - sgesv.goto dgesv.goto cgesv.goto zgesv.goto \ - sgeev.goto dgeev.goto cgeev.goto zgeev.goto \ - sgetri.goto dgetri.goto cgetri.goto zgetri.goto \ - spotrf.goto dpotrf.goto cpotrf.goto zpotrf.goto \ ssymm.goto dsymm.goto csymm.goto zsymm.goto \ smallscaling \ isamax.goto idamax.goto icamax.goto izamax.goto \ - snrm2.goto dnrm2.goto scnrm2.goto dznrm2.goto + snrm2.goto dnrm2.goto scnrm2.goto dznrm2.goto $(GOTO_LAPACK_TARGETS) acml :: slinpack.acml dlinpack.acml clinpack.acml zlinpack.acml \ scholesky.acml dcholesky.acml ccholesky.acml zcholesky.acml \ diff --git a/benchmark/iamax.c b/benchmark/iamax.c index c55f415796..034e24ea91 100644 --- a/benchmark/iamax.c +++ b/benchmark/iamax.c @@ -149,7 +149,7 @@ int main(int argc, char *argv[]){ srandom(getpid()); #endif - fprintf(stderr, " SIZE Time\n"); + fprintf(stderr, " SIZE Flops\n"); for(m = from; m <= to; m += step) { @@ -180,7 +180,9 @@ int main(int argc, char *argv[]){ timeg /= loops; - fprintf(stderr, " %10.6f secs\n", timeg); + fprintf(stderr, + " %10.2f MFlops %10.6f sec\n", + COMPSIZE * sizeof(FLOAT) * 1. * (double)m / timeg * 1.e-6, timeg); } diff --git a/benchmark/nrm2.c b/benchmark/nrm2.c index 691f28c34e..d3718f9e05 100644 --- a/benchmark/nrm2.c +++ b/benchmark/nrm2.c @@ -149,7 +149,7 @@ int main(int argc, char *argv[]){ srandom(getpid()); #endif - fprintf(stderr, " SIZE Time\n"); + fprintf(stderr, " SIZE Flops\n"); for(m = from; m <= to; m += step) { @@ -180,7 +180,10 @@ int main(int argc, char *argv[]){ timeg /= loops; - fprintf(stderr, " %10.6f secs\n", timeg); + fprintf(stderr, + " %10.2f MFlops %10.6f sec\n", + COMPSIZE * COMPSIZE * 2. * (double)m / timeg * 1.e-6, timeg); + } diff --git a/benchmark/scripts/R/deig.R b/benchmark/scripts/R/deig.R index 3521c7c5a2..ece727fb37 100755 --- a/benchmark/scripts/R/deig.R +++ b/benchmark/scripts/R/deig.R @@ -2,61 +2,54 @@ argv <- commandArgs(trailingOnly = TRUE) -nfrom = 128 -nto = 2048 -nstep = 128 -loops = 1 - -if ( length(argv) > 0 ) { - - for ( z in 1:length(argv) ) { - - if ( z == 1 ) { - nfrom <- as.numeric(argv[z]) - } else if ( z==2 ) { - nto <- as.numeric(argv[z]) - } else if ( z==3 ) { - nstep <- as.numeric(argv[z]) - } else if ( z==4 ) { - loops <- as.numeric(argv[z]) - } - } +nfrom <- 128 +nto <- 2048 +nstep <- 128 +loops <- 1 + +if (length(argv) > 0) { + for (z in 1:length(argv)) { + if (z == 1) { + nfrom <- as.numeric(argv[z]) + } else if (z == 2) { + nto <- as.numeric(argv[z]) + } else if (z == 3) { + nstep <- as.numeric(argv[z]) + } else if (z == 4) { + loops <- as.numeric(argv[z]) + } + } } -p=Sys.getenv("OPENBLAS_LOOPS") -if ( p != "" ) { - loops <- as.numeric(p) -} +p <- Sys.getenv("OPENBLAS_LOOPS") +if (p != "") { + loops <- as.numeric(p) +} -cat(sprintf("From %.0f To %.0f Step=%.0f Loops=%.0f\n",nfrom, nto, nstep, loops)) +cat(sprintf( + "From %.0f To %.0f Step=%.0f Loops=%.0f\n", + nfrom, + nto, + nstep, + loops +)) cat(sprintf(" SIZE Flops Time\n")) -n = nfrom -while ( n <= nto ) { - - A <- matrix(runif(n*n), ncol = n, nrow = n, byrow = TRUE) - - l = 1 - - start <- proc.time()[3] - - while ( l <= loops ) { +n <- nfrom +while (n <= nto) { + A <- matrix(rnorm(n * n), ncol = n, nrow = n) + ev <- 0 + z <- system.time(for (l in 1:loops) { + ev <- eigen(A) + }) - ev <- eigen(A) - l = l + 1 - } + mflops <- (26.66 * n * n * n) * loops / (z[3] * 1.0e6) - end <- proc.time()[3] - timeg = end - start - mflops = (26.66 *n*n*n ) * loops / ( timeg * 1.0e6 ) + st <- sprintf("%.0fx%.0f :", n, n) + cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, z[3])) - st = sprintf("%.0fx%.0f :",n , n) - cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, timeg)) - - n = n + nstep + n <- n + nstep } - - diff --git a/benchmark/scripts/R/dgemm.R b/benchmark/scripts/R/dgemm.R index f1c09c38d5..75297dfb83 100755 --- a/benchmark/scripts/R/dgemm.R +++ b/benchmark/scripts/R/dgemm.R @@ -2,62 +2,63 @@ argv <- commandArgs(trailingOnly = TRUE) -nfrom = 128 -nto = 2048 -nstep = 128 -loops = 1 - -if ( length(argv) > 0 ) { - - for ( z in 1:length(argv) ) { - - if ( z == 1 ) { - nfrom <- as.numeric(argv[z]) - } else if ( z==2 ) { - nto <- as.numeric(argv[z]) - } else if ( z==3 ) { - nstep <- as.numeric(argv[z]) - } else if ( z==4 ) { - loops <- as.numeric(argv[z]) - } - } +nfrom <- 128 +nto <- 2048 +nstep <- 128 +loops <- 1 + +if (length(argv) > 0) { + for (z in 1:length(argv)) { + if (z == 1) { + nfrom <- as.numeric(argv[z]) + } else if (z == 2) { + nto <- as.numeric(argv[z]) + } else if (z == 3) { + nstep <- as.numeric(argv[z]) + } else if (z == 4) { + loops <- as.numeric(argv[z]) + } + } } -p=Sys.getenv("OPENBLAS_LOOPS") -if ( p != "" ) { - loops <- as.numeric(p) -} +p <- Sys.getenv("OPENBLAS_LOOPS") +if (p != "") { + loops <- as.numeric(p) +} -cat(sprintf("From %.0f To %.0f Step=%.0f Loops=%.0f\n",nfrom, nto, nstep, loops)) +cat(sprintf( + "From %.0f To %.0f Step=%.0f Loops=%.0f\n", + nfrom, + nto, + nstep, + loops +)) cat(sprintf(" SIZE Flops Time\n")) -n = nfrom -while ( n <= nto ) { - - A <- matrix(runif(n*n), ncol = n, nrow = n, byrow = TRUE) - B <- matrix(runif(n*n), ncol = n, nrow = n, byrow = TRUE) - - l = 1 - - start <- proc.time()[3] +n <- nfrom +while (n <= nto) { + A <- matrix(runif(n * n), + ncol = n, + nrow = n, + byrow = TRUE) + B <- matrix(runif(n * n), + ncol = n, + nrow = n, + byrow = TRUE) + C <- 1 - while ( l <= loops ) { + z <- system.time(for (l in 1:loops) { + C <- A %*% B + l <- l + 1 + }) - C <- A %*% B - l = l + 1 - } + mflops <- (2.0 * n * n * n) * loops / (z[3] * 1.0e6) - end <- proc.time()[3] - timeg = end - start - mflops = ( 2.0 *n*n*n ) * loops / ( timeg * 1.0e6 ) + st <- sprintf("%.0fx%.0f :", n, n) + cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, z[3])) - st = sprintf("%.0fx%.0f :",n , n) - cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, timeg)) - - n = n + nstep + n <- n + nstep } - - diff --git a/benchmark/scripts/R/dsolve.R b/benchmark/scripts/R/dsolve.R index 6c6b77f704..a3fb78da71 100755 --- a/benchmark/scripts/R/dsolve.R +++ b/benchmark/scripts/R/dsolve.R @@ -2,62 +2,56 @@ argv <- commandArgs(trailingOnly = TRUE) -nfrom = 128 -nto = 2048 -nstep = 128 -loops = 1 - -if ( length(argv) > 0 ) { - - for ( z in 1:length(argv) ) { - - if ( z == 1 ) { - nfrom <- as.numeric(argv[z]) - } else if ( z==2 ) { - nto <- as.numeric(argv[z]) - } else if ( z==3 ) { - nstep <- as.numeric(argv[z]) - } else if ( z==4 ) { - loops <- as.numeric(argv[z]) - } - } +nfrom <- 128 +nto <- 2048 +nstep <- 128 +loops <- 1 + +if (length(argv) > 0) { + for (z in 1:length(argv)) { + if (z == 1) { + nfrom <- as.numeric(argv[z]) + } else if (z == 2) { + nto <- as.numeric(argv[z]) + } else if (z == 3) { + nstep <- as.numeric(argv[z]) + } else if (z == 4) { + loops <- as.numeric(argv[z]) + } + } } -p=Sys.getenv("OPENBLAS_LOOPS") -if ( p != "" ) { - loops <- as.numeric(p) -} +p <- Sys.getenv("OPENBLAS_LOOPS") +if (p != "") { + loops <- as.numeric(p) +} -cat(sprintf("From %.0f To %.0f Step=%.0f Loops=%.0f\n",nfrom, nto, nstep, loops)) +cat(sprintf( + "From %.0f To %.0f Step=%.0f Loops=%.0f\n", + nfrom, + nto, + nstep, + loops +)) cat(sprintf(" SIZE Flops Time\n")) -n = nfrom -while ( n <= nto ) { - - A <- matrix(runif(n*n), ncol = n, nrow = n, byrow = TRUE) - B <- matrix(runif(n*n), ncol = n, nrow = n, byrow = TRUE) - - l = 1 - - start <- proc.time()[3] +n <- nfrom +while (n <= nto) { + A <- matrix(rnorm(n * n), ncol = n, nrow = n) + B <- matrix(rnorm(n * n), ncol = n, nrow = n) - while ( l <= loops ) { + z <- system.time(for (l in 1:loops) { + solve(A, B) + }) - solve(A,B) - l = l + 1 - } + mflops <- + (2.0 / 3.0 * n * n * n + 2.0 * n * n * n) * loops / (z[3] * 1.0e6) - end <- proc.time()[3] - timeg = end - start - mflops = (2.0/3.0 *n*n*n + 2.0 *n*n*n ) * loops / ( timeg * 1.0e6 ) + st <- sprintf("%.0fx%.0f :", n, n) + cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, z[3])) - st = sprintf("%.0fx%.0f :",n , n) - cat(sprintf("%20s %10.2f MFlops %10.6f sec\n", st, mflops, timeg)) - - n = n + nstep + n <- n + nstep } - - diff --git a/c_check b/c_check index 2ec9fc484b..20da288bec 100644 --- a/c_check +++ b/c_check @@ -10,6 +10,7 @@ $hostarch = "x86_64" if ($hostarch eq "amd64"); $hostarch = "arm" if ($hostarch =~ /^arm.*/); $hostarch = "arm64" if ($hostarch eq "aarch64"); $hostarch = "power" if ($hostarch =~ /^(powerpc|ppc).*/); +$hostarch = "zarch" if ($hostarch eq "s390x"); $tmpf = new File::Temp( UNLINK => 1 ); $binary = $ENV{"BINARY"}; @@ -34,7 +35,7 @@ if (dirname($compiler_name) ne ".") { $cross_suffix .= dirname($compiler_name) . "/"; } -if (basename($compiler_name) =~ /(.*-)(.*)/) { +if (basename($compiler_name) =~ /([^\s]*-)(.*)/) { $cross_suffix .= $1; } @@ -72,6 +73,7 @@ $architecture = sparc if ($data =~ /ARCH_SPARC/); $architecture = ia64 if ($data =~ /ARCH_IA64/); $architecture = arm if ($data =~ /ARCH_ARM/); $architecture = arm64 if ($data =~ /ARCH_ARM64/); +$architecture = zarch if ($data =~ /ARCH_ZARCH/); $defined = 0; @@ -96,6 +98,11 @@ if (($architecture eq "arm") || ($architecture eq "arm64")) { $defined = 1; } +if ($architecture eq "zarch") { + $defined = 1; + $binary = 64; +} + if ($architecture eq "alpha") { $defined = 1; $binary = 64; @@ -187,6 +194,7 @@ $architecture = sparc if ($data =~ /ARCH_SPARC/); $architecture = ia64 if ($data =~ /ARCH_IA64/); $architecture = arm if ($data =~ /ARCH_ARM/); $architecture = arm64 if ($data =~ /ARCH_ARM64/); +$architecture = zarch if ($data =~ /ARCH_ZARCH/); $binformat = bin32; $binformat = bin64 if ($data =~ /BINARY_64/); @@ -234,6 +242,11 @@ $linker_a = ""; $linker_L .= "-Wl,". $flags . " " } + if ($flags =~ /^\--exclude-libs/) { + $linker_L .= "-Wl,". $flags . " "; + $flags=""; + } + if ( ($flags =~ /^\-l/) && ($flags !~ /gfortranbegin/) diff --git a/cmake/arch.cmake b/cmake/arch.cmake index 0f66a98ca7..d32d4fc24f 100644 --- a/cmake/arch.cmake +++ b/cmake/arch.cmake @@ -73,7 +73,7 @@ if (DYNAMIC_ARCH) set(DYNAMIC_CORE "${DYNAMIC_CORE} SANDYBRIDGE BULLDOZER PILEDRIVER STEAMROLLER") endif () if (NOT NO_AVX2) - set(DYNAMIC_CORE "${DYNAMIC_CORE} HASWELL") + set(DYNAMIC_CORE "${DYNAMIC_CORE} HASWELL ZEN") endif () endif () diff --git a/cmake/c_check.cmake b/cmake/c_check.cmake index 89ec31446a..56ae612ea8 100644 --- a/cmake/c_check.cmake +++ b/cmake/c_check.cmake @@ -73,6 +73,10 @@ if (${ARCH} STREQUAL "X86") set(ARCH x86) endif () +if (${ARCH} MATCHES "ppc") + set(ARCH power) +endif () + set(COMPILER_ID ${CMAKE_CXX_COMPILER_ID}) if (${COMPILER_ID} STREQUAL "GNU") set(COMPILER_ID "GCC") @@ -87,3 +91,8 @@ file(WRITE ${TARGET_CONF} "#define __${BINARY}BIT__\t1\n" "#define FUNDERSCORE\t${FU}\n") +if (${HOST_OS} STREQUAL "WINDOWSSTORE") + file(APPEND ${TARGET_CONF} + "#define OS_WINNT\t1\n") +endif () + diff --git a/cmake/fc.cmake b/cmake/fc.cmake index ba156c2107..ee9d2051b6 100644 --- a/cmake/fc.cmake +++ b/cmake/fc.cmake @@ -3,6 +3,21 @@ ## Description: Ported from portion of OpenBLAS/Makefile.system ## Sets Fortran related variables. +if (${F_COMPILER} STREQUAL "FLANG") + set(CCOMMON_OPT "${CCOMMON_OPT} -DF_INTERFACE_FLANG") + if (BINARY64) + if (INTERFACE64) + set(FCOMMON_OPT "${FCOMMON_OPT} -i8") + endif () + set(FCOMMON_OPT "${FCOMMON_OPT} -Wall") + else () + set(FCOMMON_OPT "${FCOMMON_OPT} -Wall") + endif () + if (USE_OPENMP) + set(FCOMMON_OPT "${FCOMMON_OPT} -fopenmp") + endif () +endif () + if (${F_COMPILER} STREQUAL "G77") set(CCOMMON_OPT "${CCOMMON_OPT} -DF_INTERFACE_G77") set(FCOMMON_OPT "${FCOMMON_OPT} -Wall") diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index d124ebc6e9..e6cd5373d3 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -2,7 +2,7 @@ set(ALLAUX ilaenv.f ieeeck.f lsamen.f xerbla_array.f iparmq.f - ilaprec.f ilatrans.f ilauplo.f iladiag.f chla_transtype.f + ilaprec.f ilatrans.f ilauplo.f iladiag.f iparam2stage.F chla_transtype.f ../INSTALL/ilaver.f ../INSTALL/slamch.f ) @@ -26,7 +26,7 @@ set(SCLAUX ) set(DZLAUX - dbdsdc.f + dbdsdc.f dbdsvdx.f dbdsqr.f ddisna.f dlabad.f dlacpy.f dladiv.f dlae2.f dlaebz.f dlaed0.f dlaed1.f dlaed2.f dlaed3.f dlaed4.f dlaed5.f dlaed6.f dlaed7.f dlaed8.f dlaed9.f dlaeda.f dlaev2.f dlagtf.f @@ -42,20 +42,28 @@ set(DZLAUX dsteqr.f dsterf.f dlaisnan.f disnan.f dlartgp.f dlartgs.f ../INSTALL/dlamch.f ../INSTALL/dsecnd_${TIMER}.f + dgelq.f dgelqt.f dgelqt3.f dgemlq.f dgemlqt.f dgemqr.f dgeqr.f + dgetsls.f dlamswlq.f dlamtsqr.f dlaswlq.f dlatsqr.f dtplqt.f + dtplqt2.f dtpmlqt.f dsysv_aa.f dsytrf_aa.f dsytrs_aa.f dlasyf_aa.f + dsytf2_rk.f dlasyf_rk.f dsytrf_rk.f dsytrs_3.f dsycon_3.f dsytri_3.f + dsytri_3x.f dsysv_rk.f dsb2st_kernels.f dsbev_2stage.f dsbevd_2stage.f + dsbevx_2stage.f dsyev_2stage.f dsyevd_2stage.f dsyevr_2stage.f + dsyevx_2stage.f dsygv_2stage.f dsytrd_2stage.f dsytrd_sb2st.F + dsytrd_sy2sb.f dlarfy.f ) set(SLASRC - sgbbrd.f sgbcon.f sgbequ.f sgbrfs.f sgbsv.f + sbdsvdx.f sgbbrd.f sgbcon.f sgbequ.f sgbrfs.f sgbsv.f sgbsvx.f sgbtf2.f sgbtrf.f sgbtrs.f sgebak.f sgebal.f sgebd2.f sgebrd.f sgecon.f sgeequ.f sgees.f sgeesx.f sgeev.f sgeevx.f DEPRECATED/sgegs.f DEPRECATED/sgegv.f sgehd2.f sgehrd.f sgelq2.f sgelqf.f sgels.f sgelsd.f sgelss.f DEPRECATED/sgelsx.f sgelsy.f sgeql2.f sgeqlf.f sgeqp3.f DEPRECATED/sgeqpf.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f - sgerq2.f sgerqf.f sgesc2.f sgesdd.f sgesvd.f sgesvx.f - sgetc2.f sgetri.f - sggbak.f sggbal.f sgges.f sggesx.f sggev.f sggevx.f + sgerq2.f sgerqf.f sgesc2.f sgesdd.f sgesvd.f sgesvdx.f sgesvx.f + sgetc2.f sgetri.f sgetrf2.f + sggbak.f sggbal.f sgghd3.f sgges.f sgges3.f sggesx.f sggev.f sggev3.f sggevx.f sggglm.f sgghrd.f sgglse.f sggqrf.f - sggrqf.f DEPRECATED/sggsvd.f DEPRECATED/sggsvp.f sgtcon.f sgtrfs.f sgtsv.f + sggrqf.f DEPRECATED/sggsvd.f sggsvd3.f DEPRECATED/sggsvp.f sggsvp3.f sgtcon.f sgtrfs.f sgtsv.f sgtsvx.f sgttrf.f sgttrs.f sgtts2.f shgeqz.f shsein.f shseqr.f slabrd.f slacon.f slacn2.f slaein.f slaexc.f slag2.f slags2.f slagtm.f slagv2.f slahqr.f @@ -72,7 +80,7 @@ set(SLASRC slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f DEPRECATED/slatzm.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f - sorgrq.f sorgtr.f sorm2l.f sorm2r.f + sorgrq.f sorgtr.f sorm2l.f sorm2r.f sorm22.f sormbr.f sormhr.f sorml2.f sormlq.f sormql.f sormqr.f sormr2.f sormr3.f sormrq.f sormrz.f sormtr.f spbcon.f spbequ.f spbrfs.f spbstf.f spbsv.f spbsvx.f @@ -96,7 +104,7 @@ set(SLASRC stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f stptrs.f - strcon.f strevc.f strexc.f strrfs.f strsen.f strsna.f strsyl.f + strcon.f strevc.f strevc3.f strexc.f strrfs.f strsen.f strsna.f strsyl.f strtrs.f DEPRECATED/stzrqf.f stzrzf.f sstemr.f slansf.f spftrf.f spftri.f spftrs.f ssfrk.f stfsm.f stftri.f stfttp.f stfttr.f stpttf.f stpttr.f strttf.f strttp.f @@ -106,9 +114,16 @@ set(SLASRC sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f stpqrt.f stpqrt2.f stpmqrt.f stprfb.f spotri.f + sgelq.f sgelqt.f sgelqt3.f sgemlq.f sgemlqt.f sgemqr.f sgeqr.f sgetsls.f + slamswlq.f slamtsqr.f slaswlq.f slatsqr.f stplqt.f stplqt2.f stpmlqt.f + ssysv_aa.f ssytrf_aa.f ssytrs_aa.f slasyf_aa.f ssytf2_rk.f slasyf_rk.f + ssytrf_rk.f ssytrs_3.f ssycon_3.f ssytri_3.f ssytri_3x.f ssysv_rk.f + ssb2st_kernels.f ssbev_2stage.f ssbevd_2stage.f ssbevx_2stage.f + ssyev_2stage.f ssyevd_2stage.f ssyevr_2stage.f ssyevx_2stage.f + ssygv_2stage.f ssytrd_2stage.f ssytrd_sb2st.F ssytrd_sy2sb.f slarfy.f ) -set(DSLASRC spotrs.f) +set(DSLASRC spotrs.f spotrf2.f) set(CLASRC cbdsqr.f cgbbrd.f cgbcon.f cgbequ.f cgbrfs.f cgbsv.f cgbsvx.f @@ -165,7 +180,7 @@ set(CLASRC ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f ctprfs.f ctptri.f - ctptrs.f ctrcon.f ctrevc.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f + ctptrs.f ctrcon.f ctrevc.f ctrevc3.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f ctrsyl.f ctrtrs.f DEPRECATED/ctzrqf.f ctzrzf.f cung2l.f cung2r.f cungbr.f cunghr.f cungl2.f cunglq.f cungql.f cungqr.f cungr2.f cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f @@ -178,6 +193,14 @@ set(CLASRC cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f cpotri.f + cgelq.f cgelqt.f cgelqt3.f cgemlq.f cgemlqt.f cgemqr.f cgeqr.f cgetsls.f + clamswlq.f clamtsqr.f claswlq.f clatsqr.f ctplqt.f ctplqt2.f ctpmlqt.f + chesv_aa.f chetrf_aa.f chetrs_aa.f clahef_aa.f csytf2_rk.f clasyf_rk.f + csytrf_rk.f csytrs_3.f csycon_3.f csytri_3.f csytri_3x.f csysv_rk.f + chetf2_rk.f clahef_rk.f chetrf_rk.f chetrs_3.f checon_3.f chetri_3.f + chetri_3x.f chesv_rk.f chb2st_kernels.f chbev_2stage.f chbevd_2stage.f + chbevx_2stage.f cheev_2stage.f cheevd_2stage.f cheevr_2stage.f cheevx_2stage.f + chegv_2stage.f chetrd_2stage.f chetrd_hb2st.F chetrd_he2hb.f clarfy.f ) set(ZCLASRC cpotrs.f) @@ -189,11 +212,11 @@ set(DLASRC DEPRECATED/dgegs.f DEPRECATED/dgegv.f dgehd2.f dgehrd.f dgelq2.f dgelqf.f dgels.f dgelsd.f dgelss.f DEPRECATED/dgelsx.f dgelsy.f dgeql2.f dgeqlf.f dgeqp3.f DEPRECATED/dgeqpf.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f - dgerq2.f dgerqf.f dgesc2.f dgesdd.f dgesvd.f dgesvx.f - dgetc2.f dgetri.f - dggbak.f dggbal.f dgges.f dggesx.f dggev.f dggevx.f - dggglm.f dgghrd.f dgglse.f dggqrf.f - dggrqf.f DEPRECATED/dggsvd.f DEPRECATED/dggsvp.f dgtcon.f dgtrfs.f dgtsv.f + dgerq2.f dgerqf.f dgesc2.f dgesdd.f dgesvd.f dgesvdx.f dgesvx.f + dgetc2.f dgetri.f dgetrf2.f + dggbak.f dggbal.f dgges.f dgges3.f dggesx.f dggev.f dggev3.f dggevx.f + dggglm.f dgghd3.f dgghrd.f dgglse.f dggqrf.f + dggrqf.f dggsvd3.f dggsvp3.f DEPRECATED/dggsvd.f DEPRECATED/dggsvp.f dgtcon.f dgtrfs.f dgtsv.f dgtsvx.f dgttrf.f dgttrs.f dgtts2.f dhgeqz.f dhsein.f dhseqr.f dlabrd.f dlacon.f dlacn2.f dlaein.f dlaexc.f dlag2.f dlags2.f dlagtm.f dlagv2.f dlahqr.f @@ -210,12 +233,12 @@ set(DLASRC dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f DEPRECATED/dlatzm.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f - dorgrq.f dorgtr.f dorm2l.f dorm2r.f + dorgrq.f dorgtr.f dorm2l.f dorm2r.f dorm22.f dormbr.f dormhr.f dorml2.f dormlq.f dormql.f dormqr.f dormr2.f dormr3.f dormrq.f dormrz.f dormtr.f dpbcon.f dpbequ.f dpbrfs.f dpbstf.f dpbsv.f dpbsvx.f dpbtf2.f dpbtrf.f dpbtrs.f dpocon.f dpoequ.f dporfs.f dposv.f - dposvx.f dpotrs.f dpstrf.f dpstf2.f + dposvx.f dpotrf2.f dpotrs.f dpstrf.f dpstf2.f dppcon.f dppequ.f dpprfs.f dppsv.f dppsvx.f dpptrf.f dpptri.f dpptrs.f dptcon.f dpteqr.f dptrfs.f dptsv.f dptsvx.f dpttrs.f dptts2.f drscl.f @@ -234,7 +257,7 @@ set(DLASRC dtbcon.f dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f dtptrs.f - dtrcon.f dtrevc.f dtrexc.f dtrrfs.f dtrsen.f dtrsna.f dtrsyl.f + dtrcon.f dtrevc.f dtrevc3.f dtrexc.f dtrrfs.f dtrsen.f dtrsna.f dtrsyl.f dtrtrs.f DEPRECATED/dtzrqf.f dtzrzf.f dstemr.f dsgesv.f dsposv.f dlag2s.f slag2d.f dlat2s.f dlansf.f dpftrf.f dpftri.f dpftrs.f dsfrk.f dtfsm.f dtftri.f dtfttp.f @@ -245,20 +268,28 @@ set(DLASRC dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f dpotri.f + dgelq.f dgelqt.f dgelqt3.f dgemlq.f dgemlqt.f dgemqr.f dgeqr.f dgetsls.f + dlamswlq.f dlamtsqr.f dlaswlq.f dlatsqr.f dtplqt.f dtplqt2.f dtpmlqt.f + dsysv_aa.f dsytrf_aa.f dsytrs_aa.f dlasyf_aa.f dsytf2_rk.f dlasyf_rk.f + dsytrf_rk.f dsytrs_3.f dsycon_3.f dsytri_3.f dsytri_3x.f dsysv_rk.f + dsb2st_kernels.f dsbev_2stage.f dsbevd_2stage.f dsbevx_2stage.f + dsyev_2stage.f dsyevd_2stage.f dsyevr_2stage.f dsyevx_2stage.f + dsygv_2stage.f dsytrd_2stage.f dsytrd_sb2st.F dsytrd_sy2sb.f dlarfy.f ) set(ZLASRC zbdsqr.f zgbbrd.f zgbcon.f zgbequ.f zgbrfs.f zgbsv.f zgbsvx.f zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f - DEPRECATED/zgegs.f DEPRECATED/zgegv.f zgehd2.f zgehrd.f zgelq2.f zgelqf.f + DEPRECATED/zgegs.f DEPRECATED/zgegv.f zgehd2.f zgehrd.f zgejsv.f zgelq2.f zgelqf.f zgels.f zgelsd.f zgelss.f DEPRECATED/zgelsx.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f DEPRECATED/zgeqpf.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f - zgesc2.f zgesdd.f zgesvd.f zgesvx.f zgetc2.f - zgetri.f - zggbak.f zggbal.f zgges.f zggesx.f zggev.f zggevx.f zggglm.f - zgghrd.f zgglse.f zggqrf.f zggrqf.f - DEPRECATED/zggsvd.f DEPRECATED/zggsvp.f + zgesc2.f zgesdd.f zgesvd.f zgesvdx.f zgesvj.f zgesvx.f zgetc2.f + zgetri.f zgetrf2.f + zggbak.f zggbal.f zgges.f zgges3.f zggesx.f zggev.f zggev3.f zggevx.f zggglm.f + zgghd3.f zgghrd.f zgglse.f zggqrf.f zggrqf.f + DEPRECATED/zggsvd.f zggsvd3.f DEPRECATED/zggsvp.f zggsvp3.f + zgsvj0.f zgsvj1.f zgtcon.f zgtrfs.f zgtsv.f zgtsvx.f zgttrf.f zgttrs.f zgtts2.f zhbev.f zhbevd.f zhbevx.f zhbgst.f zhbgv.f zhbgvd.f zhbgvx.f zhbtrd.f zhecon.f zheev.f zheevd.f zheevr.f zheevx.f zhegs2.f zhegst.f @@ -287,28 +318,28 @@ set(ZLASRC zlarfg.f zlarft.f zlarfgp.f zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f - zlassq.f zlasyf.f zlasyf_rook.f + zlassq.f zlasyf.f zlasyf_rook.f zlasyf_aa.f zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f DEPRECATED/zlatzm.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f - zposv.f zposvx.f zpotrs.f zpstrf.f zpstf2.f + zposv.f zposvx.f zpotrf2.f zpotrs.f zpstrf.f zpstf2.f zppcon.f zppequ.f zpprfs.f zppsv.f zppsvx.f zpptrf.f zpptri.f zpptrs.f zptcon.f zpteqr.f zptrfs.f zptsv.f zptsvx.f zpttrf.f zpttrs.f zptts2.f zrot.f zspcon.f zsprfs.f zspsv.f zspsvx.f zsptrf.f zsptri.f zsptrs.f zdrscl.f zstedc.f zstegr.f zstein.f zsteqr.f - zsycon.f + zsycon.f zsysv_aa.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f zsytri2.f zsytri2x.f - zsyswapr.f zsytrs.f zsytrs2.f zsyconv.f + zsyswapr.f zsytrs.f zsytrs_aa.f zsytrs2.f zsyconv.f zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f zsytri_rook.f zsycon_rook.f zsysv_rook.f ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f ztprfs.f ztptri.f - ztptrs.f ztrcon.f ztrevc.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f + ztptrs.f ztrcon.f ztrevc.f ztrevc3.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f ztrsyl.f ztrtrs.f DEPRECATED/ztzrqf.f ztzrzf.f zung2l.f zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f zungqr.f zungr2.f - zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f + zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunm22.f zunml2.f zunmlq.f zunmql.f zunmqr.f zunmr2.f zunmr3.f zunmrq.f zunmrz.f zunmtr.f zupgtr.f zupmtr.f izmax1.f dzsum1.f zstemr.f @@ -320,6 +351,15 @@ set(ZLASRC zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f zpotri.f + zgelq.f zgelqt.f zgelqt3.f zgemlq.f zgemlqt.f zgemqr.f zgeqr.f zgetsls.f + zlamswlq.f zlamtsqr.f zlaswlq.f zlatsqr.f ztplqt.f ztplqt2.f ztpmlqt.f + zhesv_aa.f zhetrf_aa.f zhetrs_aa.f zlahef_aa.f zsytf2_rk.f zlasyf_rk.f + zsytrf_aa.f zsytrf_rk.f zsytrs_3.f zsycon_3.f zsytri_3.f zsytri_3x.f zsysv_rk.f + zhetf2_rk.f zlahef_rk.f zhetrf_rk.f zhetrs_3.f zhecon_3.f zhetri_3.f + zhetri_3x.f zhesv_rk.f zhb2st_kernels.f zhbev_2stage.f zhbevd_2stage.f + zhbevx_2stage.f zheev_2stage.f zheevd_2stage.f zheevr_2stage.f + zheevx_2stage.f zhegv_2stage.f zhetrd_2stage.f zhetrd_hb2st.F zhetrd_he2hb.f + zlarfy.f ) set(LA_REL_SRC ${ALLAUX}) diff --git a/cmake/lapacke.cmake b/cmake/lapacke.cmake index 23a4321a4a..f56a228863 100644 --- a/cmake/lapacke.cmake +++ b/cmake/lapacke.cmake @@ -1,1992 +1,2264 @@ set(C_SRC - lapacke_cbbcsd.c - lapacke_cbbcsd_work.c - lapacke_cbdsqr.c - lapacke_cbdsqr_work.c - lapacke_cgbbrd.c - lapacke_cgbbrd_work.c - lapacke_cgbcon.c - lapacke_cgbcon_work.c - lapacke_cgbequ.c - lapacke_cgbequ_work.c - lapacke_cgbequb.c - lapacke_cgbequb_work.c - lapacke_cgbrfs.c - lapacke_cgbrfs_work.c - lapacke_cgbsv.c - lapacke_cgbsv_work.c - lapacke_cgbsvx.c - lapacke_cgbsvx_work.c - lapacke_cgbtrf.c - lapacke_cgbtrf_work.c - lapacke_cgbtrs.c - lapacke_cgbtrs_work.c - lapacke_cgebak.c - lapacke_cgebak_work.c - lapacke_cgebal.c - lapacke_cgebal_work.c - lapacke_cgebrd.c - lapacke_cgebrd_work.c - lapacke_cgecon.c - lapacke_cgecon_work.c - lapacke_cgeequ.c - lapacke_cgeequ_work.c - lapacke_cgeequb.c - lapacke_cgeequb_work.c - lapacke_cgees.c - lapacke_cgees_work.c - lapacke_cgeesx.c - lapacke_cgeesx_work.c - lapacke_cgeev.c - lapacke_cgeev_work.c - lapacke_cgeevx.c - lapacke_cgeevx_work.c - lapacke_cgehrd.c - lapacke_cgehrd_work.c - lapacke_cgelq2.c - lapacke_cgelq2_work.c - lapacke_cgelqf.c - lapacke_cgelqf_work.c - lapacke_cgels.c - lapacke_cgels_work.c - lapacke_cgelsd.c - lapacke_cgelsd_work.c - lapacke_cgelss.c - lapacke_cgelss_work.c - lapacke_cgelsy.c - lapacke_cgelsy_work.c - lapacke_cgemqrt.c - lapacke_cgemqrt_work.c - lapacke_cgeqlf.c - lapacke_cgeqlf_work.c - lapacke_cgeqp3.c - lapacke_cgeqp3_work.c - lapacke_cgeqpf.c - lapacke_cgeqpf_work.c - lapacke_cgeqr2.c - lapacke_cgeqr2_work.c - lapacke_cgeqrf.c - lapacke_cgeqrf_work.c - lapacke_cgeqrfp.c - lapacke_cgeqrfp_work.c - lapacke_cgeqrt.c - lapacke_cgeqrt2.c - lapacke_cgeqrt2_work.c - lapacke_cgeqrt3.c - lapacke_cgeqrt3_work.c - lapacke_cgeqrt_work.c - lapacke_cgerfs.c - lapacke_cgerfs_work.c - lapacke_cgerqf.c - lapacke_cgerqf_work.c - lapacke_cgesdd.c - lapacke_cgesdd_work.c - lapacke_cgesv.c - lapacke_cgesv_work.c - lapacke_cgesvd.c - lapacke_cgesvd_work.c - lapacke_cgesvx.c - lapacke_cgesvx_work.c - lapacke_cgetf2.c - lapacke_cgetf2_work.c - lapacke_cgetrf.c - lapacke_cgetrf_work.c - lapacke_cgetri.c - lapacke_cgetri_work.c - lapacke_cgetrs.c - lapacke_cgetrs_work.c - lapacke_cggbak.c - lapacke_cggbak_work.c - lapacke_cggbal.c - lapacke_cggbal_work.c - lapacke_cgges.c - lapacke_cgges_work.c - lapacke_cggesx.c - lapacke_cggesx_work.c - lapacke_cggev.c - lapacke_cggev_work.c - lapacke_cggevx.c - lapacke_cggevx_work.c - lapacke_cggglm.c - lapacke_cggglm_work.c - lapacke_cgghrd.c - lapacke_cgghrd_work.c - lapacke_cgglse.c - lapacke_cgglse_work.c - lapacke_cggqrf.c - lapacke_cggqrf_work.c - lapacke_cggrqf.c - lapacke_cggrqf_work.c - lapacke_cggsvd.c - lapacke_cggsvd_work.c - lapacke_cggsvp.c - lapacke_cggsvp_work.c - lapacke_cgtcon.c - lapacke_cgtcon_work.c - lapacke_cgtrfs.c - lapacke_cgtrfs_work.c - lapacke_cgtsv.c - lapacke_cgtsv_work.c - lapacke_cgtsvx.c - lapacke_cgtsvx_work.c - lapacke_cgttrf.c - lapacke_cgttrf_work.c - lapacke_cgttrs.c - lapacke_cgttrs_work.c - lapacke_chbev.c - lapacke_chbev_work.c - lapacke_chbevd.c - lapacke_chbevd_work.c - lapacke_chbevx.c - lapacke_chbevx_work.c - lapacke_chbgst.c - lapacke_chbgst_work.c - lapacke_chbgv.c - lapacke_chbgv_work.c - lapacke_chbgvd.c - lapacke_chbgvd_work.c - lapacke_chbgvx.c - lapacke_chbgvx_work.c - lapacke_chbtrd.c - lapacke_chbtrd_work.c - lapacke_checon.c - lapacke_checon_work.c - lapacke_cheequb.c - lapacke_cheequb_work.c - lapacke_cheev.c - lapacke_cheev_work.c - lapacke_cheevd.c - lapacke_cheevd_work.c - lapacke_cheevr.c - lapacke_cheevr_work.c - lapacke_cheevx.c - lapacke_cheevx_work.c - lapacke_chegst.c - lapacke_chegst_work.c - lapacke_chegv.c - lapacke_chegv_work.c - lapacke_chegvd.c - lapacke_chegvd_work.c - lapacke_chegvx.c - lapacke_chegvx_work.c - lapacke_cherfs.c - lapacke_cherfs_work.c - lapacke_chesv.c - lapacke_chesv_work.c - lapacke_chesvx.c - lapacke_chesvx_work.c - lapacke_cheswapr.c - lapacke_cheswapr_work.c - lapacke_chetrd.c - lapacke_chetrd_work.c - lapacke_chetrf.c - lapacke_chetrf_work.c - lapacke_chetri.c - lapacke_chetri2.c - lapacke_chetri2_work.c - lapacke_chetri2x.c - lapacke_chetri2x_work.c - lapacke_chetri_work.c - lapacke_chetrs.c - lapacke_chetrs2.c - lapacke_chetrs2_work.c - lapacke_chetrs_work.c - lapacke_chfrk.c - lapacke_chfrk_work.c - lapacke_chgeqz.c - lapacke_chgeqz_work.c - lapacke_chpcon.c - lapacke_chpcon_work.c - lapacke_chpev.c - lapacke_chpev_work.c - lapacke_chpevd.c - lapacke_chpevd_work.c - lapacke_chpevx.c - lapacke_chpevx_work.c - lapacke_chpgst.c - lapacke_chpgst_work.c - lapacke_chpgv.c - lapacke_chpgv_work.c - lapacke_chpgvd.c - lapacke_chpgvd_work.c - lapacke_chpgvx.c - lapacke_chpgvx_work.c - lapacke_chprfs.c - lapacke_chprfs_work.c - lapacke_chpsv.c - lapacke_chpsv_work.c - lapacke_chpsvx.c - lapacke_chpsvx_work.c - lapacke_chptrd.c - lapacke_chptrd_work.c - lapacke_chptrf.c - lapacke_chptrf_work.c - lapacke_chptri.c - lapacke_chptri_work.c - lapacke_chptrs.c - lapacke_chptrs_work.c - lapacke_chsein.c - lapacke_chsein_work.c - lapacke_chseqr.c - lapacke_chseqr_work.c - lapacke_clacgv.c - lapacke_clacgv_work.c - lapacke_clacn2.c - lapacke_clacn2_work.c - lapacke_clacp2.c - lapacke_clacp2_work.c - lapacke_clacpy.c - lapacke_clacpy_work.c - lapacke_clag2z.c - lapacke_clag2z_work.c - lapacke_clange.c - lapacke_clange_work.c - lapacke_clanhe.c - lapacke_clanhe_work.c - lapacke_clansy.c - lapacke_clansy_work.c - lapacke_clantr.c - lapacke_clantr_work.c - lapacke_clapmr.c - lapacke_clapmr_work.c - lapacke_clarfb.c - lapacke_clarfb_work.c - lapacke_clarfg.c - lapacke_clarfg_work.c - lapacke_clarft.c - lapacke_clarft_work.c - lapacke_clarfx.c - lapacke_clarfx_work.c - lapacke_clarnv.c - lapacke_clarnv_work.c - lapacke_claset.c - lapacke_claset_work.c - lapacke_claswp.c - lapacke_claswp_work.c - lapacke_clauum.c - lapacke_clauum_work.c - lapacke_cpbcon.c - lapacke_cpbcon_work.c - lapacke_cpbequ.c - lapacke_cpbequ_work.c - lapacke_cpbrfs.c - lapacke_cpbrfs_work.c - lapacke_cpbstf.c - lapacke_cpbstf_work.c - lapacke_cpbsv.c - lapacke_cpbsv_work.c - lapacke_cpbsvx.c - lapacke_cpbsvx_work.c - lapacke_cpbtrf.c - lapacke_cpbtrf_work.c - lapacke_cpbtrs.c - lapacke_cpbtrs_work.c - lapacke_cpftrf.c - lapacke_cpftrf_work.c - lapacke_cpftri.c - lapacke_cpftri_work.c - lapacke_cpftrs.c - lapacke_cpftrs_work.c - lapacke_cpocon.c - lapacke_cpocon_work.c - lapacke_cpoequ.c - lapacke_cpoequ_work.c - lapacke_cpoequb.c - lapacke_cpoequb_work.c - lapacke_cporfs.c - lapacke_cporfs_work.c - lapacke_cposv.c - lapacke_cposv_work.c - lapacke_cposvx.c - lapacke_cposvx_work.c - lapacke_cpotrf.c - lapacke_cpotrf_work.c - lapacke_cpotri.c - lapacke_cpotri_work.c - lapacke_cpotrs.c - lapacke_cpotrs_work.c - lapacke_cppcon.c - lapacke_cppcon_work.c - lapacke_cppequ.c - lapacke_cppequ_work.c - lapacke_cpprfs.c - lapacke_cpprfs_work.c - lapacke_cppsv.c - lapacke_cppsv_work.c - lapacke_cppsvx.c - lapacke_cppsvx_work.c - lapacke_cpptrf.c - lapacke_cpptrf_work.c - lapacke_cpptri.c - lapacke_cpptri_work.c - lapacke_cpptrs.c - lapacke_cpptrs_work.c - lapacke_cpstrf.c - lapacke_cpstrf_work.c - lapacke_cptcon.c - lapacke_cptcon_work.c - lapacke_cpteqr.c - lapacke_cpteqr_work.c - lapacke_cptrfs.c - lapacke_cptrfs_work.c - lapacke_cptsv.c - lapacke_cptsv_work.c - lapacke_cptsvx.c - lapacke_cptsvx_work.c - lapacke_cpttrf.c - lapacke_cpttrf_work.c - lapacke_cpttrs.c - lapacke_cpttrs_work.c - lapacke_cspcon.c - lapacke_cspcon_work.c - lapacke_csprfs.c - lapacke_csprfs_work.c - lapacke_cspsv.c - lapacke_cspsv_work.c - lapacke_cspsvx.c - lapacke_cspsvx_work.c - lapacke_csptrf.c - lapacke_csptrf_work.c - lapacke_csptri.c - lapacke_csptri_work.c - lapacke_csptrs.c - lapacke_csptrs_work.c - lapacke_cstedc.c - lapacke_cstedc_work.c - lapacke_cstegr.c - lapacke_cstegr_work.c - lapacke_cstein.c - lapacke_cstein_work.c - lapacke_cstemr.c - lapacke_cstemr_work.c - lapacke_csteqr.c - lapacke_csteqr_work.c - lapacke_csycon.c - lapacke_csycon_work.c - lapacke_csyconv.c - lapacke_csyconv_work.c - lapacke_csyequb.c - lapacke_csyequb_work.c - lapacke_csyrfs.c - lapacke_csyrfs_work.c - lapacke_csysv.c - lapacke_csysv_rook.c - lapacke_csysv_rook_work.c - lapacke_csysv_work.c - lapacke_csysvx.c - lapacke_csysvx_work.c - lapacke_csyswapr.c - lapacke_csyswapr_work.c - lapacke_csytrf.c - lapacke_csytrf_work.c - lapacke_csytri.c - lapacke_csytri2.c - lapacke_csytri2_work.c - lapacke_csytri2x.c - lapacke_csytri2x_work.c - lapacke_csytri_work.c - lapacke_csytrs.c - lapacke_csytrs2.c - lapacke_csytrs2_work.c - lapacke_csytrs_work.c - lapacke_ctbcon.c - lapacke_ctbcon_work.c - lapacke_ctbrfs.c - lapacke_ctbrfs_work.c - lapacke_ctbtrs.c - lapacke_ctbtrs_work.c - lapacke_ctfsm.c - lapacke_ctfsm_work.c - lapacke_ctftri.c - lapacke_ctftri_work.c - lapacke_ctfttp.c - lapacke_ctfttp_work.c - lapacke_ctfttr.c - lapacke_ctfttr_work.c - lapacke_ctgevc.c - lapacke_ctgevc_work.c - lapacke_ctgexc.c - lapacke_ctgexc_work.c - lapacke_ctgsen.c - lapacke_ctgsen_work.c - lapacke_ctgsja.c - lapacke_ctgsja_work.c - lapacke_ctgsna.c - lapacke_ctgsna_work.c - lapacke_ctgsyl.c - lapacke_ctgsyl_work.c - lapacke_ctpcon.c - lapacke_ctpcon_work.c - lapacke_ctpmqrt.c - lapacke_ctpmqrt_work.c - lapacke_ctpqrt.c - lapacke_ctpqrt2.c - lapacke_ctpqrt2_work.c - lapacke_ctpqrt_work.c - lapacke_ctprfb.c - lapacke_ctprfb_work.c - lapacke_ctprfs.c - lapacke_ctprfs_work.c - lapacke_ctptri.c - lapacke_ctptri_work.c - lapacke_ctptrs.c - lapacke_ctptrs_work.c - lapacke_ctpttf.c - lapacke_ctpttf_work.c - lapacke_ctpttr.c - lapacke_ctpttr_work.c - lapacke_ctrcon.c - lapacke_ctrcon_work.c - lapacke_ctrevc.c - lapacke_ctrevc_work.c - lapacke_ctrexc.c - lapacke_ctrexc_work.c - lapacke_ctrrfs.c - lapacke_ctrrfs_work.c - lapacke_ctrsen.c - lapacke_ctrsen_work.c - lapacke_ctrsna.c - lapacke_ctrsna_work.c - lapacke_ctrsyl.c - lapacke_ctrsyl_work.c - lapacke_ctrtri.c - lapacke_ctrtri_work.c - lapacke_ctrtrs.c - lapacke_ctrtrs_work.c - lapacke_ctrttf.c - lapacke_ctrttf_work.c - lapacke_ctrttp.c - lapacke_ctrttp_work.c - lapacke_ctzrzf.c - lapacke_ctzrzf_work.c - lapacke_cunbdb.c - lapacke_cunbdb_work.c - lapacke_cuncsd.c - lapacke_cuncsd_work.c - lapacke_cungbr.c - lapacke_cungbr_work.c - lapacke_cunghr.c - lapacke_cunghr_work.c - lapacke_cunglq.c - lapacke_cunglq_work.c - lapacke_cungql.c - lapacke_cungql_work.c - lapacke_cungqr.c - lapacke_cungqr_work.c - lapacke_cungrq.c - lapacke_cungrq_work.c - lapacke_cungtr.c - lapacke_cungtr_work.c - lapacke_cunmbr.c - lapacke_cunmbr_work.c - lapacke_cunmhr.c - lapacke_cunmhr_work.c - lapacke_cunmlq.c - lapacke_cunmlq_work.c - lapacke_cunmql.c - lapacke_cunmql_work.c - lapacke_cunmqr.c - lapacke_cunmqr_work.c - lapacke_cunmrq.c - lapacke_cunmrq_work.c - lapacke_cunmrz.c - lapacke_cunmrz_work.c - lapacke_cunmtr.c - lapacke_cunmtr_work.c - lapacke_cupgtr.c - lapacke_cupgtr_work.c - lapacke_cupmtr.c + lapacke_cbbcsd.c + lapacke_cbbcsd_work.c + lapacke_cbdsqr.c + lapacke_cbdsqr_work.c + lapacke_cgbbrd.c + lapacke_cgbbrd_work.c + lapacke_cgbcon.c + lapacke_cgbcon_work.c + lapacke_cgbequ.c + lapacke_cgbequ_work.c + lapacke_cgbequb.c + lapacke_cgbequb_work.c + lapacke_cgbrfs.c + lapacke_cgbrfs_work.c + lapacke_cgbsv.c + lapacke_cgbsv_work.c + lapacke_cgbsvx.c + lapacke_cgbsvx_work.c + lapacke_cgbtrf.c + lapacke_cgbtrf_work.c + lapacke_cgbtrs.c + lapacke_cgbtrs_work.c + lapacke_cgebak.c + lapacke_cgebak_work.c + lapacke_cgebal.c + lapacke_cgebal_work.c + lapacke_cgebrd.c + lapacke_cgebrd_work.c + lapacke_cgecon.c + lapacke_cgecon_work.c + lapacke_cgeequ.c + lapacke_cgeequ_work.c + lapacke_cgeequb.c + lapacke_cgeequb_work.c + lapacke_cgees.c + lapacke_cgees_work.c + lapacke_cgeesx.c + lapacke_cgeesx_work.c + lapacke_cgeev.c + lapacke_cgeev_work.c + lapacke_cgeevx.c + lapacke_cgeevx_work.c + lapacke_cgehrd.c + lapacke_cgehrd_work.c + lapacke_cgejsv.c + lapacke_cgejsv_work.c + lapacke_cgelq2.c + lapacke_cgelq2_work.c + lapacke_cgelqf.c + lapacke_cgelqf_work.c + lapacke_cgels.c + lapacke_cgels_work.c + lapacke_cgelsd.c + lapacke_cgelsd_work.c + lapacke_cgelss.c + lapacke_cgelss_work.c + lapacke_cgelsy.c + lapacke_cgelsy_work.c + lapacke_cgemqr.c + lapacke_cgemqr_work.c + lapacke_cgemqrt.c + lapacke_cgemqrt_work.c + lapacke_cgeqlf.c + lapacke_cgeqlf_work.c + lapacke_cgeqp3.c + lapacke_cgeqp3_work.c + lapacke_cgeqr2.c + lapacke_cgeqr2_work.c + lapacke_cgeqrf.c + lapacke_cgeqrf_work.c + lapacke_cgeqrfp.c + lapacke_cgeqrfp_work.c + lapacke_cgeqrt.c + lapacke_cgeqrt2.c + lapacke_cgeqrt2_work.c + lapacke_cgeqrt3.c + lapacke_cgeqrt3_work.c + lapacke_cgeqrt_work.c + lapacke_cgerfs.c + lapacke_cgerfs_work.c + lapacke_cgerqf.c + lapacke_cgerqf_work.c + lapacke_cgesdd.c + lapacke_cgesdd_work.c + lapacke_cgesv.c + lapacke_cgesv_work.c + lapacke_cgesvd.c + lapacke_cgesvd_work.c + lapacke_cgesvdx.c + lapacke_cgesvdx_work.c + lapacke_cgesvj.c + lapacke_cgesvj_work.c + lapacke_cgesvx.c + lapacke_cgesvx_work.c + lapacke_cgetf2.c + lapacke_cgetf2_work.c + lapacke_cgetrf.c + lapacke_cgetrf_work.c + lapacke_cgetrf2.c + lapacke_cgetrf2_work.c + lapacke_cgetri.c + lapacke_cgetri_work.c + lapacke_cgetrs.c + lapacke_cgetrs_work.c + lapacke_cgetsls.c + lapacke_cgetsls_work.c + lapacke_cggbak.c + lapacke_cggbak_work.c + lapacke_cggbal.c + lapacke_cggbal_work.c + lapacke_cgges.c + lapacke_cgges_work.c + lapacke_cgges3.c + lapacke_cgges3_work.c + lapacke_cggesx.c + lapacke_cggesx_work.c + lapacke_cggev.c + lapacke_cggev_work.c + lapacke_cggev3.c + lapacke_cggev3_work.c + lapacke_cggevx.c + lapacke_cggevx_work.c + lapacke_cggglm.c + lapacke_cggglm_work.c + lapacke_cgghrd.c + lapacke_cgghrd_work.c + lapacke_cgghd3.c + lapacke_cgghd3_work.c + lapacke_cgglse.c + lapacke_cgglse_work.c + lapacke_cggqrf.c + lapacke_cggqrf_work.c + lapacke_cggrqf.c + lapacke_cggrqf_work.c + lapacke_cggsvd3.c + lapacke_cggsvd3_work.c + lapacke_cggsvp3.c + lapacke_cggsvp3_work.c + lapacke_cgtcon.c + lapacke_cgtcon_work.c + lapacke_cgtrfs.c + lapacke_cgtrfs_work.c + lapacke_cgtsv.c + lapacke_cgtsv_work.c + lapacke_cgtsvx.c + lapacke_cgtsvx_work.c + lapacke_cgttrf.c + lapacke_cgttrf_work.c + lapacke_cgttrs.c + lapacke_cgttrs_work.c + lapacke_chbev.c + lapacke_chbev_work.c + lapacke_chbevd.c + lapacke_chbevd_work.c + lapacke_chbevx.c + lapacke_chbevx_work.c + lapacke_chbev_2stage.c + lapacke_chbev_2stage_work.c + lapacke_chbevd_2stage.c + lapacke_chbevd_2stage_work.c + lapacke_chbevx_2stage.c + lapacke_chbevx_2stage_work.c + lapacke_chbgst.c + lapacke_chbgst_work.c + lapacke_chbgv.c + lapacke_chbgv_work.c + lapacke_chbgvd.c + lapacke_chbgvd_work.c + lapacke_chbgvx.c + lapacke_chbgvx_work.c + lapacke_chbtrd.c + lapacke_chbtrd_work.c + lapacke_checon.c + lapacke_checon_work.c + lapacke_checon_3.c + lapacke_checon_3_work.c + lapacke_cheequb.c + lapacke_cheequb_work.c + lapacke_cheev.c + lapacke_cheev_work.c + lapacke_cheevd.c + lapacke_cheevd_work.c + lapacke_cheevr.c + lapacke_cheevr_work.c + lapacke_cheevx.c + lapacke_cheevx_work.c + lapacke_cheev_2stage.c + lapacke_cheev_2stage_work.c + lapacke_cheevd_2stage.c + lapacke_cheevd_2stage_work.c + lapacke_cheevr_2stage.c + lapacke_cheevr_2stage_work.c + lapacke_cheevx_2stage.c + lapacke_cheevx_2stage_work.c + lapacke_chegst.c + lapacke_chegst_work.c + lapacke_chegv.c + lapacke_chegv_work.c + lapacke_chegv_2stage.c + lapacke_chegv_2stage_work.c + lapacke_chegvd.c + lapacke_chegvd_work.c + lapacke_chegvx.c + lapacke_chegvx_work.c + lapacke_cherfs.c + lapacke_cherfs_work.c + lapacke_chesv.c + lapacke_chesv_work.c + lapacke_chesv_aa.c + lapacke_chesv_aa_work.c + lapacke_chesv_rk.c + lapacke_chesv_rk_work.c + lapacke_chesvx.c + lapacke_chesvx_work.c + lapacke_cheswapr.c + lapacke_cheswapr_work.c + lapacke_chetrd.c + lapacke_chetrd_work.c + lapacke_chetrf.c + lapacke_chetrf_rook.c + lapacke_chetrf_work.c + lapacke_chetrf_rook_work.c + lapacke_chetrf_aa.c + lapacke_chetrf_aa_work.c + lapacke_chetrf_rk.c + lapacke_chetrf_rk_work.c + lapacke_chetri.c + lapacke_chetri2.c + lapacke_chetri2_work.c + lapacke_chetri_3.c + lapacke_chetri_3_work.c + lapacke_chetri2x.c + lapacke_chetri2x_work.c + lapacke_chetri_work.c + lapacke_chetrs.c + lapacke_chetrs_rook.c + lapacke_chetrs2.c + lapacke_chetrs2_work.c + lapacke_chetrs_work.c + lapacke_chetrs_rook_work.c + lapacke_chetrs_aa.c + lapacke_chetrs_aa_work.c + lapacke_chetrs_3.c + lapacke_chetrs_3_work.c + lapacke_chfrk.c + lapacke_chfrk_work.c + lapacke_chgeqz.c + lapacke_chgeqz_work.c + lapacke_chpcon.c + lapacke_chpcon_work.c + lapacke_chpev.c + lapacke_chpev_work.c + lapacke_chpevd.c + lapacke_chpevd_work.c + lapacke_chpevx.c + lapacke_chpevx_work.c + lapacke_chpgst.c + lapacke_chpgst_work.c + lapacke_chpgv.c + lapacke_chpgv_work.c + lapacke_chpgvd.c + lapacke_chpgvd_work.c + lapacke_chpgvx.c + lapacke_chpgvx_work.c + lapacke_chprfs.c + lapacke_chprfs_work.c + lapacke_chpsv.c + lapacke_chpsv_work.c + lapacke_chpsvx.c + lapacke_chpsvx_work.c + lapacke_chptrd.c + lapacke_chptrd_work.c + lapacke_chptrf.c + lapacke_chptrf_work.c + lapacke_chptri.c + lapacke_chptri_work.c + lapacke_chptrs.c + lapacke_chptrs_work.c + lapacke_chsein.c + lapacke_chsein_work.c + lapacke_chseqr.c + lapacke_chseqr_work.c + lapacke_clacgv.c + lapacke_clacgv_work.c + lapacke_clacn2.c + lapacke_clacn2_work.c + lapacke_clacp2.c + lapacke_clacp2_work.c + lapacke_clacpy.c + lapacke_clacpy_work.c + lapacke_clag2z.c + lapacke_clag2z_work.c + lapacke_clange.c + lapacke_clange_work.c + lapacke_clanhe.c + lapacke_clanhe_work.c + lapacke_clansy.c + lapacke_clansy_work.c + lapacke_clantr.c + lapacke_clantr_work.c + lapacke_clapmr.c + lapacke_clapmr_work.c + lapacke_clapmt.c + lapacke_clapmt_work.c + lapacke_clarfb.c + lapacke_clarfb_work.c + lapacke_clarfg.c + lapacke_clarfg_work.c + lapacke_clarft.c + lapacke_clarft_work.c + lapacke_clarfx.c + lapacke_clarfx_work.c + lapacke_clarnv.c + lapacke_clarnv_work.c + lapacke_clascl.c + lapacke_clascl_work.c + lapacke_claset.c + lapacke_claset_work.c + lapacke_claswp.c + lapacke_claswp_work.c + lapacke_clauum.c + lapacke_clauum_work.c + lapacke_cpbcon.c + lapacke_cpbcon_work.c + lapacke_cpbequ.c + lapacke_cpbequ_work.c + lapacke_cpbrfs.c + lapacke_cpbrfs_work.c + lapacke_cpbstf.c + lapacke_cpbstf_work.c + lapacke_cpbsv.c + lapacke_cpbsv_work.c + lapacke_cpbsvx.c + lapacke_cpbsvx_work.c + lapacke_cpbtrf.c + lapacke_cpbtrf_work.c + lapacke_cpbtrs.c + lapacke_cpbtrs_work.c + lapacke_cpftrf.c + lapacke_cpftrf_work.c + lapacke_cpftri.c + lapacke_cpftri_work.c + lapacke_cpftrs.c + lapacke_cpftrs_work.c + lapacke_cpocon.c + lapacke_cpocon_work.c + lapacke_cpoequ.c + lapacke_cpoequ_work.c + lapacke_cpoequb.c + lapacke_cpoequb_work.c + lapacke_cporfs.c + lapacke_cporfs_work.c + lapacke_cposv.c + lapacke_cposv_work.c + lapacke_cposvx.c + lapacke_cposvx_work.c + lapacke_cpotrf.c + lapacke_cpotrf_work.c + lapacke_cpotrf2.c + lapacke_cpotrf2_work.c + lapacke_cpotri.c + lapacke_cpotri_work.c + lapacke_cpotrs.c + lapacke_cpotrs_work.c + lapacke_cppcon.c + lapacke_cppcon_work.c + lapacke_cppequ.c + lapacke_cppequ_work.c + lapacke_cpprfs.c + lapacke_cpprfs_work.c + lapacke_cppsv.c + lapacke_cppsv_work.c + lapacke_cppsvx.c + lapacke_cppsvx_work.c + lapacke_cpptrf.c + lapacke_cpptrf_work.c + lapacke_cpptri.c + lapacke_cpptri_work.c + lapacke_cpptrs.c + lapacke_cpptrs_work.c + lapacke_cpstrf.c + lapacke_cpstrf_work.c + lapacke_cptcon.c + lapacke_cptcon_work.c + lapacke_cpteqr.c + lapacke_cpteqr_work.c + lapacke_cptrfs.c + lapacke_cptrfs_work.c + lapacke_cptsv.c + lapacke_cptsv_work.c + lapacke_cptsvx.c + lapacke_cptsvx_work.c + lapacke_cpttrf.c + lapacke_cpttrf_work.c + lapacke_cpttrs.c + lapacke_cpttrs_work.c + lapacke_cspcon.c + lapacke_cspcon_work.c + lapacke_csprfs.c + lapacke_csprfs_work.c + lapacke_cspsv.c + lapacke_cspsv_work.c + lapacke_cspsvx.c + lapacke_cspsvx_work.c + lapacke_csptrf.c + lapacke_csptrf_work.c + lapacke_csptri.c + lapacke_csptri_work.c + lapacke_csptrs.c + lapacke_csptrs_work.c + lapacke_cstedc.c + lapacke_cstedc_work.c + lapacke_cstegr.c + lapacke_cstegr_work.c + lapacke_cstein.c + lapacke_cstein_work.c + lapacke_cstemr.c + lapacke_cstemr_work.c + lapacke_csteqr.c + lapacke_csteqr_work.c + lapacke_csycon.c + lapacke_csycon_work.c + lapacke_csycon_3.c + lapacke_csycon_3_work.c + lapacke_csyconv.c + lapacke_csyconv_work.c + lapacke_csyequb.c + lapacke_csyequb_work.c + lapacke_csyrfs.c + lapacke_csyrfs_work.c + lapacke_csysv.c + lapacke_csysv_rook.c + lapacke_csysv_rook_work.c + lapacke_csysv_work.c + lapacke_csysv_aa.c + lapacke_csysv_aa_work.c + lapacke_csysv_rk.c + lapacke_csysv_rk_work.c + lapacke_csysvx.c + lapacke_csysvx_work.c + lapacke_csyswapr.c + lapacke_csyswapr_work.c + lapacke_csytrf.c + lapacke_csytrf_work.c + lapacke_csytrf_rook.c + lapacke_csytrf_rook_work.c + lapacke_csytrf_aa.c + lapacke_csytrf_aa_work.c + lapacke_csytrf_rk.c + lapacke_csytrf_rk_work.c + lapacke_csytri.c + lapacke_csytri2.c + lapacke_csytri2_work.c + lapacke_csytri_3.c + lapacke_csytri_3_work.c + lapacke_csytri2x.c + lapacke_csytri2x_work.c + lapacke_csytri_work.c + lapacke_csytrs.c + lapacke_csytrs_rook.c + lapacke_csytrs2.c + lapacke_csytrs2_work.c + lapacke_csytrs_work.c + lapacke_csytrs_rook_work.c + lapacke_csytrs_aa.c + lapacke_csytrs_aa_work.c + lapacke_csytrs_3.c + lapacke_csytrs_3_work.c + lapacke_ctbcon.c + lapacke_ctbcon_work.c + lapacke_ctbrfs.c + lapacke_ctbrfs_work.c + lapacke_ctbtrs.c + lapacke_ctbtrs_work.c + lapacke_ctfsm.c + lapacke_ctfsm_work.c + lapacke_ctftri.c + lapacke_ctftri_work.c + lapacke_ctfttp.c + lapacke_ctfttp_work.c + lapacke_ctfttr.c + lapacke_ctfttr_work.c + lapacke_ctgevc.c + lapacke_ctgevc_work.c + lapacke_ctgexc.c + lapacke_ctgexc_work.c + lapacke_ctgsen.c + lapacke_ctgsen_work.c + lapacke_ctgsja.c + lapacke_ctgsja_work.c + lapacke_ctgsna.c + lapacke_ctgsna_work.c + lapacke_ctgsyl.c + lapacke_ctgsyl_work.c + lapacke_ctpcon.c + lapacke_ctpcon_work.c + lapacke_ctpmqrt.c + lapacke_ctpmqrt_work.c + lapacke_ctpqrt.c + lapacke_ctpqrt2.c + lapacke_ctpqrt2_work.c + lapacke_ctpqrt_work.c + lapacke_ctprfb.c + lapacke_ctprfb_work.c + lapacke_ctprfs.c + lapacke_ctprfs_work.c + lapacke_ctptri.c + lapacke_ctptri_work.c + lapacke_ctptrs.c + lapacke_ctptrs_work.c + lapacke_ctpttf.c + lapacke_ctpttf_work.c + lapacke_ctpttr.c + lapacke_ctpttr_work.c + lapacke_ctrcon.c + lapacke_ctrcon_work.c + lapacke_ctrevc.c + lapacke_ctrevc_work.c + lapacke_ctrexc.c + lapacke_ctrexc_work.c + lapacke_ctrrfs.c + lapacke_ctrrfs_work.c + lapacke_ctrsen.c + lapacke_ctrsen_work.c + lapacke_ctrsna.c + lapacke_ctrsna_work.c + lapacke_ctrsyl.c + lapacke_ctrsyl_work.c + lapacke_ctrtri.c + lapacke_ctrtri_work.c + lapacke_ctrtrs.c + lapacke_ctrtrs_work.c + lapacke_ctrttf.c + lapacke_ctrttf_work.c + lapacke_ctrttp.c + lapacke_ctrttp_work.c + lapacke_ctzrzf.c + lapacke_ctzrzf_work.c + lapacke_cunbdb.c + lapacke_cunbdb_work.c + lapacke_cuncsd.c + lapacke_cuncsd_work.c + lapacke_cuncsd2by1.c + lapacke_cuncsd2by1_work.c + lapacke_cungbr.c + lapacke_cungbr_work.c + lapacke_cunghr.c + lapacke_cunghr_work.c + lapacke_cunglq.c + lapacke_cunglq_work.c + lapacke_cungql.c + lapacke_cungql_work.c + lapacke_cungqr.c + lapacke_cungqr_work.c + lapacke_cungrq.c + lapacke_cungrq_work.c + lapacke_cungtr.c + lapacke_cungtr_work.c + lapacke_cunmbr.c + lapacke_cunmbr_work.c + lapacke_cunmhr.c + lapacke_cunmhr_work.c + lapacke_cunmlq.c + lapacke_cunmlq_work.c + lapacke_cunmql.c + lapacke_cunmql_work.c + lapacke_cunmqr.c + lapacke_cunmqr_work.c + lapacke_cunmrq.c + lapacke_cunmrq_work.c + lapacke_cunmrz.c + lapacke_cunmrz_work.c + lapacke_cunmtr.c + lapacke_cunmtr_work.c + lapacke_cupgtr.c + lapacke_cupgtr_work.c + lapacke_cupmtr.c lapacke_cupmtr_work.c ) set(DSRC - lapacke_dbbcsd.c - lapacke_dbbcsd_work.c - lapacke_dbdsdc.c - lapacke_dbdsdc_work.c - lapacke_dbdsqr.c - lapacke_dbdsqr_work.c - lapacke_ddisna.c - lapacke_ddisna_work.c - lapacke_dgbbrd.c - lapacke_dgbbrd_work.c - lapacke_dgbcon.c - lapacke_dgbcon_work.c - lapacke_dgbequ.c - lapacke_dgbequ_work.c - lapacke_dgbequb.c - lapacke_dgbequb_work.c - lapacke_dgbrfs.c - lapacke_dgbrfs_work.c - lapacke_dgbsv.c - lapacke_dgbsv_work.c - lapacke_dgbsvx.c - lapacke_dgbsvx_work.c - lapacke_dgbtrf.c - lapacke_dgbtrf_work.c - lapacke_dgbtrs.c - lapacke_dgbtrs_work.c - lapacke_dgebak.c - lapacke_dgebak_work.c - lapacke_dgebal.c - lapacke_dgebal_work.c - lapacke_dgebrd.c - lapacke_dgebrd_work.c - lapacke_dgecon.c - lapacke_dgecon_work.c - lapacke_dgeequ.c - lapacke_dgeequ_work.c - lapacke_dgeequb.c - lapacke_dgeequb_work.c - lapacke_dgees.c - lapacke_dgees_work.c - lapacke_dgeesx.c - lapacke_dgeesx_work.c - lapacke_dgeev.c - lapacke_dgeev_work.c - lapacke_dgeevx.c - lapacke_dgeevx_work.c - lapacke_dgehrd.c - lapacke_dgehrd_work.c - lapacke_dgejsv.c - lapacke_dgejsv_work.c - lapacke_dgelq2.c - lapacke_dgelq2_work.c - lapacke_dgelqf.c - lapacke_dgelqf_work.c - lapacke_dgels.c - lapacke_dgels_work.c - lapacke_dgelsd.c - lapacke_dgelsd_work.c - lapacke_dgelss.c - lapacke_dgelss_work.c - lapacke_dgelsy.c - lapacke_dgelsy_work.c - lapacke_dgemqrt.c - lapacke_dgemqrt_work.c - lapacke_dgeqlf.c - lapacke_dgeqlf_work.c - lapacke_dgeqp3.c - lapacke_dgeqp3_work.c - lapacke_dgeqpf.c - lapacke_dgeqpf_work.c - lapacke_dgeqr2.c - lapacke_dgeqr2_work.c - lapacke_dgeqrf.c - lapacke_dgeqrf_work.c - lapacke_dgeqrfp.c - lapacke_dgeqrfp_work.c - lapacke_dgeqrt.c - lapacke_dgeqrt2.c - lapacke_dgeqrt2_work.c - lapacke_dgeqrt3.c - lapacke_dgeqrt3_work.c - lapacke_dgeqrt_work.c - lapacke_dgerfs.c - lapacke_dgerfs_work.c - lapacke_dgerqf.c - lapacke_dgerqf_work.c - lapacke_dgesdd.c - lapacke_dgesdd_work.c - lapacke_dgesv.c - lapacke_dgesv_work.c - lapacke_dgesvd.c - lapacke_dgesvd_work.c - lapacke_dgesvj.c - lapacke_dgesvj_work.c - lapacke_dgesvx.c - lapacke_dgesvx_work.c - lapacke_dgetf2.c - lapacke_dgetf2_work.c - lapacke_dgetrf.c - lapacke_dgetrf_work.c - lapacke_dgetri.c - lapacke_dgetri_work.c - lapacke_dgetrs.c - lapacke_dgetrs_work.c - lapacke_dggbak.c - lapacke_dggbak_work.c - lapacke_dggbal.c - lapacke_dggbal_work.c - lapacke_dgges.c - lapacke_dgges_work.c - lapacke_dggesx.c - lapacke_dggesx_work.c - lapacke_dggev.c - lapacke_dggev_work.c - lapacke_dggevx.c - lapacke_dggevx_work.c - lapacke_dggglm.c - lapacke_dggglm_work.c - lapacke_dgghrd.c - lapacke_dgghrd_work.c - lapacke_dgglse.c - lapacke_dgglse_work.c - lapacke_dggqrf.c - lapacke_dggqrf_work.c - lapacke_dggrqf.c - lapacke_dggrqf_work.c - lapacke_dggsvd.c - lapacke_dggsvd_work.c - lapacke_dggsvp.c - lapacke_dggsvp_work.c - lapacke_dgtcon.c - lapacke_dgtcon_work.c - lapacke_dgtrfs.c - lapacke_dgtrfs_work.c - lapacke_dgtsv.c - lapacke_dgtsv_work.c - lapacke_dgtsvx.c - lapacke_dgtsvx_work.c - lapacke_dgttrf.c - lapacke_dgttrf_work.c - lapacke_dgttrs.c - lapacke_dgttrs_work.c - lapacke_dhgeqz.c - lapacke_dhgeqz_work.c - lapacke_dhsein.c - lapacke_dhsein_work.c - lapacke_dhseqr.c - lapacke_dhseqr_work.c - lapacke_dlacn2.c - lapacke_dlacn2_work.c - lapacke_dlacpy.c - lapacke_dlacpy_work.c - lapacke_dlag2s.c - lapacke_dlag2s_work.c - lapacke_dlamch.c - lapacke_dlamch_work.c - lapacke_dlange.c - lapacke_dlange_work.c - lapacke_dlansy.c - lapacke_dlansy_work.c - lapacke_dlantr.c - lapacke_dlantr_work.c - lapacke_dlapmr.c - lapacke_dlapmr_work.c - lapacke_dlapy2.c - lapacke_dlapy2_work.c - lapacke_dlapy3.c - lapacke_dlapy3_work.c - lapacke_dlarfb.c - lapacke_dlarfb_work.c - lapacke_dlarfg.c - lapacke_dlarfg_work.c - lapacke_dlarft.c - lapacke_dlarft_work.c - lapacke_dlarfx.c - lapacke_dlarfx_work.c - lapacke_dlarnv.c - lapacke_dlarnv_work.c - lapacke_dlartgp.c - lapacke_dlartgp_work.c - lapacke_dlartgs.c - lapacke_dlartgs_work.c - lapacke_dlaset.c - lapacke_dlaset_work.c - lapacke_dlasrt.c - lapacke_dlasrt_work.c - lapacke_dlaswp.c - lapacke_dlaswp_work.c - lapacke_dlauum.c - lapacke_dlauum_work.c - lapacke_dopgtr.c - lapacke_dopgtr_work.c - lapacke_dopmtr.c - lapacke_dopmtr_work.c - lapacke_dorbdb.c - lapacke_dorbdb_work.c - lapacke_dorcsd.c - lapacke_dorcsd_work.c - lapacke_dorgbr.c - lapacke_dorgbr_work.c - lapacke_dorghr.c - lapacke_dorghr_work.c - lapacke_dorglq.c - lapacke_dorglq_work.c - lapacke_dorgql.c - lapacke_dorgql_work.c - lapacke_dorgqr.c - lapacke_dorgqr_work.c - lapacke_dorgrq.c - lapacke_dorgrq_work.c - lapacke_dorgtr.c - lapacke_dorgtr_work.c - lapacke_dormbr.c - lapacke_dormbr_work.c - lapacke_dormhr.c - lapacke_dormhr_work.c - lapacke_dormlq.c - lapacke_dormlq_work.c - lapacke_dormql.c - lapacke_dormql_work.c - lapacke_dormqr.c - lapacke_dormqr_work.c - lapacke_dormrq.c - lapacke_dormrq_work.c - lapacke_dormrz.c - lapacke_dormrz_work.c - lapacke_dormtr.c - lapacke_dormtr_work.c - lapacke_dpbcon.c - lapacke_dpbcon_work.c - lapacke_dpbequ.c - lapacke_dpbequ_work.c - lapacke_dpbrfs.c - lapacke_dpbrfs_work.c - lapacke_dpbstf.c - lapacke_dpbstf_work.c - lapacke_dpbsv.c - lapacke_dpbsv_work.c - lapacke_dpbsvx.c - lapacke_dpbsvx_work.c - lapacke_dpbtrf.c - lapacke_dpbtrf_work.c - lapacke_dpbtrs.c - lapacke_dpbtrs_work.c - lapacke_dpftrf.c - lapacke_dpftrf_work.c - lapacke_dpftri.c - lapacke_dpftri_work.c - lapacke_dpftrs.c - lapacke_dpftrs_work.c - lapacke_dpocon.c - lapacke_dpocon_work.c - lapacke_dpoequ.c - lapacke_dpoequ_work.c - lapacke_dpoequb.c - lapacke_dpoequb_work.c - lapacke_dporfs.c - lapacke_dporfs_work.c - lapacke_dposv.c - lapacke_dposv_work.c - lapacke_dposvx.c - lapacke_dposvx_work.c - lapacke_dpotrf.c - lapacke_dpotrf_work.c - lapacke_dpotri.c - lapacke_dpotri_work.c - lapacke_dpotrs.c - lapacke_dpotrs_work.c - lapacke_dppcon.c - lapacke_dppcon_work.c - lapacke_dppequ.c - lapacke_dppequ_work.c - lapacke_dpprfs.c - lapacke_dpprfs_work.c - lapacke_dppsv.c - lapacke_dppsv_work.c - lapacke_dppsvx.c - lapacke_dppsvx_work.c - lapacke_dpptrf.c - lapacke_dpptrf_work.c - lapacke_dpptri.c - lapacke_dpptri_work.c - lapacke_dpptrs.c - lapacke_dpptrs_work.c - lapacke_dpstrf.c - lapacke_dpstrf_work.c - lapacke_dptcon.c - lapacke_dptcon_work.c - lapacke_dpteqr.c - lapacke_dpteqr_work.c - lapacke_dptrfs.c - lapacke_dptrfs_work.c - lapacke_dptsv.c - lapacke_dptsv_work.c - lapacke_dptsvx.c - lapacke_dptsvx_work.c - lapacke_dpttrf.c - lapacke_dpttrf_work.c - lapacke_dpttrs.c - lapacke_dpttrs_work.c - lapacke_dsbev.c - lapacke_dsbev_work.c - lapacke_dsbevd.c - lapacke_dsbevd_work.c - lapacke_dsbevx.c - lapacke_dsbevx_work.c - lapacke_dsbgst.c - lapacke_dsbgst_work.c - lapacke_dsbgv.c - lapacke_dsbgv_work.c - lapacke_dsbgvd.c - lapacke_dsbgvd_work.c - lapacke_dsbgvx.c - lapacke_dsbgvx_work.c - lapacke_dsbtrd.c - lapacke_dsbtrd_work.c - lapacke_dsfrk.c - lapacke_dsfrk_work.c - lapacke_dsgesv.c - lapacke_dsgesv_work.c - lapacke_dspcon.c - lapacke_dspcon_work.c - lapacke_dspev.c - lapacke_dspev_work.c - lapacke_dspevd.c - lapacke_dspevd_work.c - lapacke_dspevx.c - lapacke_dspevx_work.c - lapacke_dspgst.c - lapacke_dspgst_work.c - lapacke_dspgv.c - lapacke_dspgv_work.c - lapacke_dspgvd.c - lapacke_dspgvd_work.c - lapacke_dspgvx.c - lapacke_dspgvx_work.c - lapacke_dsposv.c - lapacke_dsposv_work.c - lapacke_dsprfs.c - lapacke_dsprfs_work.c - lapacke_dspsv.c - lapacke_dspsv_work.c - lapacke_dspsvx.c - lapacke_dspsvx_work.c - lapacke_dsptrd.c - lapacke_dsptrd_work.c - lapacke_dsptrf.c - lapacke_dsptrf_work.c - lapacke_dsptri.c - lapacke_dsptri_work.c - lapacke_dsptrs.c - lapacke_dsptrs_work.c - lapacke_dstebz.c - lapacke_dstebz_work.c - lapacke_dstedc.c - lapacke_dstedc_work.c - lapacke_dstegr.c - lapacke_dstegr_work.c - lapacke_dstein.c - lapacke_dstein_work.c - lapacke_dstemr.c - lapacke_dstemr_work.c - lapacke_dsteqr.c - lapacke_dsteqr_work.c - lapacke_dsterf.c - lapacke_dsterf_work.c - lapacke_dstev.c - lapacke_dstev_work.c - lapacke_dstevd.c - lapacke_dstevd_work.c - lapacke_dstevr.c - lapacke_dstevr_work.c - lapacke_dstevx.c - lapacke_dstevx_work.c - lapacke_dsycon.c - lapacke_dsycon_work.c - lapacke_dsyconv.c - lapacke_dsyconv_work.c - lapacke_dsyequb.c - lapacke_dsyequb_work.c - lapacke_dsyev.c - lapacke_dsyev_work.c - lapacke_dsyevd.c - lapacke_dsyevd_work.c - lapacke_dsyevr.c - lapacke_dsyevr_work.c - lapacke_dsyevx.c - lapacke_dsyevx_work.c - lapacke_dsygst.c - lapacke_dsygst_work.c - lapacke_dsygv.c - lapacke_dsygv_work.c - lapacke_dsygvd.c - lapacke_dsygvd_work.c - lapacke_dsygvx.c - lapacke_dsygvx_work.c - lapacke_dsyrfs.c - lapacke_dsyrfs_work.c - lapacke_dsysv.c - lapacke_dsysv_rook.c - lapacke_dsysv_rook_work.c - lapacke_dsysv_work.c - lapacke_dsysvx.c - lapacke_dsysvx_work.c - lapacke_dsyswapr.c - lapacke_dsyswapr_work.c - lapacke_dsytrd.c - lapacke_dsytrd_work.c - lapacke_dsytrf.c - lapacke_dsytrf_work.c - lapacke_dsytri.c - lapacke_dsytri2.c - lapacke_dsytri2_work.c - lapacke_dsytri2x.c - lapacke_dsytri2x_work.c - lapacke_dsytri_work.c - lapacke_dsytrs.c - lapacke_dsytrs2.c - lapacke_dsytrs2_work.c - lapacke_dsytrs_work.c - lapacke_dtbcon.c - lapacke_dtbcon_work.c - lapacke_dtbrfs.c - lapacke_dtbrfs_work.c - lapacke_dtbtrs.c - lapacke_dtbtrs_work.c - lapacke_dtfsm.c - lapacke_dtfsm_work.c - lapacke_dtftri.c - lapacke_dtftri_work.c - lapacke_dtfttp.c - lapacke_dtfttp_work.c - lapacke_dtfttr.c - lapacke_dtfttr_work.c - lapacke_dtgevc.c - lapacke_dtgevc_work.c - lapacke_dtgexc.c - lapacke_dtgexc_work.c - lapacke_dtgsen.c - lapacke_dtgsen_work.c - lapacke_dtgsja.c - lapacke_dtgsja_work.c - lapacke_dtgsna.c - lapacke_dtgsna_work.c - lapacke_dtgsyl.c - lapacke_dtgsyl_work.c - lapacke_dtpcon.c - lapacke_dtpcon_work.c - lapacke_dtpmqrt.c - lapacke_dtpmqrt_work.c - lapacke_dtpqrt.c - lapacke_dtpqrt2.c - lapacke_dtpqrt2_work.c - lapacke_dtpqrt_work.c - lapacke_dtprfb.c - lapacke_dtprfb_work.c - lapacke_dtprfs.c - lapacke_dtprfs_work.c - lapacke_dtptri.c - lapacke_dtptri_work.c - lapacke_dtptrs.c - lapacke_dtptrs_work.c - lapacke_dtpttf.c - lapacke_dtpttf_work.c - lapacke_dtpttr.c - lapacke_dtpttr_work.c - lapacke_dtrcon.c - lapacke_dtrcon_work.c - lapacke_dtrevc.c - lapacke_dtrevc_work.c - lapacke_dtrexc.c - lapacke_dtrexc_work.c - lapacke_dtrrfs.c - lapacke_dtrrfs_work.c - lapacke_dtrsen.c - lapacke_dtrsen_work.c - lapacke_dtrsna.c - lapacke_dtrsna_work.c - lapacke_dtrsyl.c - lapacke_dtrsyl_work.c - lapacke_dtrtri.c - lapacke_dtrtri_work.c - lapacke_dtrtrs.c - lapacke_dtrtrs_work.c - lapacke_dtrttf.c - lapacke_dtrttf_work.c - lapacke_dtrttp.c - lapacke_dtrttp_work.c - lapacke_dtzrzf.c + lapacke_dbbcsd.c + lapacke_dbbcsd_work.c + lapacke_dbdsdc.c + lapacke_dbdsdc_work.c + lapacke_dbdsvdx.c + lapacke_dbdsvdx_work.c + lapacke_dbdsqr.c + lapacke_dbdsqr_work.c + lapacke_ddisna.c + lapacke_ddisna_work.c + lapacke_dgbbrd.c + lapacke_dgbbrd_work.c + lapacke_dgbcon.c + lapacke_dgbcon_work.c + lapacke_dgbequ.c + lapacke_dgbequ_work.c + lapacke_dgbequb.c + lapacke_dgbequb_work.c + lapacke_dgbrfs.c + lapacke_dgbrfs_work.c + lapacke_dgbsv.c + lapacke_dgbsv_work.c + lapacke_dgbsvx.c + lapacke_dgbsvx_work.c + lapacke_dgbtrf.c + lapacke_dgbtrf_work.c + lapacke_dgbtrs.c + lapacke_dgbtrs_work.c + lapacke_dgebak.c + lapacke_dgebak_work.c + lapacke_dgebal.c + lapacke_dgebal_work.c + lapacke_dgebrd.c + lapacke_dgebrd_work.c + lapacke_dgecon.c + lapacke_dgecon_work.c + lapacke_dgeequ.c + lapacke_dgeequ_work.c + lapacke_dgeequb.c + lapacke_dgeequb_work.c + lapacke_dgees.c + lapacke_dgees_work.c + lapacke_dgeesx.c + lapacke_dgeesx_work.c + lapacke_dgeev.c + lapacke_dgeev_work.c + lapacke_dgeevx.c + lapacke_dgeevx_work.c + lapacke_dgehrd.c + lapacke_dgehrd_work.c + lapacke_dgejsv.c + lapacke_dgejsv_work.c + lapacke_dgelq2.c + lapacke_dgelq2_work.c + lapacke_dgelqf.c + lapacke_dgelqf_work.c + lapacke_dgels.c + lapacke_dgels_work.c + lapacke_dgelsd.c + lapacke_dgelsd_work.c + lapacke_dgelss.c + lapacke_dgelss_work.c + lapacke_dgelsy.c + lapacke_dgelsy_work.c + lapacke_dgemqr.c + lapacke_dgemqr_work.c + lapacke_dgemqrt.c + lapacke_dgemqrt_work.c + lapacke_dgeqlf.c + lapacke_dgeqlf_work.c + lapacke_dgeqp3.c + lapacke_dgeqp3_work.c + lapacke_dgeqr2.c + lapacke_dgeqr2_work.c + lapacke_dgeqrf.c + lapacke_dgeqrf_work.c + lapacke_dgeqrfp.c + lapacke_dgeqrfp_work.c + lapacke_dgeqrt.c + lapacke_dgeqrt2.c + lapacke_dgeqrt2_work.c + lapacke_dgeqrt3.c + lapacke_dgeqrt3_work.c + lapacke_dgeqrt_work.c + lapacke_dgerfs.c + lapacke_dgerfs_work.c + lapacke_dgerqf.c + lapacke_dgerqf_work.c + lapacke_dgesdd.c + lapacke_dgesdd_work.c + lapacke_dgesv.c + lapacke_dgesv_work.c + lapacke_dgesvd.c + lapacke_dgesvd_work.c + lapacke_dgesvdx.c + lapacke_dgesvdx_work.c + lapacke_dgesvj.c + lapacke_dgesvj_work.c + lapacke_dgesvx.c + lapacke_dgesvx_work.c + lapacke_dgetf2.c + lapacke_dgetf2_work.c + lapacke_dgetrf.c + lapacke_dgetrf_work.c + lapacke_dgetrf2.c + lapacke_dgetrf2_work.c + lapacke_dgetri.c + lapacke_dgetri_work.c + lapacke_dgetrs.c + lapacke_dgetrs_work.c + lapacke_dgetsls.c + lapacke_dgetsls_work.c + lapacke_dggbak.c + lapacke_dggbak_work.c + lapacke_dggbal.c + lapacke_dggbal_work.c + lapacke_dgges.c + lapacke_dgges_work.c + lapacke_dgges3.c + lapacke_dgges3_work.c + lapacke_dggesx.c + lapacke_dggesx_work.c + lapacke_dggev.c + lapacke_dggev_work.c + lapacke_dggev3.c + lapacke_dggev3_work.c + lapacke_dggevx.c + lapacke_dggevx_work.c + lapacke_dggglm.c + lapacke_dggglm_work.c + lapacke_dgghrd.c + lapacke_dgghrd_work.c + lapacke_dgghd3.c + lapacke_dgghd3_work.c + lapacke_dgglse.c + lapacke_dgglse_work.c + lapacke_dggqrf.c + lapacke_dggqrf_work.c + lapacke_dggrqf.c + lapacke_dggrqf_work.c + lapacke_dggsvd3.c + lapacke_dggsvd3_work.c + lapacke_dggsvp3.c + lapacke_dggsvp3_work.c + lapacke_dgtcon.c + lapacke_dgtcon_work.c + lapacke_dgtrfs.c + lapacke_dgtrfs_work.c + lapacke_dgtsv.c + lapacke_dgtsv_work.c + lapacke_dgtsvx.c + lapacke_dgtsvx_work.c + lapacke_dgttrf.c + lapacke_dgttrf_work.c + lapacke_dgttrs.c + lapacke_dgttrs_work.c + lapacke_dhgeqz.c + lapacke_dhgeqz_work.c + lapacke_dhsein.c + lapacke_dhsein_work.c + lapacke_dhseqr.c + lapacke_dhseqr_work.c + lapacke_dlacn2.c + lapacke_dlacn2_work.c + lapacke_dlacpy.c + lapacke_dlacpy_work.c + lapacke_dlag2s.c + lapacke_dlag2s_work.c + lapacke_dlamch.c + lapacke_dlamch_work.c + lapacke_dlange.c + lapacke_dlange_work.c + lapacke_dlansy.c + lapacke_dlansy_work.c + lapacke_dlantr.c + lapacke_dlantr_work.c + lapacke_dlapmr.c + lapacke_dlapmr_work.c + lapacke_dlapmt.c + lapacke_dlapmt_work.c + lapacke_dlapy2.c + lapacke_dlapy2_work.c + lapacke_dlapy3.c + lapacke_dlapy3_work.c + lapacke_dlarfb.c + lapacke_dlarfb_work.c + lapacke_dlarfg.c + lapacke_dlarfg_work.c + lapacke_dlarft.c + lapacke_dlarft_work.c + lapacke_dlarfx.c + lapacke_dlarfx_work.c + lapacke_dlarnv.c + lapacke_dlarnv_work.c + lapacke_dlartgp.c + lapacke_dlartgp_work.c + lapacke_dlartgs.c + lapacke_dlartgs_work.c + lapacke_dlascl.c + lapacke_dlascl_work.c + lapacke_dlaset.c + lapacke_dlaset_work.c + lapacke_dlasrt.c + lapacke_dlasrt_work.c + lapacke_dlaswp.c + lapacke_dlaswp_work.c + lapacke_dlauum.c + lapacke_dlauum_work.c + lapacke_dopgtr.c + lapacke_dopgtr_work.c + lapacke_dopmtr.c + lapacke_dopmtr_work.c + lapacke_dorbdb.c + lapacke_dorbdb_work.c + lapacke_dorcsd2by1.c + lapacke_dorcsd2by1_work.c + lapacke_dorcsd.c + lapacke_dorcsd_work.c + lapacke_dorgbr.c + lapacke_dorgbr_work.c + lapacke_dorghr.c + lapacke_dorghr_work.c + lapacke_dorglq.c + lapacke_dorglq_work.c + lapacke_dorgql.c + lapacke_dorgql_work.c + lapacke_dorgqr.c + lapacke_dorgqr_work.c + lapacke_dorgrq.c + lapacke_dorgrq_work.c + lapacke_dorgtr.c + lapacke_dorgtr_work.c + lapacke_dormbr.c + lapacke_dormbr_work.c + lapacke_dormhr.c + lapacke_dormhr_work.c + lapacke_dormlq.c + lapacke_dormlq_work.c + lapacke_dormql.c + lapacke_dormql_work.c + lapacke_dormqr.c + lapacke_dormqr_work.c + lapacke_dormrq.c + lapacke_dormrq_work.c + lapacke_dormrz.c + lapacke_dormrz_work.c + lapacke_dormtr.c + lapacke_dormtr_work.c + lapacke_dpbcon.c + lapacke_dpbcon_work.c + lapacke_dpbequ.c + lapacke_dpbequ_work.c + lapacke_dpbrfs.c + lapacke_dpbrfs_work.c + lapacke_dpbstf.c + lapacke_dpbstf_work.c + lapacke_dpbsv.c + lapacke_dpbsv_work.c + lapacke_dpbsvx.c + lapacke_dpbsvx_work.c + lapacke_dpbtrf.c + lapacke_dpbtrf_work.c + lapacke_dpbtrs.c + lapacke_dpbtrs_work.c + lapacke_dpftrf.c + lapacke_dpftrf_work.c + lapacke_dpftri.c + lapacke_dpftri_work.c + lapacke_dpftrs.c + lapacke_dpftrs_work.c + lapacke_dpocon.c + lapacke_dpocon_work.c + lapacke_dpoequ.c + lapacke_dpoequ_work.c + lapacke_dpoequb.c + lapacke_dpoequb_work.c + lapacke_dporfs.c + lapacke_dporfs_work.c + lapacke_dposv.c + lapacke_dposv_work.c + lapacke_dposvx.c + lapacke_dposvx_work.c + lapacke_dpotrf.c + lapacke_dpotrf_work.c + lapacke_dpotrf2.c + lapacke_dpotrf2_work.c + lapacke_dpotri.c + lapacke_dpotri_work.c + lapacke_dpotrs.c + lapacke_dpotrs_work.c + lapacke_dppcon.c + lapacke_dppcon_work.c + lapacke_dppequ.c + lapacke_dppequ_work.c + lapacke_dpprfs.c + lapacke_dpprfs_work.c + lapacke_dppsv.c + lapacke_dppsv_work.c + lapacke_dppsvx.c + lapacke_dppsvx_work.c + lapacke_dpptrf.c + lapacke_dpptrf_work.c + lapacke_dpptri.c + lapacke_dpptri_work.c + lapacke_dpptrs.c + lapacke_dpptrs_work.c + lapacke_dpstrf.c + lapacke_dpstrf_work.c + lapacke_dptcon.c + lapacke_dptcon_work.c + lapacke_dpteqr.c + lapacke_dpteqr_work.c + lapacke_dptrfs.c + lapacke_dptrfs_work.c + lapacke_dptsv.c + lapacke_dptsv_work.c + lapacke_dptsvx.c + lapacke_dptsvx_work.c + lapacke_dpttrf.c + lapacke_dpttrf_work.c + lapacke_dpttrs.c + lapacke_dpttrs_work.c + lapacke_dsbev.c + lapacke_dsbev_work.c + lapacke_dsbevd.c + lapacke_dsbevd_work.c + lapacke_dsbevx.c + lapacke_dsbevx_work.c + lapacke_dsbev_2stage.c + lapacke_dsbev_2stage_work.c + lapacke_dsbevd_2stage.c + lapacke_dsbevd_2stage_work.c + lapacke_dsbevx_2stage.c + lapacke_dsbevx_2stage_work.c + lapacke_dsbgst.c + lapacke_dsbgst_work.c + lapacke_dsbgv.c + lapacke_dsbgv_work.c + lapacke_dsbgvd.c + lapacke_dsbgvd_work.c + lapacke_dsbgvx.c + lapacke_dsbgvx_work.c + lapacke_dsbtrd.c + lapacke_dsbtrd_work.c + lapacke_dsfrk.c + lapacke_dsfrk_work.c + lapacke_dsgesv.c + lapacke_dsgesv_work.c + lapacke_dspcon.c + lapacke_dspcon_work.c + lapacke_dspev.c + lapacke_dspev_work.c + lapacke_dspevd.c + lapacke_dspevd_work.c + lapacke_dspevx.c + lapacke_dspevx_work.c + lapacke_dspgst.c + lapacke_dspgst_work.c + lapacke_dspgv.c + lapacke_dspgv_work.c + lapacke_dspgvd.c + lapacke_dspgvd_work.c + lapacke_dspgvx.c + lapacke_dspgvx_work.c + lapacke_dsposv.c + lapacke_dsposv_work.c + lapacke_dsprfs.c + lapacke_dsprfs_work.c + lapacke_dspsv.c + lapacke_dspsv_work.c + lapacke_dspsvx.c + lapacke_dspsvx_work.c + lapacke_dsptrd.c + lapacke_dsptrd_work.c + lapacke_dsptrf.c + lapacke_dsptrf_work.c + lapacke_dsptri.c + lapacke_dsptri_work.c + lapacke_dsptrs.c + lapacke_dsptrs_work.c + lapacke_dstebz.c + lapacke_dstebz_work.c + lapacke_dstedc.c + lapacke_dstedc_work.c + lapacke_dstegr.c + lapacke_dstegr_work.c + lapacke_dstein.c + lapacke_dstein_work.c + lapacke_dstemr.c + lapacke_dstemr_work.c + lapacke_dsteqr.c + lapacke_dsteqr_work.c + lapacke_dsterf.c + lapacke_dsterf_work.c + lapacke_dstev.c + lapacke_dstev_work.c + lapacke_dstevd.c + lapacke_dstevd_work.c + lapacke_dstevr.c + lapacke_dstevr_work.c + lapacke_dstevx.c + lapacke_dstevx_work.c + lapacke_dsycon.c + lapacke_dsycon_work.c + lapacke_dsycon_3.c + lapacke_dsycon_3_work.c + lapacke_dsyconv.c + lapacke_dsyconv_work.c + lapacke_dsyequb.c + lapacke_dsyequb_work.c + lapacke_dsyev.c + lapacke_dsyev_work.c + lapacke_dsyevd.c + lapacke_dsyevd_work.c + lapacke_dsyevr.c + lapacke_dsyevr_work.c + lapacke_dsyevx.c + lapacke_dsyevx_work.c + lapacke_dsyev_2stage.c + lapacke_dsyev_2stage_work.c + lapacke_dsyevd_2stage.c + lapacke_dsyevd_2stage_work.c + lapacke_dsyevr_2stage.c + lapacke_dsyevr_2stage_work.c + lapacke_dsyevx_2stage.c + lapacke_dsyevx_2stage_work.c + lapacke_dsygst.c + lapacke_dsygst_work.c + lapacke_dsygv.c + lapacke_dsygv_work.c + lapacke_dsygv_2stage.c + lapacke_dsygv_2stage_work.c + lapacke_dsygvd.c + lapacke_dsygvd_work.c + lapacke_dsygvx.c + lapacke_dsygvx_work.c + lapacke_dsyrfs.c + lapacke_dsyrfs_work.c + lapacke_dsysv.c + lapacke_dsysv_rook.c + lapacke_dsysv_rook_work.c + lapacke_dsysv_work.c + lapacke_dsysv_aa.c + lapacke_dsysv_aa_work.c + lapacke_dsysv_rk.c + lapacke_dsysv_rk_work.c + lapacke_dsysvx.c + lapacke_dsysvx_work.c + lapacke_dsyswapr.c + lapacke_dsyswapr_work.c + lapacke_dsytrd.c + lapacke_dsytrd_work.c + lapacke_dsytrf.c + lapacke_dsytrf_work.c + lapacke_dsytrf_rook.c + lapacke_dsytrf_rook_work.c + lapacke_dsytrf_aa.c + lapacke_dsytrf_aa_work.c + lapacke_dsytrf_rk.c + lapacke_dsytrf_rk_work.c + lapacke_dsytri.c + lapacke_dsytri2.c + lapacke_dsytri2_work.c + lapacke_dsytri_3.c + lapacke_dsytri_3_work.c + lapacke_dsytri2x.c + lapacke_dsytri2x_work.c + lapacke_dsytri_work.c + lapacke_dsytrs.c + lapacke_dsytrs_rook.c + lapacke_dsytrs2.c + lapacke_dsytrs2_work.c + lapacke_dsytrs_aa.c + lapacke_dsytrs_aa_work.c + lapacke_dsytrs_3.c + lapacke_dsytrs_3_work.c + lapacke_dsytrs_work.c + lapacke_dsytrs_rook_work.c + lapacke_dtbcon.c + lapacke_dtbcon_work.c + lapacke_dtbrfs.c + lapacke_dtbrfs_work.c + lapacke_dtbtrs.c + lapacke_dtbtrs_work.c + lapacke_dtfsm.c + lapacke_dtfsm_work.c + lapacke_dtftri.c + lapacke_dtftri_work.c + lapacke_dtfttp.c + lapacke_dtfttp_work.c + lapacke_dtfttr.c + lapacke_dtfttr_work.c + lapacke_dtgevc.c + lapacke_dtgevc_work.c + lapacke_dtgexc.c + lapacke_dtgexc_work.c + lapacke_dtgsen.c + lapacke_dtgsen_work.c + lapacke_dtgsja.c + lapacke_dtgsja_work.c + lapacke_dtgsna.c + lapacke_dtgsna_work.c + lapacke_dtgsyl.c + lapacke_dtgsyl_work.c + lapacke_dtpcon.c + lapacke_dtpcon_work.c + lapacke_dtpmqrt.c + lapacke_dtpmqrt_work.c + lapacke_dtpqrt.c + lapacke_dtpqrt2.c + lapacke_dtpqrt2_work.c + lapacke_dtpqrt_work.c + lapacke_dtprfb.c + lapacke_dtprfb_work.c + lapacke_dtprfs.c + lapacke_dtprfs_work.c + lapacke_dtptri.c + lapacke_dtptri_work.c + lapacke_dtptrs.c + lapacke_dtptrs_work.c + lapacke_dtpttf.c + lapacke_dtpttf_work.c + lapacke_dtpttr.c + lapacke_dtpttr_work.c + lapacke_dtrcon.c + lapacke_dtrcon_work.c + lapacke_dtrevc.c + lapacke_dtrevc_work.c + lapacke_dtrexc.c + lapacke_dtrexc_work.c + lapacke_dtrrfs.c + lapacke_dtrrfs_work.c + lapacke_dtrsen.c + lapacke_dtrsen_work.c + lapacke_dtrsna.c + lapacke_dtrsna_work.c + lapacke_dtrsyl.c + lapacke_dtrsyl_work.c + lapacke_dtrtri.c + lapacke_dtrtri_work.c + lapacke_dtrtrs.c + lapacke_dtrtrs_work.c + lapacke_dtrttf.c + lapacke_dtrttf_work.c + lapacke_dtrttp.c + lapacke_dtrttp_work.c + lapacke_dtzrzf.c lapacke_dtzrzf_work.c ) set(SSRC - lapacke_sbbcsd.c - lapacke_sbbcsd_work.c - lapacke_sbdsdc.c - lapacke_sbdsdc_work.c - lapacke_sbdsqr.c - lapacke_sbdsqr_work.c - lapacke_sdisna.c - lapacke_sdisna_work.c - lapacke_sgbbrd.c - lapacke_sgbbrd_work.c - lapacke_sgbcon.c - lapacke_sgbcon_work.c - lapacke_sgbequ.c - lapacke_sgbequ_work.c - lapacke_sgbequb.c - lapacke_sgbequb_work.c - lapacke_sgbrfs.c - lapacke_sgbrfs_work.c - lapacke_sgbsv.c - lapacke_sgbsv_work.c - lapacke_sgbsvx.c - lapacke_sgbsvx_work.c - lapacke_sgbtrf.c - lapacke_sgbtrf_work.c - lapacke_sgbtrs.c - lapacke_sgbtrs_work.c - lapacke_sgebak.c - lapacke_sgebak_work.c - lapacke_sgebal.c - lapacke_sgebal_work.c - lapacke_sgebrd.c - lapacke_sgebrd_work.c - lapacke_sgecon.c - lapacke_sgecon_work.c - lapacke_sgeequ.c - lapacke_sgeequ_work.c - lapacke_sgeequb.c - lapacke_sgeequb_work.c - lapacke_sgees.c - lapacke_sgees_work.c - lapacke_sgeesx.c - lapacke_sgeesx_work.c - lapacke_sgeev.c - lapacke_sgeev_work.c - lapacke_sgeevx.c - lapacke_sgeevx_work.c - lapacke_sgehrd.c - lapacke_sgehrd_work.c - lapacke_sgejsv.c - lapacke_sgejsv_work.c - lapacke_sgelq2.c - lapacke_sgelq2_work.c - lapacke_sgelqf.c - lapacke_sgelqf_work.c - lapacke_sgels.c - lapacke_sgels_work.c - lapacke_sgelsd.c - lapacke_sgelsd_work.c - lapacke_sgelss.c - lapacke_sgelss_work.c - lapacke_sgelsy.c - lapacke_sgelsy_work.c - lapacke_sgemqrt.c - lapacke_sgemqrt_work.c - lapacke_sgeqlf.c - lapacke_sgeqlf_work.c - lapacke_sgeqp3.c - lapacke_sgeqp3_work.c - lapacke_sgeqpf.c - lapacke_sgeqpf_work.c - lapacke_sgeqr2.c - lapacke_sgeqr2_work.c - lapacke_sgeqrf.c - lapacke_sgeqrf_work.c - lapacke_sgeqrfp.c - lapacke_sgeqrfp_work.c - lapacke_sgeqrt.c - lapacke_sgeqrt2.c - lapacke_sgeqrt2_work.c - lapacke_sgeqrt3.c - lapacke_sgeqrt3_work.c - lapacke_sgeqrt_work.c - lapacke_sgerfs.c - lapacke_sgerfs_work.c - lapacke_sgerqf.c - lapacke_sgerqf_work.c - lapacke_sgesdd.c - lapacke_sgesdd_work.c - lapacke_sgesv.c - lapacke_sgesv_work.c - lapacke_sgesvd.c - lapacke_sgesvd_work.c - lapacke_sgesvj.c - lapacke_sgesvj_work.c - lapacke_sgesvx.c - lapacke_sgesvx_work.c - lapacke_sgetf2.c - lapacke_sgetf2_work.c - lapacke_sgetrf.c - lapacke_sgetrf_work.c - lapacke_sgetri.c - lapacke_sgetri_work.c - lapacke_sgetrs.c - lapacke_sgetrs_work.c - lapacke_sggbak.c - lapacke_sggbak_work.c - lapacke_sggbal.c - lapacke_sggbal_work.c - lapacke_sgges.c - lapacke_sgges_work.c - lapacke_sggesx.c - lapacke_sggesx_work.c - lapacke_sggev.c - lapacke_sggev_work.c - lapacke_sggevx.c - lapacke_sggevx_work.c - lapacke_sggglm.c - lapacke_sggglm_work.c - lapacke_sgghrd.c - lapacke_sgghrd_work.c - lapacke_sgglse.c - lapacke_sgglse_work.c - lapacke_sggqrf.c - lapacke_sggqrf_work.c - lapacke_sggrqf.c - lapacke_sggrqf_work.c - lapacke_sggsvd.c - lapacke_sggsvd_work.c - lapacke_sggsvp.c - lapacke_sggsvp_work.c - lapacke_sgtcon.c - lapacke_sgtcon_work.c - lapacke_sgtrfs.c - lapacke_sgtrfs_work.c - lapacke_sgtsv.c - lapacke_sgtsv_work.c - lapacke_sgtsvx.c - lapacke_sgtsvx_work.c - lapacke_sgttrf.c - lapacke_sgttrf_work.c - lapacke_sgttrs.c - lapacke_sgttrs_work.c - lapacke_shgeqz.c - lapacke_shgeqz_work.c - lapacke_shsein.c - lapacke_shsein_work.c - lapacke_shseqr.c - lapacke_shseqr_work.c - lapacke_slacn2.c - lapacke_slacn2_work.c - lapacke_slacpy.c - lapacke_slacpy_work.c - lapacke_slag2d.c - lapacke_slag2d_work.c - lapacke_slamch.c - lapacke_slamch_work.c - lapacke_slange.c - lapacke_slange_work.c - lapacke_slansy.c - lapacke_slansy_work.c - lapacke_slantr.c - lapacke_slantr_work.c - lapacke_slapmr.c - lapacke_slapmr_work.c - lapacke_slapy2.c - lapacke_slapy2_work.c - lapacke_slapy3.c - lapacke_slapy3_work.c - lapacke_slarfb.c - lapacke_slarfb_work.c - lapacke_slarfg.c - lapacke_slarfg_work.c - lapacke_slarft.c - lapacke_slarft_work.c - lapacke_slarfx.c - lapacke_slarfx_work.c - lapacke_slarnv.c - lapacke_slarnv_work.c - lapacke_slartgp.c - lapacke_slartgp_work.c - lapacke_slartgs.c - lapacke_slartgs_work.c - lapacke_slaset.c - lapacke_slaset_work.c - lapacke_slasrt.c - lapacke_slasrt_work.c - lapacke_slaswp.c - lapacke_slaswp_work.c - lapacke_slauum.c - lapacke_slauum_work.c - lapacke_sopgtr.c - lapacke_sopgtr_work.c - lapacke_sopmtr.c - lapacke_sopmtr_work.c - lapacke_sorbdb.c - lapacke_sorbdb_work.c - lapacke_sorcsd.c - lapacke_sorcsd_work.c - lapacke_sorgbr.c - lapacke_sorgbr_work.c - lapacke_sorghr.c - lapacke_sorghr_work.c - lapacke_sorglq.c - lapacke_sorglq_work.c - lapacke_sorgql.c - lapacke_sorgql_work.c - lapacke_sorgqr.c - lapacke_sorgqr_work.c - lapacke_sorgrq.c - lapacke_sorgrq_work.c - lapacke_sorgtr.c - lapacke_sorgtr_work.c - lapacke_sormbr.c - lapacke_sormbr_work.c - lapacke_sormhr.c - lapacke_sormhr_work.c - lapacke_sormlq.c - lapacke_sormlq_work.c - lapacke_sormql.c - lapacke_sormql_work.c - lapacke_sormqr.c - lapacke_sormqr_work.c - lapacke_sormrq.c - lapacke_sormrq_work.c - lapacke_sormrz.c - lapacke_sormrz_work.c - lapacke_sormtr.c - lapacke_sormtr_work.c - lapacke_spbcon.c - lapacke_spbcon_work.c - lapacke_spbequ.c - lapacke_spbequ_work.c - lapacke_spbrfs.c - lapacke_spbrfs_work.c - lapacke_spbstf.c - lapacke_spbstf_work.c - lapacke_spbsv.c - lapacke_spbsv_work.c - lapacke_spbsvx.c - lapacke_spbsvx_work.c - lapacke_spbtrf.c - lapacke_spbtrf_work.c - lapacke_spbtrs.c - lapacke_spbtrs_work.c - lapacke_spftrf.c - lapacke_spftrf_work.c - lapacke_spftri.c - lapacke_spftri_work.c - lapacke_spftrs.c - lapacke_spftrs_work.c - lapacke_spocon.c - lapacke_spocon_work.c - lapacke_spoequ.c - lapacke_spoequ_work.c - lapacke_spoequb.c - lapacke_spoequb_work.c - lapacke_sporfs.c - lapacke_sporfs_work.c - lapacke_sposv.c - lapacke_sposv_work.c - lapacke_sposvx.c - lapacke_sposvx_work.c - lapacke_spotrf.c - lapacke_spotrf_work.c - lapacke_spotri.c - lapacke_spotri_work.c - lapacke_spotrs.c - lapacke_spotrs_work.c - lapacke_sppcon.c - lapacke_sppcon_work.c - lapacke_sppequ.c - lapacke_sppequ_work.c - lapacke_spprfs.c - lapacke_spprfs_work.c - lapacke_sppsv.c - lapacke_sppsv_work.c - lapacke_sppsvx.c - lapacke_sppsvx_work.c - lapacke_spptrf.c - lapacke_spptrf_work.c - lapacke_spptri.c - lapacke_spptri_work.c - lapacke_spptrs.c - lapacke_spptrs_work.c - lapacke_spstrf.c - lapacke_spstrf_work.c - lapacke_sptcon.c - lapacke_sptcon_work.c - lapacke_spteqr.c - lapacke_spteqr_work.c - lapacke_sptrfs.c - lapacke_sptrfs_work.c - lapacke_sptsv.c - lapacke_sptsv_work.c - lapacke_sptsvx.c - lapacke_sptsvx_work.c - lapacke_spttrf.c - lapacke_spttrf_work.c - lapacke_spttrs.c - lapacke_spttrs_work.c - lapacke_ssbev.c - lapacke_ssbev_work.c - lapacke_ssbevd.c - lapacke_ssbevd_work.c - lapacke_ssbevx.c - lapacke_ssbevx_work.c - lapacke_ssbgst.c - lapacke_ssbgst_work.c - lapacke_ssbgv.c - lapacke_ssbgv_work.c - lapacke_ssbgvd.c - lapacke_ssbgvd_work.c - lapacke_ssbgvx.c - lapacke_ssbgvx_work.c - lapacke_ssbtrd.c - lapacke_ssbtrd_work.c - lapacke_ssfrk.c - lapacke_ssfrk_work.c - lapacke_sspcon.c - lapacke_sspcon_work.c - lapacke_sspev.c - lapacke_sspev_work.c - lapacke_sspevd.c - lapacke_sspevd_work.c - lapacke_sspevx.c - lapacke_sspevx_work.c - lapacke_sspgst.c - lapacke_sspgst_work.c - lapacke_sspgv.c - lapacke_sspgv_work.c - lapacke_sspgvd.c - lapacke_sspgvd_work.c - lapacke_sspgvx.c - lapacke_sspgvx_work.c - lapacke_ssprfs.c - lapacke_ssprfs_work.c - lapacke_sspsv.c - lapacke_sspsv_work.c - lapacke_sspsvx.c - lapacke_sspsvx_work.c - lapacke_ssptrd.c - lapacke_ssptrd_work.c - lapacke_ssptrf.c - lapacke_ssptrf_work.c - lapacke_ssptri.c - lapacke_ssptri_work.c - lapacke_ssptrs.c - lapacke_ssptrs_work.c - lapacke_sstebz.c - lapacke_sstebz_work.c - lapacke_sstedc.c - lapacke_sstedc_work.c - lapacke_sstegr.c - lapacke_sstegr_work.c - lapacke_sstein.c - lapacke_sstein_work.c - lapacke_sstemr.c - lapacke_sstemr_work.c - lapacke_ssteqr.c - lapacke_ssteqr_work.c - lapacke_ssterf.c - lapacke_ssterf_work.c - lapacke_sstev.c - lapacke_sstev_work.c - lapacke_sstevd.c - lapacke_sstevd_work.c - lapacke_sstevr.c - lapacke_sstevr_work.c - lapacke_sstevx.c - lapacke_sstevx_work.c - lapacke_ssycon.c - lapacke_ssycon_work.c - lapacke_ssyconv.c - lapacke_ssyconv_work.c - lapacke_ssyequb.c - lapacke_ssyequb_work.c - lapacke_ssyev.c - lapacke_ssyev_work.c - lapacke_ssyevd.c - lapacke_ssyevd_work.c - lapacke_ssyevr.c - lapacke_ssyevr_work.c - lapacke_ssyevx.c - lapacke_ssyevx_work.c - lapacke_ssygst.c - lapacke_ssygst_work.c - lapacke_ssygv.c - lapacke_ssygv_work.c - lapacke_ssygvd.c - lapacke_ssygvd_work.c - lapacke_ssygvx.c - lapacke_ssygvx_work.c - lapacke_ssyrfs.c - lapacke_ssyrfs_work.c - lapacke_ssysv.c - lapacke_ssysv_rook.c - lapacke_ssysv_rook_work.c - lapacke_ssysv_work.c - lapacke_ssysvx.c - lapacke_ssysvx_work.c - lapacke_ssyswapr.c - lapacke_ssyswapr_work.c - lapacke_ssytrd.c - lapacke_ssytrd_work.c - lapacke_ssytrf.c - lapacke_ssytrf_work.c - lapacke_ssytri.c - lapacke_ssytri2.c - lapacke_ssytri2_work.c - lapacke_ssytri2x.c - lapacke_ssytri2x_work.c - lapacke_ssytri_work.c - lapacke_ssytrs.c - lapacke_ssytrs2.c - lapacke_ssytrs2_work.c - lapacke_ssytrs_work.c - lapacke_stbcon.c - lapacke_stbcon_work.c - lapacke_stbrfs.c - lapacke_stbrfs_work.c - lapacke_stbtrs.c - lapacke_stbtrs_work.c - lapacke_stfsm.c - lapacke_stfsm_work.c - lapacke_stftri.c - lapacke_stftri_work.c - lapacke_stfttp.c - lapacke_stfttp_work.c - lapacke_stfttr.c - lapacke_stfttr_work.c - lapacke_stgevc.c - lapacke_stgevc_work.c - lapacke_stgexc.c - lapacke_stgexc_work.c - lapacke_stgsen.c - lapacke_stgsen_work.c - lapacke_stgsja.c - lapacke_stgsja_work.c - lapacke_stgsna.c - lapacke_stgsna_work.c - lapacke_stgsyl.c - lapacke_stgsyl_work.c - lapacke_stpcon.c - lapacke_stpcon_work.c - lapacke_stpmqrt.c - lapacke_stpmqrt_work.c - lapacke_stpqrt2.c - lapacke_stpqrt2_work.c - lapacke_stprfb.c - lapacke_stprfb_work.c - lapacke_stprfs.c - lapacke_stprfs_work.c - lapacke_stptri.c - lapacke_stptri_work.c - lapacke_stptrs.c - lapacke_stptrs_work.c - lapacke_stpttf.c - lapacke_stpttf_work.c - lapacke_stpttr.c - lapacke_stpttr_work.c - lapacke_strcon.c - lapacke_strcon_work.c - lapacke_strevc.c - lapacke_strevc_work.c - lapacke_strexc.c - lapacke_strexc_work.c - lapacke_strrfs.c - lapacke_strrfs_work.c - lapacke_strsen.c - lapacke_strsen_work.c - lapacke_strsna.c - lapacke_strsna_work.c - lapacke_strsyl.c - lapacke_strsyl_work.c - lapacke_strtri.c - lapacke_strtri_work.c - lapacke_strtrs.c - lapacke_strtrs_work.c - lapacke_strttf.c - lapacke_strttf_work.c - lapacke_strttp.c - lapacke_strttp_work.c - lapacke_stzrzf.c + lapacke_sbbcsd.c + lapacke_sbbcsd_work.c + lapacke_sbdsdc.c + lapacke_sbdsdc_work.c + lapacke_sbdsvdx.c + lapacke_sbdsvdx_work.c + lapacke_sbdsqr.c + lapacke_sbdsqr_work.c + lapacke_sdisna.c + lapacke_sdisna_work.c + lapacke_sgbbrd.c + lapacke_sgbbrd_work.c + lapacke_sgbcon.c + lapacke_sgbcon_work.c + lapacke_sgbequ.c + lapacke_sgbequ_work.c + lapacke_sgbequb.c + lapacke_sgbequb_work.c + lapacke_sgbrfs.c + lapacke_sgbrfs_work.c + lapacke_sgbsv.c + lapacke_sgbsv_work.c + lapacke_sgbsvx.c + lapacke_sgbsvx_work.c + lapacke_sgbtrf.c + lapacke_sgbtrf_work.c + lapacke_sgbtrs.c + lapacke_sgbtrs_work.c + lapacke_sgebak.c + lapacke_sgebak_work.c + lapacke_sgebal.c + lapacke_sgebal_work.c + lapacke_sgebrd.c + lapacke_sgebrd_work.c + lapacke_sgecon.c + lapacke_sgecon_work.c + lapacke_sgeequ.c + lapacke_sgeequ_work.c + lapacke_sgeequb.c + lapacke_sgeequb_work.c + lapacke_sgees.c + lapacke_sgees_work.c + lapacke_sgeesx.c + lapacke_sgeesx_work.c + lapacke_sgeev.c + lapacke_sgeev_work.c + lapacke_sgeevx.c + lapacke_sgeevx_work.c + lapacke_sgehrd.c + lapacke_sgehrd_work.c + lapacke_sgejsv.c + lapacke_sgejsv_work.c + lapacke_sgelq2.c + lapacke_sgelq2_work.c + lapacke_sgelqf.c + lapacke_sgelqf_work.c + lapacke_sgels.c + lapacke_sgels_work.c + lapacke_sgelsd.c + lapacke_sgelsd_work.c + lapacke_sgelss.c + lapacke_sgelss_work.c + lapacke_sgelsy.c + lapacke_sgelsy_work.c + lapacke_sgemqr.c + lapacke_sgemqr_work.c + lapacke_sgemqrt.c + lapacke_sgemqrt_work.c + lapacke_sgeqlf.c + lapacke_sgeqlf_work.c + lapacke_sgeqp3.c + lapacke_sgeqp3_work.c + lapacke_sgeqr2.c + lapacke_sgeqr2_work.c + lapacke_sgeqrf.c + lapacke_sgeqrf_work.c + lapacke_sgeqrfp.c + lapacke_sgeqrfp_work.c + lapacke_sgeqrt.c + lapacke_sgeqrt2.c + lapacke_sgeqrt2_work.c + lapacke_sgeqrt3.c + lapacke_sgeqrt3_work.c + lapacke_sgeqrt_work.c + lapacke_sgerfs.c + lapacke_sgerfs_work.c + lapacke_sgerqf.c + lapacke_sgerqf_work.c + lapacke_sgesdd.c + lapacke_sgesdd_work.c + lapacke_sgesv.c + lapacke_sgesv_work.c + lapacke_sgesvd.c + lapacke_sgesvd_work.c + lapacke_sgesvdx.c + lapacke_sgesvdx_work.c + lapacke_sgesvj.c + lapacke_sgesvj_work.c + lapacke_sgesvx.c + lapacke_sgesvx_work.c + lapacke_sgetf2.c + lapacke_sgetf2_work.c + lapacke_sgetrf.c + lapacke_sgetrf_work.c + lapacke_sgetrf2.c + lapacke_sgetrf2_work.c + lapacke_sgetri.c + lapacke_sgetri_work.c + lapacke_sgetrs.c + lapacke_sgetrs_work.c + lapacke_sgetsls.c + lapacke_sgetsls_work.c + lapacke_sggbak.c + lapacke_sggbak_work.c + lapacke_sggbal.c + lapacke_sggbal_work.c + lapacke_sgges.c + lapacke_sgges_work.c + lapacke_sgges3.c + lapacke_sgges3_work.c + lapacke_sggesx.c + lapacke_sggesx_work.c + lapacke_sggev.c + lapacke_sggev_work.c + lapacke_sggev3.c + lapacke_sggev3_work.c + lapacke_sggevx.c + lapacke_sggevx_work.c + lapacke_sggglm.c + lapacke_sggglm_work.c + lapacke_sgghrd.c + lapacke_sgghrd_work.c + lapacke_sgghd3.c + lapacke_sgghd3_work.c + lapacke_sgglse.c + lapacke_sgglse_work.c + lapacke_sggqrf.c + lapacke_sggqrf_work.c + lapacke_sggrqf.c + lapacke_sggrqf_work.c + lapacke_sggsvd3.c + lapacke_sggsvd3_work.c + lapacke_sggsvp3.c + lapacke_sggsvp3_work.c + lapacke_sgtcon.c + lapacke_sgtcon_work.c + lapacke_sgtrfs.c + lapacke_sgtrfs_work.c + lapacke_sgtsv.c + lapacke_sgtsv_work.c + lapacke_sgtsvx.c + lapacke_sgtsvx_work.c + lapacke_sgttrf.c + lapacke_sgttrf_work.c + lapacke_sgttrs.c + lapacke_sgttrs_work.c + lapacke_shgeqz.c + lapacke_shgeqz_work.c + lapacke_shsein.c + lapacke_shsein_work.c + lapacke_shseqr.c + lapacke_shseqr_work.c + lapacke_slacn2.c + lapacke_slacn2_work.c + lapacke_slacpy.c + lapacke_slacpy_work.c + lapacke_slag2d.c + lapacke_slag2d_work.c + lapacke_slamch.c + lapacke_slamch_work.c + lapacke_slange.c + lapacke_slange_work.c + lapacke_slansy.c + lapacke_slansy_work.c + lapacke_slantr.c + lapacke_slantr_work.c + lapacke_slapmr.c + lapacke_slapmr_work.c + lapacke_slapmt.c + lapacke_slapmt_work.c + lapacke_slapy2.c + lapacke_slapy2_work.c + lapacke_slapy3.c + lapacke_slapy3_work.c + lapacke_slarfb.c + lapacke_slarfb_work.c + lapacke_slarfg.c + lapacke_slarfg_work.c + lapacke_slarft.c + lapacke_slarft_work.c + lapacke_slarfx.c + lapacke_slarfx_work.c + lapacke_slarnv.c + lapacke_slarnv_work.c + lapacke_slartgp.c + lapacke_slartgp_work.c + lapacke_slartgs.c + lapacke_slartgs_work.c + lapacke_slascl.c + lapacke_slascl_work.c + lapacke_slaset.c + lapacke_slaset_work.c + lapacke_slasrt.c + lapacke_slasrt_work.c + lapacke_slaswp.c + lapacke_slaswp_work.c + lapacke_slauum.c + lapacke_slauum_work.c + lapacke_sopgtr.c + lapacke_sopgtr_work.c + lapacke_sopmtr.c + lapacke_sopmtr_work.c + lapacke_sorbdb.c + lapacke_sorbdb_work.c + lapacke_sorcsd.c + lapacke_sorcsd_work.c + lapacke_sorcsd2by1.c + lapacke_sorcsd2by1_work.c + lapacke_sorgbr.c + lapacke_sorgbr_work.c + lapacke_sorghr.c + lapacke_sorghr_work.c + lapacke_sorglq.c + lapacke_sorglq_work.c + lapacke_sorgql.c + lapacke_sorgql_work.c + lapacke_sorgqr.c + lapacke_sorgqr_work.c + lapacke_sorgrq.c + lapacke_sorgrq_work.c + lapacke_sorgtr.c + lapacke_sorgtr_work.c + lapacke_sormbr.c + lapacke_sormbr_work.c + lapacke_sormhr.c + lapacke_sormhr_work.c + lapacke_sormlq.c + lapacke_sormlq_work.c + lapacke_sormql.c + lapacke_sormql_work.c + lapacke_sormqr.c + lapacke_sormqr_work.c + lapacke_sormrq.c + lapacke_sormrq_work.c + lapacke_sormrz.c + lapacke_sormrz_work.c + lapacke_sormtr.c + lapacke_sormtr_work.c + lapacke_spbcon.c + lapacke_spbcon_work.c + lapacke_spbequ.c + lapacke_spbequ_work.c + lapacke_spbrfs.c + lapacke_spbrfs_work.c + lapacke_spbstf.c + lapacke_spbstf_work.c + lapacke_spbsv.c + lapacke_spbsv_work.c + lapacke_spbsvx.c + lapacke_spbsvx_work.c + lapacke_spbtrf.c + lapacke_spbtrf_work.c + lapacke_spbtrs.c + lapacke_spbtrs_work.c + lapacke_spftrf.c + lapacke_spftrf_work.c + lapacke_spftri.c + lapacke_spftri_work.c + lapacke_spftrs.c + lapacke_spftrs_work.c + lapacke_spocon.c + lapacke_spocon_work.c + lapacke_spoequ.c + lapacke_spoequ_work.c + lapacke_spoequb.c + lapacke_spoequb_work.c + lapacke_sporfs.c + lapacke_sporfs_work.c + lapacke_sposv.c + lapacke_sposv_work.c + lapacke_sposvx.c + lapacke_sposvx_work.c + lapacke_spotrf.c + lapacke_spotrf_work.c + lapacke_spotrf2.c + lapacke_spotrf2_work.c + lapacke_spotri.c + lapacke_spotri_work.c + lapacke_spotrs.c + lapacke_spotrs_work.c + lapacke_sppcon.c + lapacke_sppcon_work.c + lapacke_sppequ.c + lapacke_sppequ_work.c + lapacke_spprfs.c + lapacke_spprfs_work.c + lapacke_sppsv.c + lapacke_sppsv_work.c + lapacke_sppsvx.c + lapacke_sppsvx_work.c + lapacke_spptrf.c + lapacke_spptrf_work.c + lapacke_spptri.c + lapacke_spptri_work.c + lapacke_spptrs.c + lapacke_spptrs_work.c + lapacke_spstrf.c + lapacke_spstrf_work.c + lapacke_sptcon.c + lapacke_sptcon_work.c + lapacke_spteqr.c + lapacke_spteqr_work.c + lapacke_sptrfs.c + lapacke_sptrfs_work.c + lapacke_sptsv.c + lapacke_sptsv_work.c + lapacke_sptsvx.c + lapacke_sptsvx_work.c + lapacke_spttrf.c + lapacke_spttrf_work.c + lapacke_spttrs.c + lapacke_spttrs_work.c + lapacke_ssbev.c + lapacke_ssbev_work.c + lapacke_ssbevd.c + lapacke_ssbevd_work.c + lapacke_ssbevx.c + lapacke_ssbevx_work.c + lapacke_ssbev_2stage.c + lapacke_ssbev_2stage_work.c + lapacke_ssbevd_2stage.c + lapacke_ssbevd_2stage_work.c + lapacke_ssbevx_2stage.c + lapacke_ssbevx_2stage_work.c + lapacke_ssbgst.c + lapacke_ssbgst_work.c + lapacke_ssbgv.c + lapacke_ssbgv_work.c + lapacke_ssbgvd.c + lapacke_ssbgvd_work.c + lapacke_ssbgvx.c + lapacke_ssbgvx_work.c + lapacke_ssbtrd.c + lapacke_ssbtrd_work.c + lapacke_ssfrk.c + lapacke_ssfrk_work.c + lapacke_sspcon.c + lapacke_sspcon_work.c + lapacke_sspev.c + lapacke_sspev_work.c + lapacke_sspevd.c + lapacke_sspevd_work.c + lapacke_sspevx.c + lapacke_sspevx_work.c + lapacke_sspgst.c + lapacke_sspgst_work.c + lapacke_sspgv.c + lapacke_sspgv_work.c + lapacke_sspgvd.c + lapacke_sspgvd_work.c + lapacke_sspgvx.c + lapacke_sspgvx_work.c + lapacke_ssprfs.c + lapacke_ssprfs_work.c + lapacke_sspsv.c + lapacke_sspsv_work.c + lapacke_sspsvx.c + lapacke_sspsvx_work.c + lapacke_ssptrd.c + lapacke_ssptrd_work.c + lapacke_ssptrf.c + lapacke_ssptrf_work.c + lapacke_ssptri.c + lapacke_ssptri_work.c + lapacke_ssptrs.c + lapacke_ssptrs_work.c + lapacke_sstebz.c + lapacke_sstebz_work.c + lapacke_sstedc.c + lapacke_sstedc_work.c + lapacke_sstegr.c + lapacke_sstegr_work.c + lapacke_sstein.c + lapacke_sstein_work.c + lapacke_sstemr.c + lapacke_sstemr_work.c + lapacke_ssteqr.c + lapacke_ssteqr_work.c + lapacke_ssterf.c + lapacke_ssterf_work.c + lapacke_sstev.c + lapacke_sstev_work.c + lapacke_sstevd.c + lapacke_sstevd_work.c + lapacke_sstevr.c + lapacke_sstevr_work.c + lapacke_sstevx.c + lapacke_sstevx_work.c + lapacke_ssycon.c + lapacke_ssycon_work.c + lapacke_ssycon_3.c + lapacke_ssycon_3_work.c + lapacke_ssyconv.c + lapacke_ssyconv_work.c + lapacke_ssyequb.c + lapacke_ssyequb_work.c + lapacke_ssyev.c + lapacke_ssyev_work.c + lapacke_ssyevd.c + lapacke_ssyevd_work.c + lapacke_ssyevr.c + lapacke_ssyevr_work.c + lapacke_ssyevx.c + lapacke_ssyevx_work.c + lapacke_ssyev_2stage.c + lapacke_ssyev_2stage_work.c + lapacke_ssyevd_2stage.c + lapacke_ssyevd_2stage_work.c + lapacke_ssyevr_2stage.c + lapacke_ssyevr_2stage_work.c + lapacke_ssyevx_2stage.c + lapacke_ssyevx_2stage_work.c + lapacke_ssygst.c + lapacke_ssygst_work.c + lapacke_ssygv.c + lapacke_ssygv_work.c + lapacke_ssygv_2stage.c + lapacke_ssygv_2stage_work.c + lapacke_ssygvd.c + lapacke_ssygvd_work.c + lapacke_ssygvx.c + lapacke_ssygvx_work.c + lapacke_ssyrfs.c + lapacke_ssyrfs_work.c + lapacke_ssysv.c + lapacke_ssysv_rook.c + lapacke_ssysv_rook_work.c + lapacke_ssysv_work.c + lapacke_ssysv_aa.c + lapacke_ssysv_aa_work.c + lapacke_ssysv_rk.c + lapacke_ssysv_rk_work.c + lapacke_ssysvx.c + lapacke_ssysvx_work.c + lapacke_ssyswapr.c + lapacke_ssyswapr_work.c + lapacke_ssytrd.c + lapacke_ssytrd_work.c + lapacke_ssytrf.c + lapacke_ssytrf_work.c + lapacke_ssytrf_rook.c + lapacke_ssytrf_rook_work.c + lapacke_ssytrf_aa.c + lapacke_ssytrf_aa_work.c + lapacke_ssytrf_rk.c + lapacke_ssytrf_rk_work.c + lapacke_ssytri.c + lapacke_ssytri2.c + lapacke_ssytri2_work.c + lapacke_ssytri_3.c + lapacke_ssytri_3_work.c + lapacke_ssytri2x.c + lapacke_ssytri2x_work.c + lapacke_ssytri_work.c + lapacke_ssytrs.c + lapacke_ssytrs_rook.c + lapacke_ssytrs2.c + lapacke_ssytrs2_work.c + lapacke_ssytrs_aa.c + lapacke_ssytrs_aa_work.c + lapacke_ssytrs_3.c + lapacke_ssytrs_3_work.c + lapacke_ssytrs_work.c + lapacke_ssytrs_rook_work.c + lapacke_stbcon.c + lapacke_stbcon_work.c + lapacke_stbrfs.c + lapacke_stbrfs_work.c + lapacke_stbtrs.c + lapacke_stbtrs_work.c + lapacke_stfsm.c + lapacke_stfsm_work.c + lapacke_stftri.c + lapacke_stftri_work.c + lapacke_stfttp.c + lapacke_stfttp_work.c + lapacke_stfttr.c + lapacke_stfttr_work.c + lapacke_stgevc.c + lapacke_stgevc_work.c + lapacke_stgexc.c + lapacke_stgexc_work.c + lapacke_stgsen.c + lapacke_stgsen_work.c + lapacke_stgsja.c + lapacke_stgsja_work.c + lapacke_stgsna.c + lapacke_stgsna_work.c + lapacke_stgsyl.c + lapacke_stgsyl_work.c + lapacke_stpcon.c + lapacke_stpcon_work.c + lapacke_stpmqrt.c + lapacke_stpmqrt_work.c + lapacke_stpqrt.c + lapacke_stpqrt_work.c + lapacke_stpqrt2.c + lapacke_stpqrt2_work.c + lapacke_stprfb.c + lapacke_stprfb_work.c + lapacke_stprfs.c + lapacke_stprfs_work.c + lapacke_stptri.c + lapacke_stptri_work.c + lapacke_stptrs.c + lapacke_stptrs_work.c + lapacke_stpttf.c + lapacke_stpttf_work.c + lapacke_stpttr.c + lapacke_stpttr_work.c + lapacke_strcon.c + lapacke_strcon_work.c + lapacke_strevc.c + lapacke_strevc_work.c + lapacke_strexc.c + lapacke_strexc_work.c + lapacke_strrfs.c + lapacke_strrfs_work.c + lapacke_strsen.c + lapacke_strsen_work.c + lapacke_strsna.c + lapacke_strsna_work.c + lapacke_strsyl.c + lapacke_strsyl_work.c + lapacke_strtri.c + lapacke_strtri_work.c + lapacke_strtrs.c + lapacke_strtrs_work.c + lapacke_strttf.c + lapacke_strttf_work.c + lapacke_strttp.c + lapacke_strttp_work.c + lapacke_stzrzf.c lapacke_stzrzf_work.c ) set(ZSRC - lapacke_zbbcsd.c - lapacke_zbbcsd_work.c - lapacke_zbdsqr.c - lapacke_zbdsqr_work.c - lapacke_zcgesv.c - lapacke_zcgesv_work.c - lapacke_zcposv.c - lapacke_zcposv_work.c - lapacke_zgbbrd.c - lapacke_zgbbrd_work.c - lapacke_zgbcon.c - lapacke_zgbcon_work.c - lapacke_zgbequ.c - lapacke_zgbequ_work.c - lapacke_zgbequb.c - lapacke_zgbequb_work.c - lapacke_zgbrfs.c - lapacke_zgbrfs_work.c - lapacke_zgbsv.c - lapacke_zgbsv_work.c - lapacke_zgbsvx.c - lapacke_zgbsvx_work.c - lapacke_zgbtrf.c - lapacke_zgbtrf_work.c - lapacke_zgbtrs.c - lapacke_zgbtrs_work.c - lapacke_zgebak.c - lapacke_zgebak_work.c - lapacke_zgebal.c - lapacke_zgebal_work.c - lapacke_zgebrd.c - lapacke_zgebrd_work.c - lapacke_zgecon.c - lapacke_zgecon_work.c - lapacke_zgeequ.c - lapacke_zgeequ_work.c - lapacke_zgeequb.c - lapacke_zgeequb_work.c - lapacke_zgees.c - lapacke_zgees_work.c - lapacke_zgeesx.c - lapacke_zgeesx_work.c - lapacke_zgeev.c - lapacke_zgeev_work.c - lapacke_zgeevx.c - lapacke_zgeevx_work.c - lapacke_zgehrd.c - lapacke_zgehrd_work.c - lapacke_zgelq2.c - lapacke_zgelq2_work.c - lapacke_zgelqf.c - lapacke_zgelqf_work.c - lapacke_zgels.c - lapacke_zgels_work.c - lapacke_zgelsd.c - lapacke_zgelsd_work.c - lapacke_zgelss.c - lapacke_zgelss_work.c - lapacke_zgelsy.c - lapacke_zgelsy_work.c - lapacke_zgemqrt.c - lapacke_zgemqrt_work.c - lapacke_zgeqlf.c - lapacke_zgeqlf_work.c - lapacke_zgeqp3.c - lapacke_zgeqp3_work.c - lapacke_zgeqpf.c - lapacke_zgeqpf_work.c - lapacke_zgeqr2.c - lapacke_zgeqr2_work.c - lapacke_zgeqrf.c - lapacke_zgeqrf_work.c - lapacke_zgeqrfp.c - lapacke_zgeqrfp_work.c - lapacke_zgeqrt.c - lapacke_zgeqrt2.c - lapacke_zgeqrt2_work.c - lapacke_zgeqrt3.c - lapacke_zgeqrt3_work.c - lapacke_zgeqrt_work.c - lapacke_zgerfs.c - lapacke_zgerfs_work.c - lapacke_zgerqf.c - lapacke_zgerqf_work.c - lapacke_zgesdd.c - lapacke_zgesdd_work.c - lapacke_zgesv.c - lapacke_zgesv_work.c - lapacke_zgesvd.c - lapacke_zgesvd_work.c - lapacke_zgesvx.c - lapacke_zgesvx_work.c - lapacke_zgetf2.c - lapacke_zgetf2_work.c - lapacke_zgetrf.c - lapacke_zgetrf_work.c - lapacke_zgetri.c - lapacke_zgetri_work.c - lapacke_zgetrs.c - lapacke_zgetrs_work.c - lapacke_zggbak.c - lapacke_zggbak_work.c - lapacke_zggbal.c - lapacke_zggbal_work.c - lapacke_zgges.c - lapacke_zgges_work.c - lapacke_zggesx.c - lapacke_zggesx_work.c - lapacke_zggev.c - lapacke_zggev_work.c - lapacke_zggevx.c - lapacke_zggevx_work.c - lapacke_zggglm.c - lapacke_zggglm_work.c - lapacke_zgghrd.c - lapacke_zgghrd_work.c - lapacke_zgglse.c - lapacke_zgglse_work.c - lapacke_zggqrf.c - lapacke_zggqrf_work.c - lapacke_zggrqf.c - lapacke_zggrqf_work.c - lapacke_zggsvd.c - lapacke_zggsvd_work.c - lapacke_zggsvp.c - lapacke_zggsvp_work.c - lapacke_zgtcon.c - lapacke_zgtcon_work.c - lapacke_zgtrfs.c - lapacke_zgtrfs_work.c - lapacke_zgtsv.c - lapacke_zgtsv_work.c - lapacke_zgtsvx.c - lapacke_zgtsvx_work.c - lapacke_zgttrf.c - lapacke_zgttrf_work.c - lapacke_zgttrs.c - lapacke_zgttrs_work.c - lapacke_zhbev.c - lapacke_zhbev_work.c - lapacke_zhbevd.c - lapacke_zhbevd_work.c - lapacke_zhbevx.c - lapacke_zhbevx_work.c - lapacke_zhbgst.c - lapacke_zhbgst_work.c - lapacke_zhbgv.c - lapacke_zhbgv_work.c - lapacke_zhbgvd.c - lapacke_zhbgvd_work.c - lapacke_zhbgvx.c - lapacke_zhbgvx_work.c - lapacke_zhbtrd.c - lapacke_zhbtrd_work.c - lapacke_zhecon.c - lapacke_zhecon_work.c - lapacke_zheequb.c - lapacke_zheequb_work.c - lapacke_zheev.c - lapacke_zheev_work.c - lapacke_zheevd.c - lapacke_zheevd_work.c - lapacke_zheevr.c - lapacke_zheevr_work.c - lapacke_zheevx.c - lapacke_zheevx_work.c - lapacke_zhegst.c - lapacke_zhegst_work.c - lapacke_zhegv.c - lapacke_zhegv_work.c - lapacke_zhegvd.c - lapacke_zhegvd_work.c - lapacke_zhegvx.c - lapacke_zhegvx_work.c - lapacke_zherfs.c - lapacke_zherfs_work.c - lapacke_zhesv.c - lapacke_zhesv_work.c - lapacke_zhesvx.c - lapacke_zhesvx_work.c - lapacke_zheswapr.c - lapacke_zheswapr_work.c - lapacke_zhetrd.c - lapacke_zhetrd_work.c - lapacke_zhetrf.c - lapacke_zhetrf_work.c - lapacke_zhetri.c - lapacke_zhetri2.c - lapacke_zhetri2_work.c - lapacke_zhetri2x.c - lapacke_zhetri2x_work.c - lapacke_zhetri_work.c - lapacke_zhetrs.c - lapacke_zhetrs2.c - lapacke_zhetrs2_work.c - lapacke_zhetrs_work.c - lapacke_zhfrk.c - lapacke_zhfrk_work.c - lapacke_zhgeqz.c - lapacke_zhgeqz_work.c - lapacke_zhpcon.c - lapacke_zhpcon_work.c - lapacke_zhpev.c - lapacke_zhpev_work.c - lapacke_zhpevd.c - lapacke_zhpevd_work.c - lapacke_zhpevx.c - lapacke_zhpevx_work.c - lapacke_zhpgst.c - lapacke_zhpgst_work.c - lapacke_zhpgv.c - lapacke_zhpgv_work.c - lapacke_zhpgvd.c - lapacke_zhpgvd_work.c - lapacke_zhpgvx.c - lapacke_zhpgvx_work.c - lapacke_zhprfs.c - lapacke_zhprfs_work.c - lapacke_zhpsv.c - lapacke_zhpsv_work.c - lapacke_zhpsvx.c - lapacke_zhpsvx_work.c - lapacke_zhptrd.c - lapacke_zhptrd_work.c - lapacke_zhptrf.c - lapacke_zhptrf_work.c - lapacke_zhptri.c - lapacke_zhptri_work.c - lapacke_zhptrs.c - lapacke_zhptrs_work.c - lapacke_zhsein.c - lapacke_zhsein_work.c - lapacke_zhseqr.c - lapacke_zhseqr_work.c - lapacke_zlacgv.c - lapacke_zlacgv_work.c - lapacke_zlacn2.c - lapacke_zlacn2_work.c - lapacke_zlacp2.c - lapacke_zlacp2_work.c - lapacke_zlacpy.c - lapacke_zlacpy_work.c - lapacke_zlag2c.c - lapacke_zlag2c_work.c - lapacke_zlange.c - lapacke_zlange_work.c - lapacke_zlanhe.c - lapacke_zlanhe_work.c - lapacke_zlansy.c - lapacke_zlansy_work.c - lapacke_zlantr.c - lapacke_zlantr_work.c - lapacke_zlapmr.c - lapacke_zlapmr_work.c - lapacke_zlarfb.c - lapacke_zlarfb_work.c - lapacke_zlarfg.c - lapacke_zlarfg_work.c - lapacke_zlarft.c - lapacke_zlarft_work.c - lapacke_zlarfx.c - lapacke_zlarfx_work.c - lapacke_zlarnv.c - lapacke_zlarnv_work.c - lapacke_zlaset.c - lapacke_zlaset_work.c - lapacke_zlaswp.c - lapacke_zlaswp_work.c - lapacke_zlauum.c - lapacke_zlauum_work.c - lapacke_zpbcon.c - lapacke_zpbcon_work.c - lapacke_zpbequ.c - lapacke_zpbequ_work.c - lapacke_zpbrfs.c - lapacke_zpbrfs_work.c - lapacke_zpbstf.c - lapacke_zpbstf_work.c - lapacke_zpbsv.c - lapacke_zpbsv_work.c - lapacke_zpbsvx.c - lapacke_zpbsvx_work.c - lapacke_zpbtrf.c - lapacke_zpbtrf_work.c - lapacke_zpbtrs.c - lapacke_zpbtrs_work.c - lapacke_zpftrf.c - lapacke_zpftrf_work.c - lapacke_zpftri.c - lapacke_zpftri_work.c - lapacke_zpftrs.c - lapacke_zpftrs_work.c - lapacke_zpocon.c - lapacke_zpocon_work.c - lapacke_zpoequ.c - lapacke_zpoequ_work.c - lapacke_zpoequb.c - lapacke_zpoequb_work.c - lapacke_zporfs.c - lapacke_zporfs_work.c - lapacke_zposv.c - lapacke_zposv_work.c - lapacke_zposvx.c - lapacke_zposvx_work.c - lapacke_zpotrf.c - lapacke_zpotrf_work.c - lapacke_zpotri.c - lapacke_zpotri_work.c - lapacke_zpotrs.c - lapacke_zpotrs_work.c - lapacke_zppcon.c - lapacke_zppcon_work.c - lapacke_zppequ.c - lapacke_zppequ_work.c - lapacke_zpprfs.c - lapacke_zpprfs_work.c - lapacke_zppsv.c - lapacke_zppsv_work.c - lapacke_zppsvx.c - lapacke_zppsvx_work.c - lapacke_zpptrf.c - lapacke_zpptrf_work.c - lapacke_zpptri.c - lapacke_zpptri_work.c - lapacke_zpptrs.c - lapacke_zpptrs_work.c - lapacke_zpstrf.c - lapacke_zpstrf_work.c - lapacke_zptcon.c - lapacke_zptcon_work.c - lapacke_zpteqr.c - lapacke_zpteqr_work.c - lapacke_zptrfs.c - lapacke_zptrfs_work.c - lapacke_zptsv.c - lapacke_zptsv_work.c - lapacke_zptsvx.c - lapacke_zptsvx_work.c - lapacke_zpttrf.c - lapacke_zpttrf_work.c - lapacke_zpttrs.c - lapacke_zpttrs_work.c - lapacke_zspcon.c - lapacke_zspcon_work.c - lapacke_zsprfs.c - lapacke_zsprfs_work.c - lapacke_zspsv.c - lapacke_zspsv_work.c - lapacke_zspsvx.c - lapacke_zspsvx_work.c - lapacke_zsptrf.c - lapacke_zsptrf_work.c - lapacke_zsptri.c - lapacke_zsptri_work.c - lapacke_zsptrs.c - lapacke_zsptrs_work.c - lapacke_zstedc.c - lapacke_zstedc_work.c - lapacke_zstegr.c - lapacke_zstegr_work.c - lapacke_zstein.c - lapacke_zstein_work.c - lapacke_zstemr.c - lapacke_zstemr_work.c - lapacke_zsteqr.c - lapacke_zsteqr_work.c - lapacke_zsycon.c - lapacke_zsycon_work.c - lapacke_zsyconv.c - lapacke_zsyconv_work.c - lapacke_zsyequb.c - lapacke_zsyequb_work.c - lapacke_zsyrfs.c - lapacke_zsyrfs_work.c - lapacke_zsysv.c - lapacke_zsysv_rook.c - lapacke_zsysv_rook_work.c - lapacke_zsysv_work.c - lapacke_zsysvx.c - lapacke_zsysvx_work.c - lapacke_zsyswapr.c - lapacke_zsyswapr_work.c - lapacke_zsytrf.c - lapacke_zsytrf_work.c - lapacke_zsytri.c - lapacke_zsytri2.c - lapacke_zsytri2_work.c - lapacke_zsytri2x.c - lapacke_zsytri2x_work.c - lapacke_zsytri_work.c - lapacke_zsytrs.c - lapacke_zsytrs2.c - lapacke_zsytrs2_work.c - lapacke_zsytrs_work.c - lapacke_ztbcon.c - lapacke_ztbcon_work.c - lapacke_ztbrfs.c - lapacke_ztbrfs_work.c - lapacke_ztbtrs.c - lapacke_ztbtrs_work.c - lapacke_ztfsm.c - lapacke_ztfsm_work.c - lapacke_ztftri.c - lapacke_ztftri_work.c - lapacke_ztfttp.c - lapacke_ztfttp_work.c - lapacke_ztfttr.c - lapacke_ztfttr_work.c - lapacke_ztgevc.c - lapacke_ztgevc_work.c - lapacke_ztgexc.c - lapacke_ztgexc_work.c - lapacke_ztgsen.c - lapacke_ztgsen_work.c - lapacke_ztgsja.c - lapacke_ztgsja_work.c - lapacke_ztgsna.c - lapacke_ztgsna_work.c - lapacke_ztgsyl.c - lapacke_ztgsyl_work.c - lapacke_ztpcon.c - lapacke_ztpcon_work.c - lapacke_ztpmqrt.c - lapacke_ztpmqrt_work.c - lapacke_ztpqrt.c - lapacke_ztpqrt2.c - lapacke_ztpqrt2_work.c - lapacke_ztpqrt_work.c - lapacke_ztprfb.c - lapacke_ztprfb_work.c - lapacke_ztprfs.c - lapacke_ztprfs_work.c - lapacke_ztptri.c - lapacke_ztptri_work.c - lapacke_ztptrs.c - lapacke_ztptrs_work.c - lapacke_ztpttf.c - lapacke_ztpttf_work.c - lapacke_ztpttr.c - lapacke_ztpttr_work.c - lapacke_ztrcon.c - lapacke_ztrcon_work.c - lapacke_ztrevc.c - lapacke_ztrevc_work.c - lapacke_ztrexc.c - lapacke_ztrexc_work.c - lapacke_ztrrfs.c - lapacke_ztrrfs_work.c - lapacke_ztrsen.c - lapacke_ztrsen_work.c - lapacke_ztrsna.c - lapacke_ztrsna_work.c - lapacke_ztrsyl.c - lapacke_ztrsyl_work.c - lapacke_ztrtri.c - lapacke_ztrtri_work.c - lapacke_ztrtrs.c - lapacke_ztrtrs_work.c - lapacke_ztrttf.c - lapacke_ztrttf_work.c - lapacke_ztrttp.c - lapacke_ztrttp_work.c - lapacke_ztzrzf.c - lapacke_ztzrzf_work.c - lapacke_zunbdb.c - lapacke_zunbdb_work.c - lapacke_zuncsd.c - lapacke_zuncsd_work.c - lapacke_zungbr.c - lapacke_zungbr_work.c - lapacke_zunghr.c - lapacke_zunghr_work.c - lapacke_zunglq.c - lapacke_zunglq_work.c - lapacke_zungql.c - lapacke_zungql_work.c - lapacke_zungqr.c - lapacke_zungqr_work.c - lapacke_zungrq.c - lapacke_zungrq_work.c - lapacke_zungtr.c - lapacke_zungtr_work.c - lapacke_zunmbr.c - lapacke_zunmbr_work.c - lapacke_zunmhr.c - lapacke_zunmhr_work.c - lapacke_zunmlq.c - lapacke_zunmlq_work.c - lapacke_zunmql.c - lapacke_zunmql_work.c - lapacke_zunmqr.c - lapacke_zunmqr_work.c - lapacke_zunmrq.c - lapacke_zunmrq_work.c - lapacke_zunmrz.c - lapacke_zunmrz_work.c - lapacke_zunmtr.c - lapacke_zunmtr_work.c - lapacke_zupgtr.c - lapacke_zupgtr_work.c - lapacke_zupmtr.c - lapacke_zupmtr_work.c - lapacke_zsyr.c - lapacke_csyr.c - lapacke_zsyr_work.c - lapacke_csyr_work.c + lapacke_zbbcsd.c + lapacke_zbbcsd_work.c + lapacke_zbdsqr.c + lapacke_zbdsqr_work.c + lapacke_zcgesv.c + lapacke_zcgesv_work.c + lapacke_zcposv.c + lapacke_zcposv_work.c + lapacke_zgbbrd.c + lapacke_zgbbrd_work.c + lapacke_zgbcon.c + lapacke_zgbcon_work.c + lapacke_zgbequ.c + lapacke_zgbequ_work.c + lapacke_zgbequb.c + lapacke_zgbequb_work.c + lapacke_zgbrfs.c + lapacke_zgbrfs_work.c + lapacke_zgbsv.c + lapacke_zgbsv_work.c + lapacke_zgbsvx.c + lapacke_zgbsvx_work.c + lapacke_zgbtrf.c + lapacke_zgbtrf_work.c + lapacke_zgbtrs.c + lapacke_zgbtrs_work.c + lapacke_zgebak.c + lapacke_zgebak_work.c + lapacke_zgebal.c + lapacke_zgebal_work.c + lapacke_zgebrd.c + lapacke_zgebrd_work.c + lapacke_zgecon.c + lapacke_zgecon_work.c + lapacke_zgeequ.c + lapacke_zgeequ_work.c + lapacke_zgeequb.c + lapacke_zgeequb_work.c + lapacke_zgees.c + lapacke_zgees_work.c + lapacke_zgeesx.c + lapacke_zgeesx_work.c + lapacke_zgeev.c + lapacke_zgeev_work.c + lapacke_zgeevx.c + lapacke_zgeevx_work.c + lapacke_zgehrd.c + lapacke_zgehrd_work.c + lapacke_zgejsv.c + lapacke_zgejsv_work.c + lapacke_zgelq2.c + lapacke_zgelq2_work.c + lapacke_zgelqf.c + lapacke_zgelqf_work.c + lapacke_zgels.c + lapacke_zgels_work.c + lapacke_zgelsd.c + lapacke_zgelsd_work.c + lapacke_zgelss.c + lapacke_zgelss_work.c + lapacke_zgelsy.c + lapacke_zgelsy_work.c + lapacke_zgemqr.c + lapacke_zgemqr_work.c + lapacke_zgemqrt.c + lapacke_zgemqrt_work.c + lapacke_zgeqlf.c + lapacke_zgeqlf_work.c + lapacke_zgeqp3.c + lapacke_zgeqp3_work.c + lapacke_zgeqr2.c + lapacke_zgeqr2_work.c + lapacke_zgeqrf.c + lapacke_zgeqrf_work.c + lapacke_zgeqrfp.c + lapacke_zgeqrfp_work.c + lapacke_zgeqrt.c + lapacke_zgeqrt2.c + lapacke_zgeqrt2_work.c + lapacke_zgeqrt3.c + lapacke_zgeqrt3_work.c + lapacke_zgeqrt_work.c + lapacke_zgerfs.c + lapacke_zgerfs_work.c + lapacke_zgerqf.c + lapacke_zgerqf_work.c + lapacke_zgesdd.c + lapacke_zgesdd_work.c + lapacke_zgesv.c + lapacke_zgesv_work.c + lapacke_zgesvd.c + lapacke_zgesvd_work.c + lapacke_zgesvdx.c + lapacke_zgesvdx_work.c + lapacke_zgesvj.c + lapacke_zgesvj_work.c + lapacke_zgesvx.c + lapacke_zgesvx_work.c + lapacke_zgetf2.c + lapacke_zgetf2_work.c + lapacke_zgetrf.c + lapacke_zgetrf_work.c + lapacke_zgetrf2.c + lapacke_zgetrf2_work.c + lapacke_zgetri.c + lapacke_zgetri_work.c + lapacke_zgetrs.c + lapacke_zgetrs_work.c + lapacke_zgetsls.c + lapacke_zgetsls_work.c + lapacke_zggbak.c + lapacke_zggbak_work.c + lapacke_zggbal.c + lapacke_zggbal_work.c + lapacke_zgges.c + lapacke_zgges_work.c + lapacke_zgges3.c + lapacke_zgges3_work.c + lapacke_zggesx.c + lapacke_zggesx_work.c + lapacke_zggev.c + lapacke_zggev_work.c + lapacke_zggev3.c + lapacke_zggev3_work.c + lapacke_zggevx.c + lapacke_zggevx_work.c + lapacke_zggglm.c + lapacke_zggglm_work.c + lapacke_zgghrd.c + lapacke_zgghrd_work.c + lapacke_zgghd3.c + lapacke_zgghd3_work.c + lapacke_zgglse.c + lapacke_zgglse_work.c + lapacke_zggqrf.c + lapacke_zggqrf_work.c + lapacke_zggrqf.c + lapacke_zggrqf_work.c + lapacke_zggsvd3.c + lapacke_zggsvd3_work.c + lapacke_zggsvp3.c + lapacke_zggsvp3_work.c + lapacke_zgtcon.c + lapacke_zgtcon_work.c + lapacke_zgtrfs.c + lapacke_zgtrfs_work.c + lapacke_zgtsv.c + lapacke_zgtsv_work.c + lapacke_zgtsvx.c + lapacke_zgtsvx_work.c + lapacke_zgttrf.c + lapacke_zgttrf_work.c + lapacke_zgttrs.c + lapacke_zgttrs_work.c + lapacke_zhbev.c + lapacke_zhbev_work.c + lapacke_zhbevd.c + lapacke_zhbevd_work.c + lapacke_zhbevx.c + lapacke_zhbevx_work.c + lapacke_zhbgst.c + lapacke_zhbgst_work.c + lapacke_zhbgv.c + lapacke_zhbgv_work.c + lapacke_zhbgvd.c + lapacke_zhbgvd_work.c + lapacke_zhbgvx.c + lapacke_zhbgvx_work.c + lapacke_zhbtrd.c + lapacke_zhbtrd_work.c + lapacke_zhecon.c + lapacke_zhecon_work.c + lapacke_zhecon_3.c + lapacke_zhecon_3_work.c + lapacke_zheequb.c + lapacke_zheequb_work.c + lapacke_zheev.c + lapacke_zheev_work.c + lapacke_zheevd.c + lapacke_zheevd_work.c + lapacke_zheevr.c + lapacke_zheevr_work.c + lapacke_zheevx.c + lapacke_zheevx_work.c + lapacke_zheev_2stage.c + lapacke_zheev_2stage_work.c + lapacke_zheevd_2stage.c + lapacke_zheevd_2stage_work.c + lapacke_zheevr_2stage.c + lapacke_zheevr_2stage_work.c + lapacke_zheevx_2stage.c + lapacke_zheevx_2stage_work.c + lapacke_zhegst.c + lapacke_zhegst_work.c + lapacke_zhegv.c + lapacke_zhegv_work.c + lapacke_zhegv_2stage.c + lapacke_zhegv_2stage_work.c + lapacke_zhegvd.c + lapacke_zhegvd_work.c + lapacke_zhegvx.c + lapacke_zhegvx_work.c + lapacke_zherfs.c + lapacke_zherfs_work.c + lapacke_zhesv.c + lapacke_zhesv_work.c + lapacke_zhesv_aa.c + lapacke_zhesv_aa_work.c + lapacke_zhesv_rk.c + lapacke_zhesv_rk_work.c + lapacke_zhesvx.c + lapacke_zhesvx_work.c + lapacke_zheswapr.c + lapacke_zheswapr_work.c + lapacke_zhetrd.c + lapacke_zhetrd_work.c + lapacke_zhetrf.c + lapacke_zhetrf_rook.c + lapacke_zhetrf_work.c + lapacke_zhetrf_rook_work.c + lapacke_zhetrf_aa.c + lapacke_zhetrf_aa_work.c + lapacke_zhetrf_rk.c + lapacke_zhetrf_rk_work.c + lapacke_zhetri.c + lapacke_zhetri2.c + lapacke_zhetri2_work.c + lapacke_zhetri_3.c + lapacke_zhetri_3_work.c + lapacke_zhetri2x.c + lapacke_zhetri2x_work.c + lapacke_zhetri_work.c + lapacke_zhetrs.c + lapacke_zhetrs_rook.c + lapacke_zhetrs2.c + lapacke_zhetrs2_work.c + lapacke_zhetrs_work.c + lapacke_zhetrs_aa.c + lapacke_zhetrs_aa_work.c + lapacke_zhetrs_3.c + lapacke_zhetrs_3_work.c + lapacke_zhetrs_rook_work.c + lapacke_zhfrk.c + lapacke_zhfrk_work.c + lapacke_zhgeqz.c + lapacke_zhgeqz_work.c + lapacke_zhpcon.c + lapacke_zhpcon_work.c + lapacke_zhpev.c + lapacke_zhpev_work.c + lapacke_zhpevd.c + lapacke_zhpevd_work.c + lapacke_zhpevx.c + lapacke_zhpevx_work.c + lapacke_zhpgst.c + lapacke_zhpgst_work.c + lapacke_zhpgv.c + lapacke_zhpgv_work.c + lapacke_zhpgvd.c + lapacke_zhpgvd_work.c + lapacke_zhpgvx.c + lapacke_zhpgvx_work.c + lapacke_zhprfs.c + lapacke_zhprfs_work.c + lapacke_zhpsv.c + lapacke_zhpsv_work.c + lapacke_zhpsvx.c + lapacke_zhpsvx_work.c + lapacke_zhptrd.c + lapacke_zhptrd_work.c + lapacke_zhptrf.c + lapacke_zhptrf_work.c + lapacke_zhptri.c + lapacke_zhptri_work.c + lapacke_zhptrs.c + lapacke_zhptrs_work.c + lapacke_zhsein.c + lapacke_zhsein_work.c + lapacke_zhseqr.c + lapacke_zhseqr_work.c + lapacke_zlacgv.c + lapacke_zlacgv_work.c + lapacke_zlacn2.c + lapacke_zlacn2_work.c + lapacke_zlacp2.c + lapacke_zlacp2_work.c + lapacke_zlacpy.c + lapacke_zlacpy_work.c + lapacke_zlag2c.c + lapacke_zlag2c_work.c + lapacke_zlange.c + lapacke_zlange_work.c + lapacke_zlanhe.c + lapacke_zlanhe_work.c + lapacke_zlansy.c + lapacke_zlansy_work.c + lapacke_zlantr.c + lapacke_zlantr_work.c + lapacke_zlapmr.c + lapacke_zlapmr_work.c + lapacke_zlapmt.c + lapacke_zlapmt_work.c + lapacke_zlarfb.c + lapacke_zlarfb_work.c + lapacke_zlarfg.c + lapacke_zlarfg_work.c + lapacke_zlarft.c + lapacke_zlarft_work.c + lapacke_zlarfx.c + lapacke_zlarfx_work.c + lapacke_zlarnv.c + lapacke_zlarnv_work.c + lapacke_zlascl.c + lapacke_zlascl_work.c + lapacke_zlaset.c + lapacke_zlaset_work.c + lapacke_zlaswp.c + lapacke_zlaswp_work.c + lapacke_zlauum.c + lapacke_zlauum_work.c + lapacke_zpbcon.c + lapacke_zpbcon_work.c + lapacke_zpbequ.c + lapacke_zpbequ_work.c + lapacke_zpbrfs.c + lapacke_zpbrfs_work.c + lapacke_zpbstf.c + lapacke_zpbstf_work.c + lapacke_zpbsv.c + lapacke_zpbsv_work.c + lapacke_zpbsvx.c + lapacke_zpbsvx_work.c + lapacke_zpbtrf.c + lapacke_zpbtrf_work.c + lapacke_zpbtrs.c + lapacke_zpbtrs_work.c + lapacke_zpftrf.c + lapacke_zpftrf_work.c + lapacke_zpftri.c + lapacke_zpftri_work.c + lapacke_zpftrs.c + lapacke_zpftrs_work.c + lapacke_zpocon.c + lapacke_zpocon_work.c + lapacke_zpoequ.c + lapacke_zpoequ_work.c + lapacke_zpoequb.c + lapacke_zpoequb_work.c + lapacke_zporfs.c + lapacke_zporfs_work.c + lapacke_zposv.c + lapacke_zposv_work.c + lapacke_zposvx.c + lapacke_zposvx_work.c + lapacke_zpotrf.c + lapacke_zpotrf_work.c + lapacke_zpotrf2.c + lapacke_zpotrf2_work.c + lapacke_zpotri.c + lapacke_zpotri_work.c + lapacke_zpotrs.c + lapacke_zpotrs_work.c + lapacke_zppcon.c + lapacke_zppcon_work.c + lapacke_zppequ.c + lapacke_zppequ_work.c + lapacke_zpprfs.c + lapacke_zpprfs_work.c + lapacke_zppsv.c + lapacke_zppsv_work.c + lapacke_zppsvx.c + lapacke_zppsvx_work.c + lapacke_zpptrf.c + lapacke_zpptrf_work.c + lapacke_zpptri.c + lapacke_zpptri_work.c + lapacke_zpptrs.c + lapacke_zpptrs_work.c + lapacke_zpstrf.c + lapacke_zpstrf_work.c + lapacke_zptcon.c + lapacke_zptcon_work.c + lapacke_zpteqr.c + lapacke_zpteqr_work.c + lapacke_zptrfs.c + lapacke_zptrfs_work.c + lapacke_zptsv.c + lapacke_zptsv_work.c + lapacke_zptsvx.c + lapacke_zptsvx_work.c + lapacke_zpttrf.c + lapacke_zpttrf_work.c + lapacke_zpttrs.c + lapacke_zpttrs_work.c + lapacke_zspcon.c + lapacke_zspcon_work.c + lapacke_zsprfs.c + lapacke_zsprfs_work.c + lapacke_zspsv.c + lapacke_zspsv_work.c + lapacke_zspsvx.c + lapacke_zspsvx_work.c + lapacke_zsptrf.c + lapacke_zsptrf_work.c + lapacke_zsptri.c + lapacke_zsptri_work.c + lapacke_zsptrs.c + lapacke_zsptrs_work.c + lapacke_zstedc.c + lapacke_zstedc_work.c + lapacke_zstegr.c + lapacke_zstegr_work.c + lapacke_zstein.c + lapacke_zstein_work.c + lapacke_zstemr.c + lapacke_zstemr_work.c + lapacke_zsteqr.c + lapacke_zsteqr_work.c + lapacke_zsycon.c + lapacke_zsycon_work.c + lapacke_zsycon_3.c + lapacke_zsycon_3_work.c + lapacke_zsyconv.c + lapacke_zsyconv_work.c + lapacke_zsyequb.c + lapacke_zsyequb_work.c + lapacke_zsyrfs.c + lapacke_zsyrfs_work.c + lapacke_zsysv.c + lapacke_zsysv_rook.c + lapacke_zsysv_rook_work.c + lapacke_zsysv_work.c + lapacke_zsysv_aa.c + lapacke_zsysv_aa_work.c + lapacke_zsysv_rk.c + lapacke_zsysv_rk_work.c + lapacke_zsysvx.c + lapacke_zsysvx_work.c + lapacke_zsyswapr.c + lapacke_zsyswapr_work.c + lapacke_zsytrf.c + lapacke_zsytrf_work.c + lapacke_zsytrf_rook.c + lapacke_zsytrf_rook_work.c + lapacke_zsytrf_aa.c + lapacke_zsytrf_aa_work.c + lapacke_zsytrf_rk.c + lapacke_zsytrf_rk_work.c + lapacke_zsytri.c + lapacke_zsytri2.c + lapacke_zsytri2_work.c + lapacke_zsytri_3.c + lapacke_zsytri_3_work.c + lapacke_zsytri2x.c + lapacke_zsytri2x_work.c + lapacke_zsytri_work.c + lapacke_zsytrs.c + lapacke_zsytrs_rook.c + lapacke_zsytrs2.c + lapacke_zsytrs2_work.c + lapacke_zsytrs_work.c + lapacke_zsytrs_rook_work.c + lapacke_zsytrs_aa.c + lapacke_zsytrs_aa_work.c + lapacke_zsytrs_3.c + lapacke_zsytrs_3_work.c + lapacke_ztbcon.c + lapacke_ztbcon_work.c + lapacke_ztbrfs.c + lapacke_ztbrfs_work.c + lapacke_ztbtrs.c + lapacke_ztbtrs_work.c + lapacke_ztfsm.c + lapacke_ztfsm_work.c + lapacke_ztftri.c + lapacke_ztftri_work.c + lapacke_ztfttp.c + lapacke_ztfttp_work.c + lapacke_ztfttr.c + lapacke_ztfttr_work.c + lapacke_ztgevc.c + lapacke_ztgevc_work.c + lapacke_ztgexc.c + lapacke_ztgexc_work.c + lapacke_ztgsen.c + lapacke_ztgsen_work.c + lapacke_ztgsja.c + lapacke_ztgsja_work.c + lapacke_ztgsna.c + lapacke_ztgsna_work.c + lapacke_ztgsyl.c + lapacke_ztgsyl_work.c + lapacke_ztpcon.c + lapacke_ztpcon_work.c + lapacke_ztpmqrt.c + lapacke_ztpmqrt_work.c + lapacke_ztpqrt.c + lapacke_ztpqrt2.c + lapacke_ztpqrt2_work.c + lapacke_ztpqrt_work.c + lapacke_ztprfb.c + lapacke_ztprfb_work.c + lapacke_ztprfs.c + lapacke_ztprfs_work.c + lapacke_ztptri.c + lapacke_ztptri_work.c + lapacke_ztptrs.c + lapacke_ztptrs_work.c + lapacke_ztpttf.c + lapacke_ztpttf_work.c + lapacke_ztpttr.c + lapacke_ztpttr_work.c + lapacke_ztrcon.c + lapacke_ztrcon_work.c + lapacke_ztrevc.c + lapacke_ztrevc_work.c + lapacke_ztrexc.c + lapacke_ztrexc_work.c + lapacke_ztrrfs.c + lapacke_ztrrfs_work.c + lapacke_ztrsen.c + lapacke_ztrsen_work.c + lapacke_ztrsna.c + lapacke_ztrsna_work.c + lapacke_ztrsyl.c + lapacke_ztrsyl_work.c + lapacke_ztrtri.c + lapacke_ztrtri_work.c + lapacke_ztrtrs.c + lapacke_ztrtrs_work.c + lapacke_ztrttf.c + lapacke_ztrttf_work.c + lapacke_ztrttp.c + lapacke_ztrttp_work.c + lapacke_ztzrzf.c + lapacke_ztzrzf_work.c + lapacke_zunbdb.c + lapacke_zunbdb_work.c + lapacke_zuncsd.c + lapacke_zuncsd_work.c + lapacke_zuncsd2by1.c + lapacke_zuncsd2by1_work.c + lapacke_zungbr.c + lapacke_zungbr_work.c + lapacke_zunghr.c + lapacke_zunghr_work.c + lapacke_zunglq.c + lapacke_zunglq_work.c + lapacke_zungql.c + lapacke_zungql_work.c + lapacke_zungqr.c + lapacke_zungqr_work.c + lapacke_zungrq.c + lapacke_zungrq_work.c + lapacke_zungtr.c + lapacke_zungtr_work.c + lapacke_zunmbr.c + lapacke_zunmbr_work.c + lapacke_zunmhr.c + lapacke_zunmhr_work.c + lapacke_zunmlq.c + lapacke_zunmlq_work.c + lapacke_zunmql.c + lapacke_zunmql_work.c + lapacke_zunmqr.c + lapacke_zunmqr_work.c + lapacke_zunmrq.c + lapacke_zunmrq_work.c + lapacke_zunmrz.c + lapacke_zunmrz_work.c + lapacke_zunmtr.c + lapacke_zunmtr_work.c + lapacke_zupgtr.c + lapacke_zupgtr_work.c + lapacke_zupmtr.c + lapacke_zupmtr_work.c + lapacke_zsyr.c + lapacke_csyr.c + lapacke_zsyr_work.c + lapacke_csyr_work.c lapacke_ilaver.c ) @@ -2119,6 +2391,6 @@ foreach (Utils_FILE ${Utils_SRC}) endforeach () set(lapacke_include_dir "${NETLIB_LAPACK_DIR}/LAPACKE/include") -execute_process(COMMAND ${CMAKE_COMMAND} -E copy "${lapacke_include_dir}/lapacke_mangling_with_flags.h" "${lapacke_include_dir}/lapacke_mangling.h") +execute_process(COMMAND ${CMAKE_COMMAND} -E copy "${lapacke_include_dir}/lapacke_mangling_with_flags.h.in" "${lapacke_include_dir}/lapacke_mangling.h") include_directories(${lapacke_include_dir}) set_source_files_properties(${LAPACKE_SOURCES} PROPERTIES COMPILE_FLAGS "${LAPACK_CFLAGS}") diff --git a/cmake/openblas.pc.in b/cmake/openblas.pc.in new file mode 100644 index 0000000000..113ba85262 --- /dev/null +++ b/cmake/openblas.pc.in @@ -0,0 +1,9 @@ +libdir=@CMAKE_INSTALL_FULL_LIBDIR@ +includedir=@CMAKE_INSTALL_FULL_INCLUDEDIR@ + +Name: OpenBLAS +Description: OpenBLAS is an optimized BLAS library based on GotoBLAS2 1.13 BSD version +Version: @OPENBLAS_VERSION@ +URL: https://github.com/xianyi/OpenBLAS +Libs: -L${libdir} -lopenblas +Cflags: -I${includedir} diff --git a/cmake/os.cmake b/cmake/os.cmake index f5a75027c9..e9df68d7fd 100644 --- a/cmake/os.cmake +++ b/cmake/os.cmake @@ -77,7 +77,7 @@ if (CYGWIN) set(NO_EXPRECISION 1) endif () -if (NOT ${CMAKE_SYSTEM_NAME} STREQUAL "Windows" AND NOT ${CMAKE_SYSTEM_NAME} STREQUAL "Interix") +if (NOT ${CMAKE_SYSTEM_NAME} STREQUAL "Windows" AND NOT ${CMAKE_SYSTEM_NAME} STREQUAL "Interix" AND NOT ${CMAKE_SYSTEM_NAME} STREQUAL "Android") if (SMP) set(EXTRALIB "${EXTRALIB} -lpthread") endif () diff --git a/cmake/prebuild.cmake b/cmake/prebuild.cmake index 471ce90e47..a7f98bfb89 100644 --- a/cmake/prebuild.cmake +++ b/cmake/prebuild.cmake @@ -4,7 +4,8 @@ ## This is triggered by system.cmake and runs before any of the code is built. ## Creates config.h and Makefile.conf by first running the c_check perl script (which creates those files). ## Next it runs f_check and appends some fortran information to the files. -## Finally it runs getarch and getarch_2nd for even more environment information. +## Then it runs getarch and getarch_2nd for even more environment information. +## Finally it builds gen_config_h for use at build time to generate config.h. # CMake vars set by this file: # CORE @@ -71,16 +72,26 @@ if (MSVC) set(GETARCH_FLAGS ${GETARCH_FLAGS} -DFORCE_GENERIC) endif() +if ("${CMAKE_SYSTEM_NAME}" STREQUAL "WindowsStore") + # disable WindowsStore strict CRT checks + set(GETARCH_FLAGS ${GETARCH_FLAGS} -D_CRT_SECURE_NO_WARNINGS) +endif () + set(GETARCH_DIR "${PROJECT_BINARY_DIR}/getarch_build") set(GETARCH_BIN "getarch${CMAKE_EXECUTABLE_SUFFIX}") file(MAKE_DIRECTORY ${GETARCH_DIR}) -try_compile(GETARCH_RESULT ${GETARCH_DIR} - SOURCES ${GETARCH_SRC} - COMPILE_DEFINITIONS ${EXFLAGS} ${GETARCH_FLAGS} -I${PROJECT_SOURCE_DIR} - OUTPUT_VARIABLE GETARCH_LOG - COPY_FILE ${PROJECT_BINARY_DIR}/${GETARCH_BIN} -) - +if (NOT "${CMAKE_SYSTEM_NAME}" STREQUAL "WindowsStore") + try_compile(GETARCH_RESULT ${GETARCH_DIR} + SOURCES ${GETARCH_SRC} + COMPILE_DEFINITIONS ${EXFLAGS} ${GETARCH_FLAGS} -I${PROJECT_SOURCE_DIR} + OUTPUT_VARIABLE GETARCH_LOG + COPY_FILE ${PROJECT_BINARY_DIR}/${GETARCH_BIN} + ) + + if (NOT ${GETARCH_RESULT}) + MESSAGE(FATAL_ERROR "Compiling getarch failed ${GETARCH_LOG}") + endif () +endif () message(STATUS "Running getarch") # use the cmake binary w/ the -E param to run a shell command in a cross-platform way @@ -96,12 +107,18 @@ ParseGetArchVars(${GETARCH_MAKE_OUT}) set(GETARCH2_DIR "${PROJECT_BINARY_DIR}/getarch2_build") set(GETARCH2_BIN "getarch_2nd${CMAKE_EXECUTABLE_SUFFIX}") file(MAKE_DIRECTORY ${GETARCH2_DIR}) -try_compile(GETARCH2_RESULT ${GETARCH2_DIR} - SOURCES ${PROJECT_SOURCE_DIR}/getarch_2nd.c - COMPILE_DEFINITIONS ${EXFLAGS} ${GETARCH_FLAGS} ${GETARCH2_FLAGS} -I${PROJECT_SOURCE_DIR} - OUTPUT_VARIABLE GETARCH2_LOG - COPY_FILE ${PROJECT_BINARY_DIR}/${GETARCH2_BIN} -) +if (NOT "${CMAKE_SYSTEM_NAME}" STREQUAL "WindowsStore") + try_compile(GETARCH2_RESULT ${GETARCH2_DIR} + SOURCES ${PROJECT_SOURCE_DIR}/getarch_2nd.c + COMPILE_DEFINITIONS ${EXFLAGS} ${GETARCH_FLAGS} ${GETARCH2_FLAGS} -I${PROJECT_SOURCE_DIR} + OUTPUT_VARIABLE GETARCH2_LOG + COPY_FILE ${PROJECT_BINARY_DIR}/${GETARCH2_BIN} + ) + + if (NOT ${GETARCH2_RESULT}) + MESSAGE(FATAL_ERROR "Compiling getarch_2nd failed ${GETARCH2_LOG}") + endif () +endif () # use the cmake binary w/ the -E param to run a shell command in a cross-platform way execute_process(COMMAND ${PROJECT_BINARY_DIR}/${GETARCH2_BIN} 0 OUTPUT_VARIABLE GETARCH2_MAKE_OUT) @@ -111,3 +128,21 @@ execute_process(COMMAND ${PROJECT_BINARY_DIR}/${GETARCH2_BIN} 1 OUTPUT_VARIABLE file(APPEND ${TARGET_CONF} ${GETARCH2_CONF_OUT}) ParseGetArchVars(${GETARCH2_MAKE_OUT}) +# compile get_config_h +set(GEN_CONFIG_H_DIR "${PROJECT_BINARY_DIR}/genconfig_h_build") +set(GEN_CONFIG_H_BIN "gen_config_h${CMAKE_EXECUTABLE_SUFFIX}") +set(GEN_CONFIG_H_FLAGS "-DVERSION=\"${OpenBLAS_VERSION}\"") +file(MAKE_DIRECTORY ${GEN_CONFIG_H_DIR}) + +if (NOT "${CMAKE_SYSTEM_NAME}" STREQUAL "WindowsStore") + try_compile(GEN_CONFIG_H_RESULT ${GEN_CONFIG_H_DIR} + SOURCES ${PROJECT_SOURCE_DIR}/gen_config_h.c + COMPILE_DEFINITIONS ${EXFLAGS} ${GETARCH_FLAGS} ${GEN_CONFIG_H_FLAGS} -I${PROJECT_SOURCE_DIR} + OUTPUT_VARIABLE GEN_CONFIG_H_LOG + COPY_FILE ${PROJECT_BINARY_DIR}/${GEN_CONFIG_H_BIN} + ) + + if (NOT ${GEN_CONFIG_H_RESULT}) + MESSAGE(FATAL_ERROR "Compiling gen_config_h failed ${GEN_CONFIG_H_LOG}") + endif () +endif () \ No newline at end of file diff --git a/cmake/system.cmake b/cmake/system.cmake index aa046a56aa..75c8e9c556 100644 --- a/cmake/system.cmake +++ b/cmake/system.cmake @@ -22,7 +22,7 @@ if (DEFINED BINARY AND DEFINED TARGET AND BINARY EQUAL 32) if (${TARGET} STREQUAL "HASWELL" OR ${TARGET} STREQUAL "SANDYBRIDGE") set(TARGET "NEHALEM") endif () - if (${TARGET} STREQUAL "BULLDOZER" OR ${TARGET} STREQUAL "PILEDRIVER") + if (${TARGET} STREQUAL "BULLDOZER" OR ${TARGET} STREQUAL "PILEDRIVER" OR ${TARGET} STREQUAL "ZEN") set(TARGET "BARCELONA") endif () endif () @@ -312,6 +312,8 @@ endif () set(AWK awk) +set(SED sed) + set(REVISION "-r${OpenBLAS_VERSION}") set(MAJOR_VERSION ${OpenBLAS_MAJOR_VERSION}) diff --git a/common.h b/common.h index 480174c11a..4463141c8c 100644 --- a/common.h +++ b/common.h @@ -420,7 +420,15 @@ please https://github.com/xianyi/OpenBLAS/issues/246 #include "common_arm64.h" #endif +#ifdef ARCH_ZARCH +#include "common_zarch.h" +#endif + #ifndef ASSEMBLER +#ifdef OS_WINDOWSSTORE +typedef char env_var_t[MAX_PATH]; +#define readenv(p, n) 0 +#else #ifdef OS_WINDOWS typedef char env_var_t[MAX_PATH]; #define readenv(p, n) GetEnvironmentVariable((LPCTSTR)(n), (LPTSTR)(p), sizeof(p)) @@ -428,6 +436,7 @@ typedef char env_var_t[MAX_PATH]; typedef char* env_var_t; #define readenv(p, n) ((p)=getenv(n)) #endif +#endif #if !defined(RPCC_DEFINED) && !defined(OS_WINDOWS) #ifdef _POSIX_MONOTONIC_CLOCK @@ -552,8 +561,13 @@ static void __inline blas_lock(volatile BLASULONG *address){ #endif #if defined(C_PGI) || defined(C_SUN) -#define CREAL(X) (*((FLOAT *)&X + 0)) -#define CIMAG(X) (*((FLOAT *)&X + 1)) + #if defined(__STDC_IEC_559_COMPLEX__) + #define CREAL(X) creal(X) + #define CIMAG(X) cimag(X) + #else + #define CREAL(X) (*((FLOAT *)&X + 0)) + #define CIMAG(X) (*((FLOAT *)&X + 1)) + #endif #else #ifdef OPENBLAS_COMPLEX_STRUCT #define CREAL(Z) ((Z).real) @@ -645,7 +659,11 @@ static __inline void blas_unlock(volatile BLASULONG *address){ *address = 0; } - +#ifdef OS_WINDOWSSTORE +static __inline int readenv_atoi(char *env) { + return 0; +} +#else #ifdef OS_WINDOWS static __inline int readenv_atoi(char *env) { env_var_t p; @@ -660,7 +678,7 @@ static __inline int readenv_atoi(char *env) { return(0); } #endif - +#endif #if !defined(XDOUBLE) || !defined(QUAD_PRECISION) diff --git a/common_arm.h b/common_arm.h index 6bf836835f..27fa76b765 100644 --- a/common_arm.h +++ b/common_arm.h @@ -105,7 +105,6 @@ static inline int blas_quickdivide(blasint x, blasint y){ #define PROLOGUE \ .arm ;\ .global REALNAME ;\ - .func REALNAME ;\ REALNAME: #define EPILOGUE diff --git a/common_arm64.h b/common_arm64.h index d9d5d215ce..c6ef2fb5dd 100644 --- a/common_arm64.h +++ b/common_arm64.h @@ -39,7 +39,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define INLINE inline +#ifdef F_INTERFACE_FLANG +#define RETURN_BY_STACK +#else #define RETURN_BY_COMPLEX +#endif #ifndef ASSEMBLER diff --git a/common_linux.h b/common_linux.h index cab5e5f7b3..35f3fb6586 100644 --- a/common_linux.h +++ b/common_linux.h @@ -70,7 +70,7 @@ extern long int syscall (long int __sysno, ...); static inline int my_mbind(void *addr, unsigned long len, int mode, unsigned long *nodemask, unsigned long maxnode, unsigned flags) { -#if defined (__LSB_VERSION__) +#if defined (__LSB_VERSION__) || defined(ARCH_ZARCH) // So far, LSB (Linux Standard Base) don't support syscall(). // https://lsbbugs.linuxfoundation.org/show_bug.cgi?id=3482 return 0; @@ -90,7 +90,7 @@ static inline int my_mbind(void *addr, unsigned long len, int mode, } static inline int my_set_mempolicy(int mode, const unsigned long *addr, unsigned long flag) { -#if defined (__LSB_VERSION__) +#if defined (__LSB_VERSION__) || defined(ARCH_ZARCH) // So far, LSB (Linux Standard Base) don't support syscall(). // https://lsbbugs.linuxfoundation.org/show_bug.cgi?id=3482 return 0; diff --git a/common_macro.h b/common_macro.h index 4976e766ff..15ba6f9db9 100644 --- a/common_macro.h +++ b/common_macro.h @@ -2193,7 +2193,7 @@ #endif #ifndef ASSEMBLER -#if defined(ARCH_X86) || defined(ARCH_X86_64) || defined(ARCH_IA64) || defined(ARCH_MIPS64) +#if defined(ARCH_X86) || defined(ARCH_X86_64) || defined(ARCH_IA64) || defined(ARCH_MIPS64) || defined(ARCH_ARM64) extern BLASLONG gemm_offset_a; extern BLASLONG gemm_offset_b; extern BLASLONG sgemm_p; diff --git a/common_mips.h b/common_mips.h index ae126949a2..35bff5083a 100644 --- a/common_mips.h +++ b/common_mips.h @@ -33,8 +33,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef COMMON_MIPS #define COMMON_MIPS -#define MB -#define WMB +#define MB __sync_synchronize() +#define WMB __sync_synchronize() #define INLINE inline @@ -42,11 +42,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef ASSEMBLER -static void INLINE blas_lock(volatile unsigned long *address){ - -} -#define BLAS_LOCK_DEFINED - static inline unsigned int rpcc(void){ unsigned long ret; @@ -80,7 +75,6 @@ static inline int blas_quickdivide(blasint x, blasint y){ #define PROLOGUE \ .arm ;\ .global REALNAME ;\ - .func REALNAME ;\ REALNAME: #define EPILOGUE diff --git a/common_mips64.h b/common_mips64.h index 6078bf35b6..93bc7e519f 100644 --- a/common_mips64.h +++ b/common_mips64.h @@ -71,35 +71,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef COMMON_MIPS64 #define COMMON_MIPS64 -#define MB -#define WMB +#define MB __sync_synchronize() +#define WMB __sync_synchronize() #define INLINE inline #ifndef ASSEMBLER -static void INLINE blas_lock(volatile unsigned long *address){ - - long int ret, val = 1; - - do { - while (*address) {YIELDING;}; - - __asm__ __volatile__( - "1: ll %0, %3\n" - " ori %2, %0, 1\n" - " sc %2, %1\n" - " beqz %2, 1b\n" - " andi %2, %0, 1\n" - " sync\n" - : "=&r" (val), "=m" (address), "=&r" (ret) - : "m" (address) - : "memory"); - - } while (ret); -} -#define BLAS_LOCK_DEFINED - static inline unsigned int rpcc(void){ unsigned long ret; diff --git a/common_x86_64.h b/common_x86_64.h index 11937b4159..bee88d3ce0 100644 --- a/common_x86_64.h +++ b/common_x86_64.h @@ -245,6 +245,10 @@ static __inline int blas_quickdivide(unsigned int x, unsigned int y){ #define RETURN_BY_STACK #endif +#ifdef F_INTERFACE_FLANG +#define RETURN_BY_STACK +#endif + #ifdef F_INTERFACE_PGI #define RETURN_BY_STACK #endif diff --git a/common_zarch.h b/common_zarch.h new file mode 100644 index 0000000000..e105574e07 --- /dev/null +++ b/common_zarch.h @@ -0,0 +1,140 @@ +/***************************************************************************** +Copyright (c) 2011-2016, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +**********************************************************************************/ + +#ifndef COMMON_ZARCH +#define COMMON_ZARCH + +#define MB +//__asm__ __volatile__ ("dmb ish" : : : "memory") +#define WMB +//__asm__ __volatile__ ("dmb ishst" : : : "memory") + + +#define INLINE inline + +#define RETURN_BY_COMPLEX + +#ifndef ASSEMBLER + + /* +static void __inline blas_lock(volatile BLASULONG *address){ + + BLASULONG ret; + + do { + while (*address) {YIELDING;}; + + __asm__ __volatile__( + "mov x4, #1 \n\t" + "1: \n\t" + "ldaxr x2, [%1] \n\t" + "cbnz x2, 1b \n\t" + "2: \n\t" + "stxr w3, x4, [%1] \n\t" + "cbnz w3, 1b \n\t" + "mov %0, #0 \n\t" + : "=r"(ret), "=r"(address) + : "1"(address) + : "memory", "x2" , "x3", "x4" + + + ); + + + } while (ret); + +} + */ +//#define BLAS_LOCK_DEFINED + + + +static inline int blas_quickdivide(blasint x, blasint y){ + return x / y; +} + +#if defined(DOUBLE) +#define GET_IMAGE(res) __asm__ __volatile__("str d1, %0" : "=m"(res) : : "memory") +#else +#define GET_IMAGE(res) __asm__ __volatile__("str s1, %0" : "=m"(res) : : "memory") +#endif + +#define GET_IMAGE_CANCEL + +#endif + + +#ifndef F_INTERFACE +#define REALNAME ASMNAME +#else +#define REALNAME ASMFNAME +#endif + +#if defined(ASSEMBLER) && !defined(NEEDPARAM) + +#define PROLOGUE \ + .text ;\ + .align 256 ;\ + .global REALNAME ;\ + .type REALNAME, %function ;\ +REALNAME: + + +#define EPILOGUE + +#define PROFCODE + +#endif + + +#define SEEK_ADDRESS + +#ifndef PAGESIZE +#define PAGESIZE ( 4 << 10) +#endif +#define HUGE_PAGESIZE ( 4 << 20) + +#if defined(CORTEXA57) +#define BUFFER_SIZE (20 << 20) +#else +#define BUFFER_SIZE (16 << 20) +#endif + + +#define BASE_ADDRESS (START_ADDRESS - BUFFER_SIZE * MAX_CPU_NUMBER) + +#ifndef MAP_ANONYMOUS +#define MAP_ANONYMOUS MAP_ANON +#endif + +#endif + diff --git a/cpuid.h b/cpuid.h index e9bd2d016d..1dacc49bae 100644 --- a/cpuid.h +++ b/cpuid.h @@ -114,6 +114,7 @@ #define CORE_HASWELL 24 #define CORE_STEAMROLLER 25 #define CORE_EXCAVATOR 26 +#define CORE_ZEN 27 #define HAVE_SSE (1 << 0) #define HAVE_SSE2 (1 << 1) @@ -209,5 +210,6 @@ typedef struct { #define CPUTYPE_HASWELL 48 #define CPUTYPE_STEAMROLLER 49 #define CPUTYPE_EXCAVATOR 50 +#define CPUTYPE_ZEN 51 #endif diff --git a/cpuid_arm.c b/cpuid_arm.c index fe462c04a2..2f8959242c 100644 --- a/cpuid_arm.c +++ b/cpuid_arm.c @@ -74,7 +74,7 @@ int get_feature(char *search) fclose(infile); - if( p == NULL ) return; + if( p == NULL ) return 0; t = strtok(p," "); while( t = strtok(NULL," ")) diff --git a/cpuid_arm64.c b/cpuid_arm64.c index 506c9d0c2f..9b318e700b 100644 --- a/cpuid_arm64.c +++ b/cpuid_arm64.c @@ -30,17 +30,26 @@ #define CPU_UNKNOWN 0 #define CPU_ARMV8 1 #define CPU_CORTEXA57 2 +#define CPU_VULCAN 3 +#define CPU_THUNDERX 4 +#define CPU_THUNDERX2T99 5 static char *cpuname[] = { "UNKNOWN", "ARMV8" , - "CORTEXA57" + "CORTEXA57", + "VULCAN", + "THUNDERX", + "THUNDERX2T99" }; static char *cpuname_lower[] = { "unknown", "armv8" , - "cortexa57" + "cortexa57", + "vulcan", + "thunderx", + "thunderx2t99" }; int get_feature(char *search) @@ -85,25 +94,34 @@ int detect(void) #ifdef linux FILE *infile; - char buffer[512], *p; - p = (char *) NULL ; - - infile = fopen("/proc/cpuinfo", "r"); - while (fgets(buffer, sizeof(buffer), infile)) - { + char buffer[512], *p, *cpu_part = NULL, *cpu_implementer = NULL; + p = (char *) NULL ; - if (!strncmp("CPU part", buffer, 8)) - { - p = strchr(buffer, ':') + 2; + infile = fopen("/proc/cpuinfo", "r"); + while (fgets(buffer, sizeof(buffer), infile)) { + if ((cpu_part != NULL) && (cpu_implementer != NULL)) { break; } + + if ((cpu_part == NULL) && !strncmp("CPU part", buffer, 8)) { + cpu_part = strchr(buffer, ':') + 2; + cpu_part = strdup(cpu_part); + } else if ((cpu_implementer == NULL) && !strncmp("CPU implementer", buffer, 15)) { + cpu_implementer = strchr(buffer, ':') + 2; + cpu_implementer = strdup(cpu_implementer); + } } fclose(infile); - if(p != NULL) { - if (strstr(p, "0xd07")) { - return CPU_CORTEXA57; - } + if(cpu_part != NULL && cpu_implementer != NULL) { + if (strstr(cpu_part, "0xd07") && strstr(cpu_implementer, "0x41")) + return CPU_CORTEXA57; + else if (strstr(cpu_part, "0x516") && strstr(cpu_implementer, "0x42")) + return CPU_VULCAN; + else if (strstr(cpu_part, "0x0a1") && strstr(cpu_implementer, "0x43")) + return CPU_THUNDERX; + else if (strstr(cpu_part, "0xFFF") && strstr(cpu_implementer, "0x43")) /* TODO */ + return CPU_THUNDERX2T99; } p = (char *) NULL ; @@ -176,6 +194,28 @@ void get_cpuconfig(void) printf("#define L2_ASSOCIATIVE 4\n"); break; + case CPU_VULCAN: + printf("#define VULCAN \n"); + printf("#define HAVE_VFP \n"); + printf("#define HAVE_VFPV3 \n"); + printf("#define HAVE_NEON \n"); + printf("#define HAVE_VFPV4 \n"); + printf("#define L1_CODE_SIZE 32768 \n"); + printf("#define L1_CODE_LINESIZE 64 \n"); + printf("#define L1_CODE_ASSOCIATIVE 8 \n"); + printf("#define L1_DATA_SIZE 32768 \n"); + printf("#define L1_DATA_LINESIZE 64 \n"); + printf("#define L1_DATA_ASSOCIATIVE 8 \n"); + printf("#define L2_SIZE 262144 \n"); + printf("#define L2_LINESIZE 64 \n"); + printf("#define L2_ASSOCIATIVE 8 \n"); + printf("#define L3_SIZE 33554432 \n"); + printf("#define L3_LINESIZE 64 \n"); + printf("#define L3_ASSOCIATIVE 32 \n"); + printf("#define DTB_DEFAULT_ENTRIES 64 \n"); + printf("#define DTB_SIZE 4096 \n"); + break; + case CPU_CORTEXA57: printf("#define CORTEXA57\n"); printf("#define HAVE_VFP\n"); @@ -191,8 +231,42 @@ void get_cpuconfig(void) printf("#define L2_SIZE 2097152\n"); printf("#define L2_LINESIZE 64\n"); printf("#define L2_ASSOCIATIVE 16\n"); - printf("#define DTB_DEFAULT_ENTRIES 64\n"); - printf("#define DTB_SIZE 4096\n"); + printf("#define DTB_DEFAULT_ENTRIES 64\n"); + printf("#define DTB_SIZE 4096\n"); + break; + + case CPU_THUNDERX: + printf("#define ARMV8\n"); + printf("#define THUNDERX\n"); + printf("#define L1_DATA_SIZE 32768\n"); + printf("#define L1_DATA_LINESIZE 128\n"); + printf("#define L2_SIZE 16777216\n"); + printf("#define L2_LINESIZE 128\n"); + printf("#define DTB_DEFAULT_ENTRIES 64\n"); + printf("#define DTB_SIZE 4096\n"); + printf("#define L2_ASSOCIATIVE 16\n"); + break; + + case CPU_THUNDERX2T99: + printf("#define VULCAN \n"); + printf("#define HAVE_VFP \n"); + printf("#define HAVE_VFPV3 \n"); + printf("#define HAVE_NEON \n"); + printf("#define HAVE_VFPV4 \n"); + printf("#define L1_CODE_SIZE 32768 \n"); + printf("#define L1_CODE_LINESIZE 64 \n"); + printf("#define L1_CODE_ASSOCIATIVE 8 \n"); + printf("#define L1_DATA_SIZE 32768 \n"); + printf("#define L1_DATA_LINESIZE 64 \n"); + printf("#define L1_DATA_ASSOCIATIVE 8 \n"); + printf("#define L2_SIZE 262144 \n"); + printf("#define L2_LINESIZE 64 \n"); + printf("#define L2_ASSOCIATIVE 8 \n"); + printf("#define L3_SIZE 33554432 \n"); + printf("#define L3_LINESIZE 64 \n"); + printf("#define L3_ASSOCIATIVE 32 \n"); + printf("#define DTB_DEFAULT_ENTRIES 64 \n"); + printf("#define DTB_SIZE 4096 \n"); break; } } diff --git a/cpuid_x86.c b/cpuid_x86.c index bbd377f672..ab2ecdcaf7 100644 --- a/cpuid_x86.c +++ b/cpuid_x86.c @@ -636,6 +636,13 @@ int get_cacheinfo(int type, cache_info_t *cacheinfo){ LD1.associative = 8; LD1.linesize = 64; break; + case 0x63 : + DTB.size = 2048; + DTB.associative = 4; + DTB.linesize = 32; + LDTB.size = 4096; + LDTB.associative= 4; + LDTB.linesize = 32; case 0x66 : LD1.size = 8; LD1.associative = 4; @@ -667,6 +674,13 @@ int get_cacheinfo(int type, cache_info_t *cacheinfo){ LC1.size = 64; LC1.associative = 8; break; + case 0x76 : + ITB.size = 2048; + ITB.associative = 0; + ITB.linesize = 8; + LITB.size = 4096; + LITB.associative= 0; + LITB.linesize = 8; case 0x77 : LC1.size = 16; LC1.associative = 4; @@ -1110,6 +1124,9 @@ int get_cpuname(void){ break; case 3: switch (model) { + case 7: + // Bay Trail + return CPUTYPE_ATOM; case 10: case 14: // Ivy Bridge @@ -1202,8 +1219,35 @@ int get_cpuname(void){ #endif else return CPUTYPE_NEHALEM; + case 7: + // Xeon Phi Knights Landing + if(support_avx()) +#ifndef NO_AVX2 + return CPUTYPE_HASWELL; +#else + return CPUTYPE_SANDYBRIDGE; +#endif + else + return CPUTYPE_NEHALEM; + case 12: + // Apollo Lake + return CPUTYPE_NEHALEM; } break; + case 9: + case 8: + switch (model) { + case 14: // Kaby Lake + if(support_avx()) +#ifndef NO_AVX2 + return CPUTYPE_HASWELL; +#else + return CPUTYPE_SANDYBRIDGE; +#endif + else + return CPUTYPE_NEHALEM; + } + break; } break; case 0x7: @@ -1235,8 +1279,11 @@ int get_cpuname(void){ return CPUTYPE_OPTERON; case 1: case 3: + case 7: case 10: return CPUTYPE_BARCELONA; + case 5: + return CPUTYPE_BOBCAT; case 6: switch (model) { case 1: @@ -1251,7 +1298,13 @@ int get_cpuname(void){ return CPUTYPE_PILEDRIVER; else return CPUTYPE_BARCELONA; //OS don't support AVX. + case 5: // New EXCAVATOR CPUS + if(support_avx()) + return CPUTYPE_EXCAVATOR; + else + return CPUTYPE_BARCELONA; //OS don't support AVX. case 0: + case 8: switch(exmodel){ case 1: //AMD Trinity if(support_avx()) @@ -1273,8 +1326,19 @@ int get_cpuname(void){ break; } break; - case 5: - return CPUTYPE_BOBCAT; + case 8: + switch (model) { + case 1: + // AMD Ryzen + if(support_avx()) +#ifndef NO_AVX2 + return CPUTYPE_ZEN; +#else + return CPUTYPE_SANDYBRIDGE; // Zen is closer in architecture to Sandy Bridge than to Excavator +#endif + else + return CPUTYPE_BARCELONA; + } } break; } @@ -1401,6 +1465,7 @@ static char *cpuname[] = { "HASWELL", "STEAMROLLER", "EXCAVATOR", + "ZEN", }; static char *lowercpuname[] = { @@ -1454,6 +1519,7 @@ static char *lowercpuname[] = { "haswell", "steamroller", "excavator", + "zen", }; static char *corename[] = { @@ -1484,6 +1550,7 @@ static char *corename[] = { "HASWELL", "STEAMROLLER", "EXCAVATOR", + "ZEN", }; static char *corename_lower[] = { @@ -1514,6 +1581,7 @@ static char *corename_lower[] = { "haswell", "steamroller", "excavator", + "zen", }; @@ -1710,8 +1778,33 @@ int get_coretype(void){ #endif else return CORE_NEHALEM; - } + case 7: + // Phi Knights Landing + if(support_avx()) +#ifndef NO_AVX2 + return CORE_HASWELL; +#else + return CORE_SANDYBRIDGE; +#endif + else + return CORE_NEHALEM; + case 12: + // Apollo Lake + return CORE_NEHALEM; + } break; + case 9: + case 8: + if (model == 14) { // Kaby Lake + if(support_avx()) +#ifndef NO_AVX2 + return CORE_HASWELL; +#else + return CORE_SANDYBRIDGE; +#endif + else + return CORE_NEHALEM; + } } break; @@ -1741,8 +1834,13 @@ int get_coretype(void){ return CORE_PILEDRIVER; else return CORE_BARCELONA; //OS don't support AVX. - + case 5: // New EXCAVATOR + if(support_avx()) + return CORE_EXCAVATOR; + else + return CORE_BARCELONA; //OS don't support AVX. case 0: + case 8: switch(exmodel){ case 1: //AMD Trinity if(support_avx()) @@ -1764,9 +1862,22 @@ int get_coretype(void){ } break; } - - - }else return CORE_BARCELONA; + } else if (exfamily == 8) { + switch (model) { + case 1: + // AMD Ryzen + if(support_avx()) +#ifndef NO_AVX2 + return CORE_ZEN; +#else + return CORE_SANDYBRIDGE; // Zen is closer in architecture to Sandy Bridge than to Excavator +#endif + else + return CORE_BARCELONA; + } + } else { + return CORE_BARCELONA; + } } } diff --git a/cpuid_zarch.c b/cpuid_zarch.c new file mode 100644 index 0000000000..4e19354297 --- /dev/null +++ b/cpuid_zarch.c @@ -0,0 +1,111 @@ +/************************************************************************** + Copyright (c) 2016, The OpenBLAS Project + All rights reserved. + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE + USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + *****************************************************************************/ + +#include + +#define CPU_GENERIC 0 +#define CPU_Z13 1 + +static char *cpuname[] = { + "ZARCH_GENERIC", + "Z13" +}; + +static char *cpuname_lower[] = { + "zarch_generic", + "z13" +}; + +int detect(void) +{ + FILE *infile; + char buffer[512], *p; + + p = (char *)NULL; + infile = fopen("/proc/sysinfo", "r"); + while (fgets(buffer, sizeof(buffer), infile)){ + if (!strncmp("Type", buffer, 4)){ + p = strchr(buffer, ':') + 2; +#if 0 + fprintf(stderr, "%s\n", p); +#endif + break; + } + } + + fclose(infile); + + if (strstr(p, "2964")) return CPU_Z13; + if (strstr(p, "2965")) return CPU_Z13; + + return CPU_GENERIC; +} + +void get_libname(void) +{ + + int d = detect(); + printf("%s", cpuname_lower[d]); +} + +char *get_corename(void) +{ + return cpuname[detect()]; +} + +void get_architecture(void) +{ + printf("ZARCH"); +} + +void get_subarchitecture(void) +{ + int d = detect(); + printf("%s", cpuname[d]); +} + +void get_subdirname(void) +{ + printf("zarch"); +} + + +void get_cpuconfig(void) +{ + + int d = detect(); + switch (d){ + case CPU_GENERIC: + printf("#define ZARCH_GENERIC\n"); + printf("#define DTB_DEFAULT_ENTRIES 64\n"); + break; + case CPU_Z13: + printf("#define Z13\n"); + printf("#define DTB_DEFAULT_ENTRIES 64\n"); + break; + } +} diff --git a/ctest.c b/ctest.c index e0ef46e609..27d3b473a3 100644 --- a/ctest.c +++ b/ctest.c @@ -105,6 +105,10 @@ ARCH_X86_64 ARCH_POWER #endif +#if defined(__s390x__) || defined(__zarch__) +ARCH_ZARCH +#endif + #ifdef __mips64 ARCH_MIPS64 #endif diff --git a/driver/level2/gbmv_thread.c b/driver/level2/gbmv_thread.c index ef9d58d76f..e86b565f8e 100644 --- a/driver/level2/gbmv_thread.c +++ b/driver/level2/gbmv_thread.c @@ -177,7 +177,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG ku, BLASLONG kl, FLOAT *alpha, FLOAT blas_arg_t args; blas_queue_t queue[MAX_CPU_NUMBER]; - BLASLONG range_m[MAX_CPU_NUMBER]; + BLASLONG range_m[MAX_CPU_NUMBER + 1]; BLASLONG range_n[MAX_CPU_NUMBER + 1]; BLASLONG width, i, num_cpu; diff --git a/driver/level2/sbmv_thread.c b/driver/level2/sbmv_thread.c index a0377d6380..5718c0ec93 100644 --- a/driver/level2/sbmv_thread.c +++ b/driver/level2/sbmv_thread.c @@ -177,7 +177,7 @@ int CNAME(BLASLONG n, BLASLONG k, FLOAT *alpha, FLOAT *a, BLASLONG lda, FLOAT *x #endif blas_arg_t args; - blas_queue_t queue[MAX_CPU_NUMBER]; + blas_queue_t queue[MAX_CPU_NUMBER + 1]; BLASLONG range_m[MAX_CPU_NUMBER + 1]; BLASLONG range_n[MAX_CPU_NUMBER]; diff --git a/driver/level2/spmv_thread.c b/driver/level2/spmv_thread.c index f8ae3cdcdd..035300841d 100644 --- a/driver/level2/spmv_thread.c +++ b/driver/level2/spmv_thread.c @@ -182,7 +182,7 @@ int CNAME(BLASLONG m, FLOAT *alpha, FLOAT *a, FLOAT *x, BLASLONG incx, FLOAT *y, blas_arg_t args; blas_queue_t queue[MAX_CPU_NUMBER]; BLASLONG range_m[MAX_CPU_NUMBER + 1]; - BLASLONG range_n[MAX_CPU_NUMBER]; + BLASLONG range_n[MAX_CPU_NUMBER + 1]; BLASLONG width, i, num_cpu; diff --git a/driver/level2/tbmv_thread.c b/driver/level2/tbmv_thread.c index bbb1c50eb2..226a922e99 100644 --- a/driver/level2/tbmv_thread.c +++ b/driver/level2/tbmv_thread.c @@ -221,7 +221,7 @@ int CNAME(BLASLONG n, BLASLONG k, FLOAT *a, BLASLONG lda, FLOAT *x, BLASLONG inc blas_arg_t args; blas_queue_t queue[MAX_CPU_NUMBER]; BLASLONG range_m[MAX_CPU_NUMBER + 1]; - BLASLONG range_n[MAX_CPU_NUMBER]; + BLASLONG range_n[MAX_CPU_NUMBER + 1]; BLASLONG width, i, num_cpu; diff --git a/driver/level2/tpmv_thread.c b/driver/level2/tpmv_thread.c index 47dc1daf97..c91b527750 100644 --- a/driver/level2/tpmv_thread.c +++ b/driver/level2/tpmv_thread.c @@ -243,7 +243,7 @@ int CNAME(BLASLONG m, FLOAT *a, FLOAT *x, BLASLONG incx, FLOAT *buffer, int nthr blas_arg_t args; blas_queue_t queue[MAX_CPU_NUMBER]; BLASLONG range_m[MAX_CPU_NUMBER + 1]; - BLASLONG range_n[MAX_CPU_NUMBER]; + BLASLONG range_n[MAX_CPU_NUMBER + 1]; BLASLONG width, i, num_cpu; diff --git a/driver/level2/trmv_thread.c b/driver/level2/trmv_thread.c index 42edb83cb7..0a155366c3 100644 --- a/driver/level2/trmv_thread.c +++ b/driver/level2/trmv_thread.c @@ -281,7 +281,7 @@ int CNAME(BLASLONG m, FLOAT *a, BLASLONG lda, FLOAT *x, BLASLONG incx, FLOAT *bu blas_arg_t args; blas_queue_t queue[MAX_CPU_NUMBER]; BLASLONG range_m[MAX_CPU_NUMBER + 1]; - BLASLONG range_n[MAX_CPU_NUMBER]; + BLASLONG range_n[MAX_CPU_NUMBER + 1]; BLASLONG width, i, num_cpu; diff --git a/driver/level3/gemm3m_level3.c b/driver/level3/gemm3m_level3.c index 0649682987..bbde7e5d19 100644 --- a/driver/level3/gemm3m_level3.c +++ b/driver/level3/gemm3m_level3.c @@ -316,7 +316,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, if (min_l > GEMM3M_Q) { min_l = (min_l + 1) / 2; #ifdef UNROLL_X - min_l = (min_l + UNROLL_X - 1) & ~(UNROLL_X - 1); + min_l = ((min_l + UNROLL_X - 1)/UNROLL_X) * UNROLL_X; #endif } } @@ -326,7 +326,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else { if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } } @@ -365,7 +365,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); @@ -386,7 +386,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else { if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } } @@ -429,7 +429,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); @@ -451,7 +451,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else { if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } } @@ -494,7 +494,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); diff --git a/driver/level3/level3.c b/driver/level3/level3.c index 1ede8a2470..0ee189af46 100644 --- a/driver/level3/level3.c +++ b/driver/level3/level3.c @@ -297,9 +297,9 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_l = GEMM_Q; } else { if (min_l > GEMM_Q) { - min_l = (min_l / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_l = ((min_l / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } - gemm_p = ((l2size / min_l + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1)); + gemm_p = ((l2size / min_l + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; while (gemm_p * min_l > l2size) gemm_p -= GEMM_UNROLL_M; } @@ -311,7 +311,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else { if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } else { l1stride = 0; } @@ -369,7 +369,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } START_RPCC(); diff --git a/driver/level3/level3_gemm3m_thread.c b/driver/level3/level3_gemm3m_thread.c index 02bf57ee21..3400666259 100644 --- a/driver/level3/level3_gemm3m_thread.c +++ b/driver/level3/level3_gemm3m_thread.c @@ -365,7 +365,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, buffer[0] = sb; for (i = 1; i < DIVIDE_RATE; i++) { - buffer[i] = buffer[i - 1] + GEMM3M_Q * ((div_n + GEMM3M_UNROLL_N - 1) & ~(GEMM3M_UNROLL_N - 1)); + buffer[i] = buffer[i - 1] + GEMM3M_Q * (((div_n + GEMM3M_UNROLL_N - 1)/GEMM3M_UNROLL_N) * GEMM3M_UNROLL_N); } for(ls = 0; ls < k; ls += min_l){ @@ -384,7 +384,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else { if (min_i > GEMM3M_P) { - min_i = (min_i / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } } @@ -482,7 +482,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = ((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = (((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); @@ -618,7 +618,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = ((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = (((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); @@ -754,7 +754,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM3M_P; } else if (min_i > GEMM3M_P) { - min_i = ((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1) & ~(GEMM3M_UNROLL_M - 1); + min_i = (((min_i + 1) / 2 + GEMM3M_UNROLL_M - 1)/GEMM3M_UNROLL_M) * GEMM3M_UNROLL_M; } START_RPCC(); diff --git a/driver/level3/level3_syr2k.c b/driver/level3/level3_syr2k.c index a75d379d75..8bdd921c96 100644 --- a/driver/level3/level3_syr2k.c +++ b/driver/level3/level3_syr2k.c @@ -189,7 +189,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } #ifndef LOWER @@ -230,7 +230,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } ICOPY_OPERATION(min_l, min_i, a, lda, ls, is, sa); @@ -245,7 +245,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } if (m_start >= js) { @@ -284,7 +284,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } ICOPY_OPERATION(min_l, min_i, b, ldb, ls, is, sa); @@ -322,7 +322,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } aa = sb + min_l * (is - js) * COMPSIZE; @@ -353,7 +353,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } aa = sb + min_l * (m_start - js) * COMPSIZE; @@ -383,7 +383,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } aa = sb + min_l * (is - js) * COMPSIZE; diff --git a/driver/level3/level3_syrk.c b/driver/level3/level3_syrk.c index ba544a00d4..f3202eb880 100644 --- a/driver/level3/level3_syrk.c +++ b/driver/level3/level3_syrk.c @@ -198,7 +198,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } #ifndef LOWER @@ -239,7 +239,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } aa = sb + min_l * (is - js) * COMPSIZE; @@ -303,7 +303,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } START_RPCC(); @@ -375,7 +375,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } if (is < js + min_j) { @@ -460,7 +460,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } START_RPCC(); diff --git a/driver/level3/level3_syrk_threaded.c b/driver/level3/level3_syrk_threaded.c index 5119baad30..66732897ad 100644 --- a/driver/level3/level3_syrk_threaded.c +++ b/driver/level3/level3_syrk_threaded.c @@ -210,8 +210,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, fprintf(stderr, "Thread[%ld] m_from : %ld m_to : %ld n_from : %ld n_to : %ld\n", mypos, m_from, m_to, n_from, n_to); #endif - div_n = ((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE - + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; buffer[0] = sb; for (i = 1; i < DIVIDE_RATE; i++) { @@ -233,7 +232,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else { if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } } @@ -253,8 +252,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, STOP_RPCC(copy_A); - div_n = ((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE - + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; for (xxx = m_from, bufferside = 0; xxx < m_to; xxx += div_n, bufferside ++) { @@ -353,9 +351,8 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, while (current >= 0) { #endif - div_n = ((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE - + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); - + div_n = (((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; + for (xxx = range_n[current], bufferside = 0; xxx < range_n[current + 1]; xxx += div_n, bufferside ++) { START_RPCC(); @@ -412,7 +409,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = ((min_i + 1) / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = (((min_i + 1) / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } START_RPCC(); @@ -425,8 +422,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, do { - div_n = ((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE - + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; for (xxx = range_n[current], bufferside = 0; xxx < range_n[current + 1]; xxx += div_n, bufferside ++) { @@ -602,9 +598,9 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO double di = (double)i; - width = (((BLASLONG)(sqrt(di * di + dnum) - di) + mask) & ~mask); + width = (((BLASLONG)((sqrt(di * di + dnum) - di) + mask)/(mask+1)) * (mask+1) ); - if (num_cpu == 0) width = n - ((n - width) & ~mask); + if (num_cpu == 0) width = n - (((n - width)/(mask+1)) * (mask+1) ); if ((width > n - i) || (width < mask)) width = n - i; @@ -644,7 +640,7 @@ int CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, FLO double di = (double)i; - width = (((BLASLONG)(sqrt(di * di + dnum) - di) + mask) & ~mask); + width = (((BLASLONG)((sqrt(di * di + dnum) - di) + mask)/(mask+1)) * (mask+1)); if ((width > n - i) || (width < mask)) width = n - i; diff --git a/driver/level3/level3_thread.c b/driver/level3/level3_thread.c index 0382743005..fec873e51f 100644 --- a/driver/level3/level3_thread.c +++ b/driver/level3/level3_thread.c @@ -310,7 +310,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, buffer[0] = sb; for (i = 1; i < DIVIDE_RATE; i++) { - buffer[i] = buffer[i - 1] + GEMM_Q * ((div_n + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1)) * COMPSIZE; + buffer[i] = buffer[i - 1] + GEMM_Q * ((div_n + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N * COMPSIZE; } @@ -331,7 +331,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else { if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } else { if (args -> nthreads == 1) l1stride = 0; } @@ -443,7 +443,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = ((min_i + 1) / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_i = (((min_i + 1) / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } START_RPCC(); diff --git a/driver/level3/syrk_kernel.c b/driver/level3/syrk_kernel.c index 434d2f630a..6f224d05d4 100644 --- a/driver/level3/syrk_kernel.c +++ b/driver/level3/syrk_kernel.c @@ -158,7 +158,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha_r, int mm, nn; - mm = (loop & ~(GEMM_UNROLL_MN - 1)); + mm = (loop/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; nn = MIN(GEMM_UNROLL_MN, n - loop); #ifndef LOWER diff --git a/driver/level3/syrk_thread.c b/driver/level3/syrk_thread.c index 94274be72c..5f40853dc7 100644 --- a/driver/level3/syrk_thread.c +++ b/driver/level3/syrk_thread.c @@ -109,7 +109,7 @@ int CNAME(int mode, blas_arg_t *arg, BLASLONG *range_m, BLASLONG *range_n, int ( if (nthreads - num_cpu > 1) { di = (double)i; - width = ((BLASLONG)( sqrt(di * di + dnum) - di) + mask) & ~mask; + width = (BLASLONG)(( sqrt(di * di + dnum) - di + mask)/(mask+1)) * (mask+1); if ((width <= 0) || (width > n_to - i)) width = n_to - i; @@ -149,7 +149,7 @@ int CNAME(int mode, blas_arg_t *arg, BLASLONG *range_m, BLASLONG *range_n, int ( if (nthreads - num_cpu > 1) { di = (double)(arg -> n - i); - width = ((BLASLONG)(-sqrt(di * di + dnum) + di) + mask) & ~mask; + width = ((BLASLONG)((-sqrt(di * di + dnum) + di) + mask)/(mask+1)) * (mask+1); if ((width <= 0) || (width > n_to - i)) width = n_to - i; diff --git a/driver/level3/zher2k_kernel.c b/driver/level3/zher2k_kernel.c index 92aef88800..f67e9bd760 100644 --- a/driver/level3/zher2k_kernel.c +++ b/driver/level3/zher2k_kernel.c @@ -149,7 +149,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha_r, FLOAT alpha_i, int mm, nn; - mm = (loop & ~(GEMM_UNROLL_MN - 1)); + mm = (loop/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; nn = MIN(GEMM_UNROLL_MN, n - loop); #ifndef LOWER diff --git a/driver/level3/zherk_kernel.c b/driver/level3/zherk_kernel.c index e4c9e27c45..cebcc16db9 100644 --- a/driver/level3/zherk_kernel.c +++ b/driver/level3/zherk_kernel.c @@ -132,7 +132,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha_r, int mm, nn; - mm = (loop & ~(GEMM_UNROLL_MN - 1)); + mm = (loop/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; nn = MIN(GEMM_UNROLL_MN, n - loop); #ifndef LOWER diff --git a/driver/others/CMakeLists.txt b/driver/others/CMakeLists.txt index 489d40c76d..8e0be1e0ec 100644 --- a/driver/others/CMakeLists.txt +++ b/driver/others/CMakeLists.txt @@ -12,6 +12,8 @@ if (SMP) set(BLAS_SERVER blas_server_omp.c) elseif (${CMAKE_SYSTEM_NAME} STREQUAL "Windows") set(BLAS_SERVER blas_server_win32.c) + elseif (${CMAKE_SYSTEM_NAME} STREQUAL "WindowsStore") + set(BLAS_SERVER blas_server_win32.c) endif () if (NOT DEFINED BLAS_SERVER) diff --git a/driver/others/blas_l1_thread.c b/driver/others/blas_l1_thread.c index 83fc268841..e405c74650 100644 --- a/driver/others/blas_l1_thread.c +++ b/driver/others/blas_l1_thread.c @@ -110,3 +110,74 @@ int blas_level1_thread(int mode, BLASLONG m, BLASLONG n, BLASLONG k, void *alpha return 0; } + +int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, BLASLONG k, void *alpha, + void *a, BLASLONG lda, + void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads){ + + blas_queue_t queue[MAX_CPU_NUMBER]; + blas_arg_t args [MAX_CPU_NUMBER]; + + BLASLONG i, width, astride, bstride; + int num_cpu, calc_type; + + calc_type = (mode & BLAS_PREC) + ((mode & BLAS_COMPLEX) != 0) + 2; + + mode |= BLAS_LEGACY; + + for (i = 0; i < nthreads; i++) blas_queue_init(&queue[i]); + + num_cpu = 0; + i = m; + + while (i > 0){ + + /* Adjust Parameters */ + width = blas_quickdivide(i + nthreads - num_cpu - 1, + nthreads - num_cpu); + + i -= width; + if (i < 0) width = width + i; + + astride = width * lda; + + if (!(mode & BLAS_TRANSB_T)) { + bstride = width * ldb; + } else { + bstride = width; + } + + astride <<= calc_type; + bstride <<= calc_type; + + args[num_cpu].m = width; + args[num_cpu].n = n; + args[num_cpu].k = k; + args[num_cpu].a = (void *)a; + args[num_cpu].b = (void *)b; + args[num_cpu].c = (void *)((char *)c + num_cpu * sizeof(double)*2); + args[num_cpu].lda = lda; + args[num_cpu].ldb = ldb; + args[num_cpu].ldc = ldc; + args[num_cpu].alpha = alpha; + + queue[num_cpu].mode = mode; + queue[num_cpu].routine = function; + queue[num_cpu].args = &args[num_cpu]; + queue[num_cpu].next = &queue[num_cpu + 1]; + + a = (void *)((BLASULONG)a + astride); + b = (void *)((BLASULONG)b + bstride); + + num_cpu ++; + } + + if (num_cpu) { + queue[num_cpu - 1].next = NULL; + + exec_blas(num_cpu, queue); + } + + return 0; +} diff --git a/driver/others/blas_server.c b/driver/others/blas_server.c index 42cadf4b5d..9debe178d2 100644 --- a/driver/others/blas_server.c +++ b/driver/others/blas_server.c @@ -70,7 +70,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. /*********************************************************************/ #include "common.h" -#if defined(OS_LINUX) || defined(OS_NETBSD) || defined(OS_DARWIN) || defined(OS_ANDROID) || defined(OS_SUNOS) +#if defined(OS_LINUX) || defined(OS_NETBSD) || defined(OS_DARWIN) || defined(OS_ANDROID) || defined(OS_SUNOS) || defined(OS_FREEBSD) #include #include #include @@ -276,6 +276,9 @@ static void* blas_thread_server(void *arg){ unsigned int last_tick; void *buffer, *sa, *sb; blas_queue_t *queue; + +blas_queue_t *tscq; + #ifdef TIMING_DEBUG unsigned long start, stop; #endif @@ -309,8 +312,11 @@ static void* blas_thread_server(void *arg){ last_tick = (unsigned int)rpcc(); - while (!thread_status[cpu].queue) { + pthread_mutex_lock (&thread_status[cpu].lock); + tscq=thread_status[cpu].queue; + pthread_mutex_unlock (&thread_status[cpu].lock); + while(!tscq) { YIELDING; if ((unsigned int)rpcc() - last_tick > thread_timeout) { @@ -333,6 +339,9 @@ static void* blas_thread_server(void *arg){ last_tick = (unsigned int)rpcc(); } + pthread_mutex_lock (&thread_status[cpu].lock); + tscq=thread_status[cpu].queue; + pthread_mutex_unlock (&thread_status[cpu].lock); } @@ -351,7 +360,9 @@ static void* blas_thread_server(void *arg){ if (queue) { int (*routine)(blas_arg_t *, void *, void *, void *, void *, BLASLONG) = queue -> routine; + pthread_mutex_lock (&thread_status[cpu].lock); thread_status[cpu].queue = (blas_queue_t *)1; + pthread_mutex_unlock (&thread_status[cpu].lock); sa = queue -> sa; sb = queue -> sb; @@ -433,7 +444,10 @@ static void* blas_thread_server(void *arg){ // thread is marked as done and other threads use them WMB; + pthread_mutex_lock (&thread_status[cpu].lock); thread_status[cpu].queue = (blas_queue_t * volatile) ((long)thread_status[cpu].queue & 0); /* Need a trick */ + pthread_mutex_unlock (&thread_status[cpu].lock); + WMB; } @@ -613,6 +627,7 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ #endif BLASLONG i = 0; blas_queue_t *current = queue; + blas_queue_t *tsiq,*tspq; #if defined(OS_LINUX) && !defined(NO_AFFINITY) && !defined(PARAMTEST) int node = get_node(); int nodes = get_num_nodes(); @@ -660,15 +675,23 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ } } #else - while(thread_status[i].queue) { + pthread_mutex_lock (&thread_status[i].lock); + tsiq=thread_status[i].queue ; + pthread_mutex_unlock (&thread_status[i].lock); + while(tsiq) { i ++; if (i >= blas_num_threads - 1) i = 0; + pthread_mutex_lock (&thread_status[i].lock); + tsiq=thread_status[i].queue ; + pthread_mutex_unlock (&thread_status[i].lock); } #endif queue -> assigned = i; WMB; + pthread_mutex_lock (&thread_status[i].lock); thread_status[i].queue = queue; + pthread_mutex_unlock (&thread_status[i].lock); WMB; queue = queue -> next; @@ -689,11 +712,15 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ pos = current -> assigned; - if ((BLASULONG)thread_status[pos].queue > 1) { + pthread_mutex_lock (&thread_status[pos].lock); + tspq=thread_status[pos].queue; + pthread_mutex_unlock (&thread_status[pos].lock); + + if ((BLASULONG)tspq > 1) { + pthread_mutex_lock (&thread_status[pos].lock); if (thread_status[pos].status == THREAD_STATUS_SLEEP) { - pthread_mutex_lock (&thread_status[pos].lock); #ifdef MONITOR num_suspend ++; @@ -703,8 +730,9 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ thread_status[pos].status = THREAD_STATUS_WAKEUP; pthread_cond_signal(&thread_status[pos].wakeup); } - pthread_mutex_unlock(&thread_status[pos].lock); + } + pthread_mutex_unlock(&thread_status[pos].lock); } current = current -> next; @@ -714,11 +742,22 @@ int exec_blas_async(BLASLONG pos, blas_queue_t *queue){ } int exec_blas_async_wait(BLASLONG num, blas_queue_t *queue){ + blas_queue_t * tsqq; while ((num > 0) && queue) { - while(thread_status[queue -> assigned].queue) { + pthread_mutex_lock(&thread_status[queue->assigned].lock); + tsqq=thread_status[queue -> assigned].queue; + pthread_mutex_unlock(&thread_status[queue->assigned].lock); + + + while(tsqq) { YIELDING; + pthread_mutex_lock(&thread_status[queue->assigned].lock); + tsqq=thread_status[queue -> assigned].queue; + pthread_mutex_unlock(&thread_status[queue->assigned].lock); + + }; queue = queue -> next; diff --git a/driver/others/blas_server_win32.c b/driver/others/blas_server_win32.c index 081bdd7d42..cde8ca7934 100644 --- a/driver/others/blas_server_win32.c +++ b/driver/others/blas_server_win32.c @@ -443,8 +443,11 @@ int BLASFUNC(blas_thread_shutdown)(void){ SetEvent(pool.killed); for(i = 0; i < blas_num_threads - 1; i++){ - WaitForSingleObject(blas_threads[i], 5); //INFINITE); - TerminateThread(blas_threads[i],0); + WaitForSingleObject(blas_threads[i], 5); //INFINITE); +#ifndef OS_WINDOWSSTORE +// TerminateThread is only available with WINAPI_DESKTOP and WINAPI_SYSTEM not WINAPI_APP in UWP + TerminateThread(blas_threads[i],0); +#endif } blas_server_avail = 0; diff --git a/driver/others/dynamic.c b/driver/others/dynamic.c index 18f85c3168..e1e159de34 100644 --- a/driver/others/dynamic.c +++ b/driver/others/dynamic.c @@ -70,8 +70,10 @@ extern gotoblas_t gotoblas_STEAMROLLER; extern gotoblas_t gotoblas_EXCAVATOR; #ifdef NO_AVX2 #define gotoblas_HASWELL gotoblas_SANDYBRIDGE +#define gotoblas_ZEN gotoblas_SANDYBRIDGE #else extern gotoblas_t gotoblas_HASWELL; +extern gotoblas_t gotoblas_ZEN; #endif #else //Use NEHALEM kernels for sandy bridge @@ -81,6 +83,7 @@ extern gotoblas_t gotoblas_HASWELL; #define gotoblas_PILEDRIVER gotoblas_BARCELONA #define gotoblas_STEAMROLLER gotoblas_BARCELONA #define gotoblas_EXCAVATOR gotoblas_BARCELONA +#define gotoblas_ZEN gotoblas_BARCELONA #endif @@ -232,6 +235,7 @@ static gotoblas_t *get_coretype(void){ return &gotoblas_NEHALEM; //OS doesn't support AVX. Use old kernels. } } + if (model == 7) return &gotoblas_ATOM; //Bay Trail return NULL; case 4: //Intel Haswell @@ -263,7 +267,6 @@ static gotoblas_t *get_coretype(void){ } //Intel Braswell / Avoton if (model == 12 || model == 13) { - openblas_warning(FALLBACK_VERBOSE, NEHALEM_FALLBACK); return &gotoblas_NEHALEM; } return NULL; @@ -286,6 +289,30 @@ static gotoblas_t *get_coretype(void){ return &gotoblas_NEHALEM; //OS doesn't support AVX. Use old kernels. } } + //Intel Phi Knights Landing + if (model == 7) { + if(support_avx()) + return &gotoblas_HASWELL; + else{ + openblas_warning(FALLBACK_VERBOSE, NEHALEM_FALLBACK); + return &gotoblas_NEHALEM; //OS doesn't support AVX. Use old kernels. + } + } + //Apollo Lake + if (model == 12) { + return &gotoblas_NEHALEM; + } + return NULL; + case 9: + case 8: + if (model == 14 ) { // Kaby Lake + if(support_avx()) + return &gotoblas_HASWELL; + else{ + openblas_warning(FALLBACK_VERBOSE, NEHALEM_FALLBACK); + return &gotoblas_NEHALEM; //OS doesn't support AVX. Use old kernels. + } + } return NULL; } case 0xf: @@ -331,7 +358,14 @@ static gotoblas_t *get_coretype(void){ openblas_warning(FALLBACK_VERBOSE, BARCELONA_FALLBACK); return &gotoblas_BARCELONA; //OS doesn't support AVX. Use old kernels. } - }else if(model == 0){ + }else if(model == 5){ + if(support_avx()) + return &gotoblas_EXCAVATOR; + else{ + openblas_warning(FALLBACK_VERBOSE, BARCELONA_FALLBACK); + return &gotoblas_BARCELONA; //OS doesn't support AVX. Use old kernels. + } + }else if(model == 0 || model == 8){ if (exmodel == 1) { //AMD Trinity if(support_avx()) @@ -358,9 +392,16 @@ static gotoblas_t *get_coretype(void){ } } - - - } else { + } else if (exfamily == 8) { + if (model == 1) { + if(support_avx()) + return &gotoblas_ZEN; + else{ + openblas_warning(FALLBACK_VERBOSE, BARCELONA_FALLBACK); + return &gotoblas_BARCELONA; //OS doesn't support AVX. Use old kernels. + } + } + }else { return &gotoblas_BARCELONA; } } @@ -370,7 +411,6 @@ static gotoblas_t *get_coretype(void){ switch (family) { case 0x6: return &gotoblas_NANO; - break; } } @@ -401,6 +441,7 @@ static char *corename[] = { "Haswell", "Steamroller", "Excavator", + "Zen" }; char *gotoblas_corename(void) { @@ -427,6 +468,7 @@ char *gotoblas_corename(void) { if (gotoblas == &gotoblas_HASWELL) return corename[20]; if (gotoblas == &gotoblas_STEAMROLLER) return corename[21]; if (gotoblas == &gotoblas_EXCAVATOR) return corename[22]; + if (gotoblas == &gotoblas_ZEN) return corename[23]; return corename[0]; } @@ -439,7 +481,7 @@ static gotoblas_t *force_coretype(char *coretype){ char message[128]; //char mname[20]; - for ( i=1 ; i <= 22; i++) + for ( i=1 ; i <= 23; i++) { if (!strncasecmp(coretype,corename[i],20)) { @@ -457,6 +499,7 @@ static gotoblas_t *force_coretype(char *coretype){ switch (found) { + case 23: return (&gotoblas_ZEN); case 22: return (&gotoblas_EXCAVATOR); case 21: return (&gotoblas_STEAMROLLER); case 20: return (&gotoblas_HASWELL); diff --git a/driver/others/init.c b/driver/others/init.c index 801f939911..4c75d72e40 100644 --- a/driver/others/init.c +++ b/driver/others/init.c @@ -354,6 +354,24 @@ static int numa_check(void) { return common -> num_nodes; } +#if defined(__GLIBC_PREREQ) +#if !__GLIBC_PREREQ(2, 6) +int sched_getcpu(void) +{ +int cpu; +FILE *fp = NULL; +if ( (fp = fopen("/proc/self/stat", "r")) == NULL) + return -1; +if ( fscanf( fp, "%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%*s%d", &cpu) != 1) { + fclose (fp); + return -1; + } + fclose (fp); + return(cpu); +} +#endif +#endif + static void numa_mapping(void) { int node, cpu, core; @@ -760,11 +778,11 @@ static int initialized = 0; void gotoblas_affinity_init(void) { int cpu, num_avail; -#ifndef USE_OPENMP +#ifndef USE_OPENMP cpu_set_t cpu_mask; #endif int i; - + if (initialized) return; initialized = 1; @@ -808,16 +826,54 @@ void gotoblas_affinity_init(void) { common -> shmid = pshmid; if (common -> magic != SH_MAGIC) { + cpu_set_t *cpusetp; + int nums; + int ret; #ifdef DEBUG fprintf(stderr, "Shared Memory Initialization.\n"); #endif //returns the number of processors which are currently online - common -> num_procs = sysconf(_SC_NPROCESSORS_ONLN);; + + nums = sysconf(_SC_NPROCESSORS_CONF); + +#if !defined(__GLIBC_PREREQ) || !__GLIBC_PREREQ(2, 3) + common->num_procs = nums; +#elif __GLIBC_PREREQ(2, 7) + cpusetp = CPU_ALLOC(nums); + if (cpusetp == NULL) { + common->num_procs = nums; + } else { + size_t size; + size = CPU_ALLOC_SIZE(nums); + ret = sched_getaffinity(0,size,cpusetp); + if (ret!=0) + common->num_procs = nums; + else + common->num_procs = CPU_COUNT_S(size,cpusetp); + } + CPU_FREE(cpusetp); +#else + ret = sched_getaffinity(0,sizeof(cpu_set_t), cpusetp); + if (ret!=0) { + common->num_procs = nums; + } else { +#if !__GLIBC_PREREQ(2, 6) + int i; + int n = 0; + for (i=0;inum_procs = n; + } +#else + common->num_procs = CPU_COUNT(sizeof(cpu_set_t),cpusetp); +#endif + +#endif if(common -> num_procs > MAX_CPUS) { - fprintf(stderr, "\nOpenBLAS Warining : The number of CPU/Cores(%d) is beyond the limit(%d). Terminated.\n", common->num_procs, MAX_CPUS); + fprintf(stderr, "\nOpenBLAS Warning : The number of CPU/Cores(%d) is beyond the limit(%d). Terminated.\n", common->num_procs, MAX_CPUS); exit(1); } @@ -923,7 +979,7 @@ void gotoblas_set_affinity2(int threads) {}; void gotoblas_affinity_reschedule(void) {}; -int get_num_procs(void) { return sysconf(_SC_NPROCESSORS_ONLN); } +int get_num_procs(void) { return sysconf(_SC_NPROCESSORS_CONF); } int get_num_nodes(void) { return 1; } diff --git a/driver/others/memory.c b/driver/others/memory.c index e89f5c3281..38d0637156 100644 --- a/driver/others/memory.c +++ b/driver/others/memory.c @@ -169,13 +169,50 @@ void goto_set_num_threads(int num_threads) {}; #else -#if defined(OS_LINUX) || defined(OS_SUNOS) +#if defined(OS_LINUX) || defined(OS_SUNOS) || defined(OS_NETBSD) #ifndef NO_AFFINITY int get_num_procs(void); #else int get_num_procs(void) { static int nums = 0; - if (!nums) nums = sysconf(_SC_NPROCESSORS_ONLN); +cpu_set_t *cpusetp; +size_t size; +int ret; +int i,n; + + if (!nums) nums = sysconf(_SC_NPROCESSORS_CONF); +#if !defined(OS_LINUX) + return nums; +#endif + +#if !defined(__GLIBC_PREREQ) + return nums; +#endif +#if !__GLIBC_PREREQ(2, 3) + return nums; +#endif + +#if !__GLIBC_PREREQ(2, 7) + ret = sched_getaffinity(0,sizeof(cpu_set_t), cpusetp); + if (ret!=0) return nums; + n=0; +#if !__GLIBC_PREREQ(2, 6) + for (i=0;i NUM_BUFFERS) position >>= 1; + while (position >= NUM_BUFFERS) position >>= 1; do { if (!memory[position].used && (memory[position].pos == mypos)) { @@ -1034,14 +1074,14 @@ void *blas_memory_alloc(int procpos){ position = 0; do { - if (!memory[position].used) { +/* if (!memory[position].used) { */ blas_lock(&memory[position].lock); if (!memory[position].used) goto allocation; blas_unlock(&memory[position].lock); - } +/* } */ position ++; @@ -1103,7 +1143,9 @@ void *blas_memory_alloc(int procpos){ } while ((BLASLONG)map_address == -1); + LOCK_COMMAND(&alloc_lock); memory[position].addr = map_address; + UNLOCK_COMMAND(&alloc_lock); #ifdef DEBUG printf(" Mapping Succeeded. %p(%d)\n", (void *)memory[position].addr, position); @@ -1157,9 +1199,10 @@ void blas_memory_free(void *free_area){ #endif position = 0; + LOCK_COMMAND(&alloc_lock); - while ((memory[position].addr != free_area) - && (position < NUM_BUFFERS)) position++; + while ((position < NUM_BUFFERS) && (memory[position].addr != free_area)) + position++; if (memory[position].addr != free_area) goto error; @@ -1171,6 +1214,7 @@ void blas_memory_free(void *free_area){ WMB; memory[position].used = 0; + UNLOCK_COMMAND(&alloc_lock); #ifdef DEBUG printf("Unmap Succeeded.\n\n"); @@ -1185,6 +1229,7 @@ void blas_memory_free(void *free_area){ for (position = 0; position < NUM_BUFFERS; position++) printf("%4ld %p : %d\n", position, memory[position].addr, memory[position].used); #endif + UNLOCK_COMMAND(&alloc_lock); return; } @@ -1471,12 +1516,30 @@ static int on_process_term(void) #else #pragma comment(linker, "/INCLUDE:__tls_used") #endif -#pragma data_seg(push, old_seg) + +#ifdef _WIN64 +#pragma const_seg(".CRT$XLB") +#else #pragma data_seg(".CRT$XLB") +#endif static void (APIENTRY *dll_callback)(HINSTANCE h, DWORD ul_reason_for_call, PVOID pv) = DllMain; +#ifdef _WIN64 +#pragma const_seg() +#else +#pragma data_seg() +#endif + +#ifdef _WIN64 +#pragma const_seg(".CRT$XTU") +#else #pragma data_seg(".CRT$XTU") +#endif static int(*p_process_term)(void) = on_process_term; -#pragma data_seg(pop, old_seg) +#ifdef _WIN64 +#pragma const_seg() +#else +#pragma data_seg() +#endif #endif #if (defined(C_PGI) || (!defined(C_SUN) && defined(F_INTERFACE_SUN))) && (defined(ARCH_X86) || defined(ARCH_X86_64)) diff --git a/driver/others/parameter.c b/driver/others/parameter.c index f22c6b69ae..31a48644ff 100644 --- a/driver/others/parameter.c +++ b/driver/others/parameter.c @@ -167,7 +167,7 @@ int get_L2_size(void){ #if defined(ATHLON) || defined(OPTERON) || defined(BARCELONA) || defined(BOBCAT) || defined(BULLDOZER) || \ defined(CORE_PRESCOTT) || defined(CORE_CORE2) || defined(PENRYN) || defined(DUNNINGTON) || \ defined(CORE_NEHALEM) || defined(CORE_SANDYBRIDGE) || defined(ATOM) || defined(GENERIC) || \ - defined(PILEDRIVER) || defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) + defined(PILEDRIVER) || defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) || defined(ZEN) cpuid(0x80000006, &eax, &ebx, &ecx, &edx); @@ -251,7 +251,7 @@ int get_L2_size(void){ void blas_set_parameter(void){ int factor; -#if defined(BULLDOZER) || defined(PILEDRIVER) || defined(SANDYBRIDGE) || defined(NEHALEM) || defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) +#if defined(BULLDOZER) || defined(PILEDRIVER) || defined(SANDYBRIDGE) || defined(NEHALEM) || defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) || defined(ZEN) int size = 16; #else int size = get_L2_size(); @@ -497,13 +497,13 @@ void blas_set_parameter(void){ if (xgemm_p == 0) xgemm_p = 64; #endif - sgemm_p = (sgemm_p + SGEMM_UNROLL_M - 1) & ~(SGEMM_UNROLL_M - 1); - dgemm_p = (dgemm_p + DGEMM_UNROLL_M - 1) & ~(DGEMM_UNROLL_M - 1); - cgemm_p = (cgemm_p + CGEMM_UNROLL_M - 1) & ~(CGEMM_UNROLL_M - 1); - zgemm_p = (zgemm_p + ZGEMM_UNROLL_M - 1) & ~(ZGEMM_UNROLL_M - 1); + sgemm_p = ((sgemm_p + SGEMM_UNROLL_M - 1)/SGEMM_UNROLL_M) * SGEMM_UNROLL_M; + dgemm_p = ((dgemm_p + DGEMM_UNROLL_M - 1)/DGEMM_UNROLL_M) * DGEMM_UNROLL_M; + cgemm_p = ((cgemm_p + CGEMM_UNROLL_M - 1)/CGEMM_UNROLL_M) * CGEMM_UNROLL_M; + zgemm_p = ((zgemm_p + ZGEMM_UNROLL_M - 1)/ZGEMM_UNROLL_M) * ZGEMM_UNROLL_M; #ifdef QUAD_PRECISION - qgemm_p = (qgemm_p + QGEMM_UNROLL_M - 1) & ~(QGEMM_UNROLL_M - 1); - xgemm_p = (xgemm_p + XGEMM_UNROLL_M - 1) & ~(XGEMM_UNROLL_M - 1); + qgemm_p = ((qgemm_p + QGEMM_UNROLL_M - 1)/QGEMM_UNROLL_M) * QGEMM_UNROLL_M; + xgemm_p = ((xgemm_p + XGEMM_UNROLL_M - 1)/XGEMM_UNROLL_M) * XGEMM_UNROLL_M; #endif sgemm_r = (((BUFFER_SIZE - ((SGEMM_P * SGEMM_Q * 4 + GEMM_OFFSET_A + GEMM_ALIGN) & ~GEMM_ALIGN)) / (SGEMM_Q * 4)) - 15) & ~15; @@ -727,3 +727,38 @@ void blas_set_parameter(void){ } #endif + +#if defined(ARCH_ARM64) + +#if defined(VULCAN) || defined(THUNDERX2T99) +unsigned long dgemm_prefetch_size_a; +unsigned long dgemm_prefetch_size_b; +unsigned long dgemm_prefetch_size_c; +#endif + +void blas_set_parameter(void) +{ +#if defined(VULCAN) || defined(THUNDERX2T99) + dgemm_p = 160; + dgemm_q = 128; + dgemm_r = 4096; + + sgemm_p = 128; + sgemm_q = 352; + sgemm_r = 4096; + + cgemm_p = 128; + cgemm_q = 224; + cgemm_r = 4096; + + zgemm_p = 128; + zgemm_q = 112; + zgemm_r = 4096; + + dgemm_prefetch_size_a = 3584; + dgemm_prefetch_size_b = 512; + dgemm_prefetch_size_c = 128; +#endif +} + +#endif diff --git a/driver/others/xerbla.c b/driver/others/xerbla.c index 7427b51c4e..290f2833c3 100644 --- a/driver/others/xerbla.c +++ b/driver/others/xerbla.c @@ -46,10 +46,16 @@ #define printf _cprintf #endif +#ifdef INTERFACE64 +#define MSGFMT " ** On entry to %6s parameter number %2ld had an illegal value\n" +#else +#define MSGFMT " ** On entry to %6s parameter number %2d had an illegal value\n" +#endif + #ifdef __ELF__ int __xerbla(char *message, blasint *info, blasint length){ - printf(" ** On entry to %6s parameter number %2d had an illegal value\n", + printf(MSGFMT, message, *info); return 0; @@ -61,7 +67,7 @@ int BLASFUNC(xerbla)(char *, blasint *, blasint) __attribute__ ((weak, alias ("_ int BLASFUNC(xerbla)(char *message, blasint *info, blasint length){ - printf(" ** On entry to %6s parameter number %2d had an illegal value\n", + printf(MSGFMT, message, *info); return 0; diff --git a/exports/Makefile b/exports/Makefile index 5632b6fff7..c053895739 100644 --- a/exports/Makefile +++ b/exports/Makefile @@ -118,10 +118,16 @@ endif dllinit.$(SUFFIX) : dllinit.c $(CC) $(CFLAGS) -c -o $(@F) -s $< -ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS)) +ifeq ($(OSNAME), $(filter $(OSNAME),Linux SunOS Android)) so : ../$(LIBSONAME) +ifeq ($(OSNAME), Android) +INTERNALNAME = $(LIBPREFIX).so +else +INTERNALNAME = $(LIBPREFIX).so.$(MAJOR_VERSION) +endif + ifeq (, $(SYMBOLPREFIX)$(SYMBOLSUFFIX)) ../$(LIBSONAME) : ../$(LIBNAME) linktest.c else @@ -132,13 +138,13 @@ endif ifneq ($(C_COMPILER), LSB) $(CC) $(CFLAGS) $(LDFLAGS) -shared -o ../$(LIBSONAME) \ -Wl,--whole-archive $< -Wl,--no-whole-archive \ - -Wl,-soname,$(LIBPREFIX).so.$(MAJOR_VERSION) $(EXTRALIB) + -Wl,-soname,$(INTERNALNAME) $(EXTRALIB) $(CC) $(CFLAGS) $(LDFLAGS) -w -o linktest linktest.c ../$(LIBSONAME) $(FEXTRALIB) && echo OK. else #for LSB env LSBCC_SHAREDLIBS=gfortran $(CC) $(CFLAGS) $(LDFLAGS) -shared -o ../$(LIBSONAME) \ -Wl,--whole-archive $< -Wl,--no-whole-archive \ - -Wl,-soname,$(LIBPREFIX).so.$(MAJOR_VERSION) $(EXTRALIB) + -Wl,-soname,$(INTERNALNAME) $(EXTRALIB) $(FC) $(CFLAGS) $(LDFLAGS) -w -o linktest linktest.c ../$(LIBSONAME) $(FEXTRALIB) && echo OK. endif rm -f linktest diff --git a/exports/check_objs.sh b/exports/check_objs.sh new file mode 100755 index 0000000000..1083623275 --- /dev/null +++ b/exports/check_objs.sh @@ -0,0 +1,61 @@ +#!/bin/bash + +while read OBJ; do + + if echo "$OBJ"|grep "_$" >/dev/null + then + [ "$OBJ" = "caxpyc_" ] && continue + [ "$OBJ" = "zaxpyc_" ] && continue + [ "$OBJ" = "blas_thread_shutdown_" ] && continue + + O1=$(echo "$OBJ"|sed -e 's/_$//' ) + + if grep -w "$O1" exports/gensymbol >/dev/null + then + true + else + echo "$O1" + fi + continue + fi + + if echo "$OBJ"|grep "^cblas" >/dev/null + then + + if grep -w "$OBJ" exports/gensymbol >/dev/null + then + true + else + echo "$OBJ" + fi + continue + fi + + if echo "$OBJ"|grep "^LAPACKE" >/dev/null + then + + if grep -w "$OBJ" exports/gensymbol >/dev/null + then + true + else + echo "$OBJ" + fi + continue + fi + + if echo "$OBJ"|grep "^lapack" >/dev/null + then + + if grep -w "$OBJ" exports/gensymbol >/dev/null + then + true + else + echo "$OBJ" + fi + fi + + + + +done + diff --git a/exports/gensymbol b/exports/gensymbol index 7d16207c3e..89c6e83202 100644 --- a/exports/gensymbol +++ b/exports/gensymbol @@ -1,763 +1,1023 @@ #!/usr/bin/perl -@blasobjs = ( - caxpy,ccopy,cdotc,cdotu,cgbmv,cgemm,cgemv,cgerc,cgeru, - chbmv,chemm,chemv,cher2,cher2k,cher,cherk, - chpmv,chpr2,chpr,crotg,cscal,csrot,csscal,cswap, - csymm,csyr2k,csyrk,ctbmv,ctbsv,ctpmv,ctpsv,ctrmm,ctrmv,ctrsm, - ctrsv, csymv, - damax,damin,dasum,daxpy,dcabs1,dcopy,ddot,dgbmv,dgemm, - dgemv,dger,dmax,dmin,dnrm2,drot,drotg,drotm,drotmg,dsbmv, - dscal,dsdot,dspmv,dspr2, - dspr,dswap,dsymm,dsymv,dsyr2,dsyr2k,dsyr,dsyrk,dtbmv,dtbsv, - dtpmv,dtpsv,dtrmm,dtrmv,dtrsm,dtrsv,dzamax,dzamin,dzasum,dznrm2, - icamax,icamin,idamax,idamin,idmax,idmin,isamax,isamin,ismax,ismin, - izamax,izamin,lsame,samax,samin,sasum,saxpy,scabs1,scamax, - scamin,scasum,scnrm2,scopy,sdot,sdsdot,sgbmv,sgemm,sgemv,sger, - smax,smin,snrm2, - srot,srotg,srotm,srotmg,ssbmv,sscal,sspmv,sspr2,sspr,sswap, - ssymm,ssymv,ssyr2,ssyr2k,ssyr,ssyrk,stbmv,stbsv,stpmv,stpsv, - strmm,strmv,strsm,strsv,zaxpy,zcopy,zdotc,zdotu,zdrot, - zdscal,zgbmv,zgemm,zgemv,zgerc,zgeru, - zhbmv,zhemm,zhemv,zher2,zher2k,zher,zherk,zhpmv,zhpr2, - zhpr,zrotg,zscal,zswap,zsymm,zsyr2k,zsyrk,ztbmv, - ztbsv,ztpmv,ztpsv,ztrmm,ztrmv,ztrsm,ztrsv, zsymv, - xerbla, - saxpby,daxpby,caxpby,zaxpby, - sgeadd,dgeadd,cgeadd,zgeadd, - ); - -@cblasobjs = ( - cblas_caxpy, cblas_ccopy, cblas_cdotc, cblas_cdotu, cblas_cgbmv, cblas_cgemm, cblas_cgemv, - cblas_cgerc, cblas_cgeru, cblas_chbmv, cblas_chemm, cblas_chemv, cblas_cher2, cblas_cher2k, - cblas_cher, cblas_cherk, cblas_chpmv, cblas_chpr2, cblas_chpr, cblas_cscal, - cblas_csscal, cblas_cswap, cblas_csymm, cblas_csyr2k, cblas_csyrk, cblas_ctbmv, - cblas_ctbsv, cblas_ctpmv, cblas_ctpsv, cblas_ctrmm, cblas_ctrmv, cblas_ctrsm, cblas_ctrsv, - cblas_dasum, cblas_daxpy, cblas_dcopy, cblas_ddot, - cblas_dgbmv, cblas_dgemm, cblas_dgemv, cblas_dger, cblas_dnrm2, - cblas_drot, cblas_drotg, cblas_drotm, cblas_drotmg, cblas_dsbmv, cblas_dscal, cblas_dsdot, - cblas_dspmv, cblas_dspr2, cblas_dspr, cblas_dswap, cblas_dsymm, cblas_dsymv, cblas_dsyr2, - cblas_dsyr2k, cblas_dsyr, cblas_dsyrk, cblas_dtbmv, cblas_dtbsv, cblas_dtpmv, cblas_dtpsv, - cblas_dtrmm, cblas_dtrmv, cblas_dtrsm, cblas_dtrsv, cblas_dzasum, - cblas_dznrm2, cblas_icamax, cblas_idamax, - cblas_isamax, cblas_izamax, - cblas_sasum, cblas_saxpy, - cblas_scasum, cblas_scnrm2, cblas_scopy, cblas_sdot, cblas_sdsdot, cblas_sgbmv, cblas_sgemm, - cblas_sgemv, cblas_sger, cblas_snrm2, cblas_srot, cblas_srotg, - cblas_srotm, cblas_srotmg, cblas_ssbmv, cblas_sscal, cblas_sspmv, cblas_sspr2, cblas_sspr, - cblas_sswap, cblas_ssymm, cblas_ssymv, cblas_ssyr2, cblas_ssyr2k, cblas_ssyr, cblas_ssyrk, - cblas_stbmv, cblas_stbsv, cblas_stpmv, cblas_stpsv, cblas_strmm, cblas_strmv, cblas_strsm, - cblas_strsv, cblas_zaxpy, cblas_zcopy, cblas_zdotc, cblas_zdotu, cblas_zdscal, - cblas_zgbmv, cblas_zgemm, cblas_zgemv, cblas_zgerc, cblas_zgeru, cblas_zhbmv, cblas_zhemm, - cblas_zhemv, cblas_zher2, cblas_zher2k, cblas_zher, cblas_zherk, cblas_zhpmv, cblas_zhpr2, - cblas_zhpr, cblas_zscal, cblas_zswap, cblas_zsymm, cblas_zsyr2k, cblas_zsyrk, - cblas_ztbmv, cblas_ztbsv, cblas_ztpmv, cblas_ztpsv, cblas_ztrmm, cblas_ztrmv, cblas_ztrsm, - cblas_ztrsv, cblas_cdotc_sub, cblas_cdotu_sub, cblas_zdotc_sub, cblas_zdotu_sub, - cblas_saxpby,cblas_daxpby,cblas_caxpby,cblas_zaxpby, - cblas_somatcopy, cblas_domatcopy, cblas_comatcopy, cblas_zomatcopy, - cblas_simatcopy, cblas_dimatcopy, cblas_cimatcopy, cblas_zimatcopy, - cblas_sgeadd, cblas_dgeadd,cblas_cgeadd, cblas_zgeadd - ); +# Changelog +# 2017/09/03 staticfloat +# Added zsymv and csymv into @lapackobjs2 so they are properly renamed +# +# 2017/07/01 Saar +# removed zsymv_ and csymv_ from @blasobs, because these functions +# are now in lapack-3.7.0 +# added blas_thread_shutdown_ +# added Cblas_cgemm3m and Cblas_zgemm3m +# added somatcopy_, simatcopy_ ... +# added new functions from lapack-3.7.0 +# added LAPACKE deprecated objs from lapack-3.7.0 +# +# 2017/08/01 Saar +# removed blas_thread_shutdown_ +# +@blasobjs = ( + caxpy,ccopy,cdotc,cdotu,cgbmv,cgemm,cgemv,cgerc,cgeru, + chbmv,chemm,chemv,cher2,cher2k,cher,cherk, + chpmv,chpr2,chpr,crotg,cscal,csrot,csscal,cswap, + csymm,csyr2k,csyrk,ctbmv,ctbsv,ctpmv,ctpsv,ctrmm,ctrmv,ctrsm, + ctrsv, + damax,damin,dasum,daxpy,dcabs1,dcopy,ddot,dgbmv,dgemm, + dgemv,dger,dmax,dmin,dnrm2,drot,drotg,drotm,drotmg,dsbmv, + dscal,dsdot,dspmv,dspr2, + dspr,dswap,dsymm,dsymv,dsyr2,dsyr2k,dsyr,dsyrk,dtbmv,dtbsv, + dtpmv,dtpsv,dtrmm,dtrmv,dtrsm,dtrsv,dzamax,dzamin,dzasum,dznrm2, + icamax,icamin,idamax,idamin,idmax,idmin,isamax,isamin,ismax,ismin, + izamax,izamin,lsame,samax,samin,sasum,saxpy,scabs1,scamax, + scamin,scasum,scnrm2,scopy,sdot,sdsdot,sgbmv,sgemm,sgemv,sger, + smax,smin,snrm2, + srot,srotg,srotm,srotmg,ssbmv,sscal,sspmv,sspr2,sspr,sswap, + ssymm,ssymv,ssyr2,ssyr2k,ssyr,ssyrk,stbmv,stbsv,stpmv,stpsv, + strmm,strmv,strsm,strsv,zaxpy,zcopy,zdotc,zdotu,zdrot, + zdscal,zgbmv,zgemm,zgemv,zgerc,zgeru, + zhbmv,zhemm,zhemv,zher2,zher2k,zher,zherk,zhpmv,zhpr2, + zhpr,zrotg,zscal,zswap,zsymm,zsyr2k,zsyrk,ztbmv, + ztbsv,ztpmv,ztpsv,ztrmm,ztrmv,ztrsm,ztrsv, + xerbla, + saxpby,daxpby,caxpby,zaxpby, + sgeadd,dgeadd,cgeadd,zgeadd, + somatcopy, + simatcopy, + domatcopy, + dimatcopy, + comatcopy, + cimatcopy, + zomatcopy, + zimatcopy, +); + +@cblasobjs = ( + cblas_caxpy, cblas_ccopy, cblas_cdotc, cblas_cdotu, cblas_cgbmv, cblas_cgemm, cblas_cgemv, + cblas_cgerc, cblas_cgeru, cblas_chbmv, cblas_chemm, cblas_chemv, cblas_cher2, cblas_cher2k, + cblas_cher, cblas_cherk, cblas_chpmv, cblas_chpr2, cblas_chpr, cblas_cscal, + cblas_csscal, cblas_cswap, cblas_csymm, cblas_csyr2k, cblas_csyrk, cblas_ctbmv, + cblas_ctbsv, cblas_ctpmv, cblas_ctpsv, cblas_ctrmm, cblas_ctrmv, cblas_ctrsm, cblas_ctrsv, + cblas_dasum, cblas_daxpy, cblas_dcopy, cblas_ddot, + cblas_dgbmv, cblas_dgemm, cblas_dgemv, cblas_dger, cblas_dnrm2, + cblas_drot, cblas_drotg, cblas_drotm, cblas_drotmg, cblas_dsbmv, cblas_dscal, cblas_dsdot, + cblas_dspmv, cblas_dspr2, cblas_dspr, cblas_dswap, cblas_dsymm, cblas_dsymv, cblas_dsyr2, + cblas_dsyr2k, cblas_dsyr, cblas_dsyrk, cblas_dtbmv, cblas_dtbsv, cblas_dtpmv, cblas_dtpsv, + cblas_dtrmm, cblas_dtrmv, cblas_dtrsm, cblas_dtrsv, cblas_dzasum, + cblas_dznrm2, cblas_icamax, cblas_idamax, + cblas_isamax, cblas_izamax, + cblas_sasum, cblas_saxpy, + cblas_scasum, cblas_scnrm2, cblas_scopy, cblas_sdot, cblas_sdsdot, cblas_sgbmv, cblas_sgemm, + cblas_sgemv, cblas_sger, cblas_snrm2, cblas_srot, cblas_srotg, + cblas_srotm, cblas_srotmg, cblas_ssbmv, cblas_sscal, cblas_sspmv, cblas_sspr2, cblas_sspr, + cblas_sswap, cblas_ssymm, cblas_ssymv, cblas_ssyr2, cblas_ssyr2k, cblas_ssyr, cblas_ssyrk, + cblas_stbmv, cblas_stbsv, cblas_stpmv, cblas_stpsv, cblas_strmm, cblas_strmv, cblas_strsm, + cblas_strsv, cblas_zaxpy, cblas_zcopy, cblas_zdotc, cblas_zdotu, cblas_zdscal, + cblas_zgbmv, cblas_zgemm, cblas_zgemv, cblas_zgerc, cblas_zgeru, cblas_zhbmv, cblas_zhemm, + cblas_zhemv, cblas_zher2, cblas_zher2k, cblas_zher, cblas_zherk, cblas_zhpmv, cblas_zhpr2, + cblas_zhpr, cblas_zscal, cblas_zswap, cblas_zsymm, cblas_zsyr2k, cblas_zsyrk, + cblas_ztbmv, cblas_ztbsv, cblas_ztpmv, cblas_ztpsv, cblas_ztrmm, cblas_ztrmv, cblas_ztrsm, + cblas_ztrsv, cblas_cdotc_sub, cblas_cdotu_sub, cblas_zdotc_sub, cblas_zdotu_sub, + cblas_saxpby,cblas_daxpby,cblas_caxpby,cblas_zaxpby, + cblas_somatcopy, cblas_domatcopy, cblas_comatcopy, cblas_zomatcopy, + cblas_simatcopy, cblas_dimatcopy, cblas_cimatcopy, cblas_zimatcopy, + cblas_sgeadd, cblas_dgeadd,cblas_cgeadd, cblas_zgeadd +); @exblasobjs = ( - qamax,qamin,qasum,qaxpy,qcabs1,qcopy,qdot,qgbmv,qgemm, - qgemv,qger,qmax,qmin, - qnrm2, - qsbmv,qscal,qspmv,qspr2, - qspr,qswap,qsymm,qsymv,qsyr2,qsyr2k,qsyr,qsyrk,qtbmv,qtbsv, - qtpmv,qtpsv,qtrmm,qtrmv,qtrsm,qtrsv, - qxamax,qxamin,qxasum,qxnrm2, - xaxpy,xcopy,xdotc,xdotu, - xqscal,xgbmv,xgemm,xgemv,xgerc,xgeru, - xhbmv,xhemm,xhemv,xher2,xher2k,xher,xherk,xhpmv,xhpr2, - xhpr,xscal,xswap,xsymm,xsyr2k,xsyrk,xtbmv, - xtbsv,xtpmv,xtpsv,xtrmm,xtrmv,xtrsm,xtrsv, -# qrot,qrotg,qrotm,qrotmg, -# xdrot,xrotg, - ); + qamax,qamin,qasum,qaxpy,qcabs1,qcopy,qdot,qgbmv,qgemm, + qgemv,qger,qmax,qmin, + qnrm2, + qsbmv,qscal,qspmv,qspr2, + qspr,qswap,qsymm,qsymv,qsyr2,qsyr2k,qsyr,qsyrk,qtbmv,qtbsv, + qtpmv,qtpsv,qtrmm,qtrmv,qtrsm,qtrsv, + qxamax,qxamin,qxasum,qxnrm2, + xaxpy,xcopy,xdotc,xdotu, + xqscal,xgbmv,xgemm,xgemv,xgerc,xgeru, + xhbmv,xhemm,xhemv,xher2,xher2k,xher,xherk,xhpmv,xhpr2, + xhpr,xscal,xswap,xsymm,xsyr2k,xsyrk,xtbmv, + xtbsv,xtpmv,xtpsv,xtrmm,xtrmv,xtrsm,xtrsv, +# qrot,qrotg,qrotm,qrotmg, +# xdrot,xrotg, +); @gemm3mobjs = ( - cgemm3m,zgemm3m - ); + cgemm3m,zgemm3m +); + +@cblasgemm3mobjs = ( + cblas_cgemm3m,cblas_zgemm3m +); + + #both underscore and no underscore @misc_common_objs = ( - openblas_get_parallel, - openblas_get_num_procs, - openblas_set_num_threads, - openblas_get_num_threads, - ); + openblas_get_parallel, + openblas_get_num_procs, + openblas_set_num_threads, + openblas_get_num_threads, +); @misc_no_underscore_objs = ( - goto_set_num_threads, - openblas_get_config, - openblas_get_corename, - ); + goto_set_num_threads, + openblas_get_config, + openblas_get_corename, +); @misc_underscore_objs = ( - ); +); @lapackobjs = ( - # These routines are provided by OpenBLAS. - sgesv, dgesv, cgesv, zgesv, - sgetf2, dgetf2, cgetf2, zgetf2, - sgetrf, dgetrf, cgetrf, zgetrf, - slaswp, dlaswp, claswp, zlaswp, - sgetrs, dgetrs, cgetrs, zgetrs, - slauu2, dlauu2, clauu2, zlauu2, - slauum, dlauum, clauum, zlauum, - spotf2, dpotf2, cpotf2, zpotf2, - spotrf, dpotrf, cpotrf, zpotrf, - strti2, dtrti2, ctrti2, ztrti2, - strtri, dtrtri, ctrtri, ztrtri, - spotri, dpotri, cpotri, zpotri, - ); + # These routines are provided by OpenBLAS. + sgesv, dgesv, cgesv, zgesv, + sgetf2, dgetf2, cgetf2, zgetf2, + sgetrf, dgetrf, cgetrf, zgetrf, + slaswp, dlaswp, claswp, zlaswp, + sgetrs, dgetrs, cgetrs, zgetrs, + slauu2, dlauu2, clauu2, zlauu2, + slauum, dlauum, clauum, zlauum, + spotf2, dpotf2, cpotf2, zpotf2, + spotrf, dpotrf, cpotrf, zpotrf, + strti2, dtrti2, ctrti2, ztrti2, + strtri, dtrtri, ctrtri, ztrtri, + spotri, dpotri, cpotri, zpotri, +); @lapackobjs2 = ( - # These routines are provided by LAPACK (reference implementation). - # - # This list is prepared by copying all routines listed in - # `lapack-3.4.1/SRC/Makefile` and replacing the '.o' suffix with a comma. - # Thereafter the following routines should be removed: - # - those provided by OpenBLAS (see @lapackobjs) - # - extra precision routines (see @lapack_extendedprecision_objs) - # Each of these have been marked individually with "already provided" or "excluded". - - # ALLAUX -- Auxiliary routines called from all precisions - # already provided by @blasobjs: xerbla, lsame - ilaenv, ieeeck, lsamen, iparmq, - ilaprec, ilatrans, ilauplo, iladiag, - ilaver, slamch, slamc3, - - # SCLAUX -- Auxiliary routines called from both REAL and COMPLEX. - # excluded: second_$(TIMER) - sbdsdc, - sbdsqr, sdisna, slabad, slacpy, sladiv, slae2, slaebz, - slaed0, slaed1, slaed2, slaed3, slaed4, slaed5, slaed6, - slaed7, slaed8, slaed9, slaeda, slaev2, slagtf, - slagts, slamrg, slanst, - slapy2, slapy3, slarnv, - slarra, slarrb, slarrc, slarrd, slarre, slarrf, slarrj, - slarrk, slarrr, slaneg, - slartg, slaruv, slas2, slascl, - slasd0, slasd1, slasd2, slasd3, slasd4, slasd5, slasd6, - slasd7, slasd8, slasda, slasdq, slasdt, - slaset, slasq1, slasq2, slasq3, slasq4, slasq5, slasq6, - slasr, slasrt, slassq, slasv2, spttrf, sstebz, sstedc, - ssteqr, ssterf, slaisnan, sisnan, - slartgp, slartgs, - - # DZLAUX -- Auxiliary routines called from both DOUBLE and COMPLEX*16. - # excluded: dsecnd_$(TIMER) - dbdsdc, - dbdsqr, ddisna, dlabad, dlacpy, dladiv, dlae2, dlaebz, - dlaed0, dlaed1, dlaed2, dlaed3, dlaed4, dlaed5, dlaed6, - dlaed7, dlaed8, dlaed9, dlaeda, dlaev2, dlagtf, - dlagts, dlamrg, dlanst, - dlapy2, dlapy3, dlarnv, - dlarra, dlarrb, dlarrc, dlarrd, dlarre, dlarrf, dlarrj, - dlarrk, dlarrr, dlaneg, - dlartg, dlaruv, dlas2, dlascl, - dlasd0, dlasd1, dlasd2, dlasd3, dlasd4, dlasd5, dlasd6, - dlasd7, dlasd8, dlasda, dlasdq, dlasdt, - dlaset, dlasq1, dlasq2, dlasq3, dlasq4, dlasq5, dlasq6, - dlasr, dlasrt, dlassq, dlasv2, dpttrf, dstebz, dstedc, - dsteqr, dsterf, dlaisnan, disnan, - dlartgp, dlartgs, - dlamch, dlamc3, - - # SLASRC -- Single precision real LAPACK routines - # already provided by @lapackobjs: - # sgesv, sgetf2, slaswp, slauu2, slauum, spotf2, spotri, strti2, strtri - sgbbrd, sgbcon, sgbequ, sgbrfs, sgbsv, - sgbsvx, sgbtf2, sgbtrf, sgbtrs, sgebak, sgebal, sgebd2, - sgebrd, sgecon, sgeequ, sgees, sgeesx, sgeev, sgeevx, - sgehd2, sgehrd, sgelq2, sgelqf, - sgels, sgelsd, sgelss, sgelsy, sgeql2, sgeqlf, - sgeqp3, sgeqr2, sgeqr2p, sgeqrf, sgeqrfp, sgerfs, - sgerq2, sgerqf, sgesc2, sgesdd, sgesvd, sgesvx, - sgetc2, sgetri, - sggbak, sggbal, sgges, sggesx, sggev, sggevx, - sggglm, sgghrd, sgglse, sggqrf, - sggrqf, sgtcon, sgtrfs, sgtsv, - sgtsvx, sgttrf, sgttrs, sgtts2, shgeqz, - shsein, shseqr, slabrd, slacon, slacn2, - slaein, slaexc, slag2, slags2, slagtm, slagv2, slahqr, - slahr2, slaic1, slaln2, slals0, slalsa, slalsd, - slangb, slange, slangt, slanhs, slansb, slansp, - slansy, slantb, slantp, slantr, slanv2, - slapll, slapmt, - slaqgb, slaqge, slaqp2, slaqps, slaqsb, slaqsp, slaqsy, - slaqr0, slaqr1, slaqr2, slaqr3, slaqr4, slaqr5, - slaqtr, slar1v, slar2v, ilaslr, ilaslc, - slarf, slarfb, slarfg, slarfgp, slarft, slarfx, slargv, - slarrv, slartv, - slarz, slarzb, slarzt, slasy2, slasyf, - slatbs, slatdf, slatps, slatrd, slatrs, slatrz, - sopgtr, sopmtr, sorg2l, sorg2r, - sorgbr, sorghr, sorgl2, sorglq, sorgql, sorgqr, sorgr2, - sorgrq, sorgtr, sorm2l, sorm2r, - sormbr, sormhr, sorml2, sormlq, sormql, sormqr, sormr2, - sormr3, sormrq, sormrz, sormtr, spbcon, spbequ, spbrfs, - spbstf, spbsv, spbsvx, - spbtf2, spbtrf, spbtrs, spocon, spoequ, sporfs, sposv, - sposvx, spstrf, spstf2, - sppcon, sppequ, - spprfs, sppsv, sppsvx, spptrf, spptri, spptrs, sptcon, - spteqr, sptrfs, sptsv, sptsvx, spttrs, sptts2, srscl, - ssbev, ssbevd, ssbevx, ssbgst, ssbgv, ssbgvd, ssbgvx, - ssbtrd, sspcon, sspev, sspevd, sspevx, sspgst, - sspgv, sspgvd, sspgvx, ssprfs, sspsv, sspsvx, ssptrd, - ssptrf, ssptri, ssptrs, sstegr, sstein, sstev, sstevd, sstevr, - sstevx, - ssycon, ssyev, ssyevd, ssyevr, ssyevx, ssygs2, - ssygst, ssygv, ssygvd, ssygvx, ssyrfs, ssysv, ssysvx, - ssytd2, ssytf2, ssytrd, ssytrf, ssytri, ssytri2, ssytri2x, - ssyswapr, ssytrs, ssytrs2, ssyconv, - stbcon, - stbrfs, stbtrs, stgevc, stgex2, stgexc, stgsen, - stgsja, stgsna, stgsy2, stgsyl, stpcon, stprfs, stptri, - stptrs, - strcon, strevc, strexc, strrfs, strsen, strsna, strsyl, - strtrs, stzrzf, sstemr, - slansf, spftrf, spftri, spftrs, ssfrk, stfsm, stftri, stfttp, - stfttr, stpttf, stpttr, strttf, strttp, - sgejsv, sgesvj, sgsvj0, sgsvj1, - sgeequb, ssyequb, spoequb, sgbequb, - sbbcsd, slapmr, sorbdb, sorbdb1, sorbdb2, sorbdb3, sorbdb4, - sorbdb5, sorbdb6, sorcsd, sorcsd2by1, - sgeqrt, sgeqrt2, sgeqrt3, sgemqrt, - stpqrt, stpqrt2, stpmqrt, stprfb, - - # DSLASRC -- Double-single mixed precision real routines called from - # single, single-extra and double precision real LAPACK - # routines (i.e. from SLASRC, SXLASRC, DLASRC). - # - # already provided by @lapackobjs: - # sgetrs, spotrf, sgetrf - spotrs, - - # CLASRC -- Single precision complex LAPACK routines - # already provided by @blasobjs: csymv - # already provided by @lapackobjs: - # cgesv, cgetf2, claswp, clauu2, clauum, cpotf2, cpotri, ctrti2, ctrtri - cbdsqr, cgbbrd, cgbcon, cgbequ, cgbrfs, cgbsv, cgbsvx, - cgbtf2, cgbtrf, cgbtrs, cgebak, cgebal, cgebd2, cgebrd, - cgecon, cgeequ, cgees, cgeesx, cgeev, cgeevx, - cgehd2, cgehrd, cgelq2, cgelqf, - cgels, cgelsd, cgelss, cgelsy, cgeql2, cgeqlf, cgeqp3, - cgeqr2, cgeqr2p, cgeqrf, cgeqrfp, cgerfs, - cgerq2, cgerqf, cgesc2, cgesdd, cgesvd, - cgesvx, cgetc2, cgetri, - cggbak, cggbal, cgges, cggesx, cggev, cggevx, cggglm, - cgghrd, cgglse, cggqrf, cggrqf, - cgtcon, cgtrfs, cgtsv, cgtsvx, cgttrf, cgttrs, cgtts2, chbev, - chbevd, chbevx, chbgst, chbgv, chbgvd, chbgvx, chbtrd, - checon, cheev, cheevd, cheevr, cheevx, chegs2, chegst, - chegv, chegvd, chegvx, cherfs, chesv, chesvx, chetd2, - chetf2, chetrd, - chetrf, chetri, chetri2, chetri2x, cheswapr, - chetrs, chetrs2, chgeqz, chpcon, chpev, chpevd, - chpevx, chpgst, chpgv, chpgvd, chpgvx, chprfs, chpsv, - chpsvx, - chptrd, chptrf, chptri, chptrs, chsein, chseqr, clabrd, - clacgv, clacon, clacn2, clacp2, clacpy, clacrm, clacrt, cladiv, - claed0, claed7, claed8, - claein, claesy, claev2, clags2, clagtm, - clahef, clahqr, - clahr2, claic1, clals0, clalsa, clalsd, clangb, clange, clangt, - clanhb, clanhe, - clanhp, clanhs, clanht, clansb, clansp, clansy, clantb, - clantp, clantr, clapll, clapmt, clarcm, claqgb, claqge, - claqhb, claqhe, claqhp, claqp2, claqps, claqsb, - claqr0, claqr1, claqr2, claqr3, claqr4, claqr5, - claqsp, claqsy, clar1v, clar2v, ilaclr, ilaclc, - clarf, clarfb, clarfg, clarft, clarfgp, - clarfx, clargv, clarnv, clarrv, clartg, clartv, - clarz, clarzb, clarzt, clascl, claset, clasr, classq, - clasyf, clatbs, clatdf, clatps, clatrd, clatrs, clatrz, - cpbcon, cpbequ, cpbrfs, cpbstf, cpbsv, - cpbsvx, cpbtf2, cpbtrf, cpbtrs, cpocon, cpoequ, cporfs, - cposv, cposvx, cpstrf, cpstf2, - cppcon, cppequ, cpprfs, cppsv, cppsvx, cpptrf, cpptri, cpptrs, - cptcon, cpteqr, cptrfs, cptsv, cptsvx, cpttrf, cpttrs, cptts2, - crot, cspcon, cspmv, cspr, csprfs, cspsv, - cspsvx, csptrf, csptri, csptrs, csrscl, cstedc, - cstegr, cstein, csteqr, - csycon, - csyr, csyrfs, csysv, csysvx, csytf2, csytrf, csytri, csytri2, csytri2x, - csyswapr, csytrs, csytrs2, csyconv, - ctbcon, ctbrfs, ctbtrs, ctgevc, ctgex2, - ctgexc, ctgsen, ctgsja, ctgsna, ctgsy2, ctgsyl, ctpcon, - ctprfs, ctptri, - ctptrs, ctrcon, ctrevc, ctrexc, ctrrfs, ctrsen, ctrsna, - ctrsyl, ctrtrs, ctzrzf, cung2l, cung2r, - cungbr, cunghr, cungl2, cunglq, cungql, cungqr, cungr2, - cungrq, cungtr, cunm2l, cunm2r, cunmbr, cunmhr, cunml2, - cunmlq, cunmql, cunmqr, cunmr2, cunmr3, cunmrq, cunmrz, - cunmtr, cupgtr, cupmtr, icmax1, scsum1, cstemr, - chfrk, ctfttp, clanhf, cpftrf, cpftri, cpftrs, ctfsm, ctftri, - ctfttr, ctpttf, ctpttr, ctrttf, ctrttp, - cgeequb, cgbequb, csyequb, cpoequb, cheequb, - cbbcsd, clapmr, cunbdb, cunbdb1, cunbdb2, cunbdb3, cunbdb4, - cunbdb5, cunbdb6, cuncsd, cuncsd2by1, - cgeqrt, cgeqrt2, cgeqrt3, cgemqrt, - ctpqrt, ctpqrt2, ctpmqrt, ctprfb, - - # ZCLASRC -- Double-single mixed precision complex routines called from - # single, single-extra and double precision complex LAPACK - # routines (i.e. from CLASRC, CXLASRC, ZLASRC). - # - # already provided by @lapackobjs: - # cgetrs, cpotrf, cgetrf - cpotrs, - - # DLASRC -- Double precision real LAPACK routines - # already provided by @lapackobjs: - # dgesv, dgetf2, dgetrs, dlaswp, dlauu2, dlauum, dpotf2, dpotrf, dpotri, - # dtrti2, dtrtri - dgbbrd, dgbcon, dgbequ, dgbrfs, dgbsv, - dgbsvx, dgbtf2, dgbtrf, dgbtrs, dgebak, dgebal, dgebd2, - dgebrd, dgecon, dgeequ, dgees, dgeesx, dgeev, dgeevx, - dgehd2, dgehrd, dgelq2, dgelqf, - dgels, dgelsd, dgelss, dgelsy, dgeql2, dgeqlf, - dgeqp3, dgeqr2, dgeqr2p, dgeqrf, dgeqrfp, dgerfs, - dgerq2, dgerqf, dgesc2, dgesdd, dgesvd, dgesvx, - dgetc2, dgetri, - dggbak, dggbal, dgges, dggesx, dggev, dggevx, - dggglm, dgghrd, dgglse, dggqrf, - dggrqf, dgtcon, dgtrfs, dgtsv, - dgtsvx, dgttrf, dgttrs, dgtts2, dhgeqz, - dhsein, dhseqr, dlabrd, dlacon, dlacn2, - dlaein, dlaexc, dlag2, dlags2, dlagtm, dlagv2, dlahqr, - dlahr2, dlaic1, dlaln2, dlals0, dlalsa, dlalsd, - dlangb, dlange, dlangt, dlanhs, dlansb, dlansp, - dlansy, dlantb, dlantp, dlantr, dlanv2, - dlapll, dlapmt, - dlaqgb, dlaqge, dlaqp2, dlaqps, dlaqsb, dlaqsp, dlaqsy, - dlaqr0, dlaqr1, dlaqr2, dlaqr3, dlaqr4, dlaqr5, - dlaqtr, dlar1v, dlar2v, iladlr, iladlc, - dlarf, dlarfb, dlarfg, dlarfgp, dlarft, dlarfx, - dlargv, dlarrv, dlartv, - dlarz, dlarzb, dlarzt, dlasy2, dlasyf, - dlatbs, dlatdf, dlatps, dlatrd, dlatrs, dlatrz, - dopgtr, dopmtr, dorg2l, dorg2r, - dorgbr, dorghr, dorgl2, dorglq, dorgql, dorgqr, dorgr2, - dorgrq, dorgtr, dorm2l, dorm2r, - dormbr, dormhr, dorml2, dormlq, dormql, dormqr, dormr2, - dormr3, dormrq, dormrz, dormtr, dpbcon, dpbequ, dpbrfs, - dpbstf, dpbsv, dpbsvx, - dpbtf2, dpbtrf, dpbtrs, dpocon, dpoequ, dporfs, dposv, - dposvx, dpotrs, dpstrf, dpstf2, - dppcon, dppequ, - dpprfs, dppsv, dppsvx, dpptrf, dpptri, dpptrs, dptcon, - dpteqr, dptrfs, dptsv, dptsvx, dpttrs, dptts2, drscl, - dsbev, dsbevd, dsbevx, dsbgst, dsbgv, dsbgvd, dsbgvx, - dsbtrd, dspcon, dspev, dspevd, dspevx, dspgst, - dspgv, dspgvd, dspgvx, dsprfs, dspsv, dspsvx, dsptrd, - dsptrf, dsptri, dsptrs, dstegr, dstein, dstev, dstevd, dstevr, - dstevx, - dsycon, dsyev, dsyevd, dsyevr, - dsyevx, dsygs2, dsygst, dsygv, dsygvd, dsygvx, dsyrfs, - dsysv, dsysvx, - dsytd2, dsytf2, dsytrd, dsytrf, dsytri, dsytri2, dsytri2x, - dsyswapr, dsytrs, dsytrs2, dsyconv, - dtbcon, dtbrfs, dtbtrs, dtgevc, dtgex2, dtgexc, dtgsen, - dtgsja, dtgsna, dtgsy2, dtgsyl, dtpcon, dtprfs, dtptri, - dtptrs, - dtrcon, dtrevc, dtrexc, dtrrfs, dtrsen, dtrsna, dtrsyl, - dtrtrs, dtzrzf, dstemr, - dsgesv, dsposv, dlag2s, slag2d, dlat2s, - dlansf, dpftrf, dpftri, dpftrs, dsfrk, dtfsm, dtftri, dtfttp, - dtfttr, dtpttf, dtpttr, dtrttf, dtrttp, - dgejsv, dgesvj, dgsvj0, dgsvj1, - dgeequb, dsyequb, dpoequb, dgbequb, - dbbcsd, dlapmr, dorbdb, dorbdb1, dorbdb2, dorbdb3, dorbdb4, - dorbdb5, dorbdb6, dorcsd, dorcsd2by1, - dgeqrt, dgeqrt2, dgeqrt3, dgemqrt, - dtpqrt, dtpqrt2, dtpmqrt, dtprfb, - - # ZLASRC -- Double precision complex LAPACK routines - # already provided by @blasobjs: zsymv - # already provided by @lapackobjs: - # zgesv, zgetrs, zgetf2, zlaswp, zlauu2, zlauum, zpotf2, zpotrf, zpotri, - # ztrti2, ztrtri - zbdsqr, zgbbrd, zgbcon, zgbequ, zgbrfs, zgbsv, zgbsvx, - zgbtf2, zgbtrf, zgbtrs, zgebak, zgebal, zgebd2, zgebrd, - zgecon, zgeequ, zgees, zgeesx, zgeev, zgeevx, - zgehd2, zgehrd, zgelq2, zgelqf, - zgels, zgelsd, zgelss, zgelsy, zgeql2, zgeqlf, zgeqp3, - zgeqr2, zgeqr2p, zgeqrf, zgeqrfp, zgerfs, zgerq2, zgerqf, - zgesc2, zgesdd, zgesvd, zgesvx, zgetc2, - zgetri, - zggbak, zggbal, zgges, zggesx, zggev, zggevx, zggglm, - zgghrd, zgglse, zggqrf, zggrqf, - zgtcon, zgtrfs, zgtsv, zgtsvx, zgttrf, zgttrs, zgtts2, zhbev, - zhbevd, zhbevx, zhbgst, zhbgv, zhbgvd, zhbgvx, zhbtrd, - zhecon, zheev, zheevd, zheevr, zheevx, zhegs2, zhegst, - zhegv, zhegvd, zhegvx, zherfs, zhesv, zhesvx, zhetd2, - zhetf2, zhetrd, - zhetrf, zhetri, zhetri2, zhetri2x, zheswapr, - zhetrs, zhetrs2, zhgeqz, zhpcon, zhpev, zhpevd, - zhpevx, zhpgst, zhpgv, zhpgvd, zhpgvx, zhprfs, zhpsv, - zhpsvx, - zhptrd, zhptrf, zhptri, zhptrs, zhsein, zhseqr, zlabrd, - zlacgv, zlacon, zlacn2, zlacp2, zlacpy, zlacrm, zlacrt, zladiv, - zlaed0, zlaed7, zlaed8, - zlaein, zlaesy, zlaev2, zlags2, zlagtm, - zlahef, zlahqr, - zlahr2, zlaic1, zlals0, zlalsa, zlalsd, zlangb, zlange, - zlangt, zlanhb, - zlanhe, - zlanhp, zlanhs, zlanht, zlansb, zlansp, zlansy, zlantb, - zlantp, zlantr, zlapll, zlapmt, zlaqgb, zlaqge, - zlaqhb, zlaqhe, zlaqhp, zlaqp2, zlaqps, zlaqsb, - zlaqr0, zlaqr1, zlaqr2, zlaqr3, zlaqr4, zlaqr5, - zlaqsp, zlaqsy, zlar1v, zlar2v, ilazlr, ilazlc, - zlarcm, zlarf, zlarfb, - zlarfg, zlarft, zlarfgp, - zlarfx, zlargv, zlarnv, zlarrv, zlartg, zlartv, - zlarz, zlarzb, zlarzt, zlascl, zlaset, zlasr, - zlassq, zlasyf, - zlatbs, zlatdf, zlatps, zlatrd, zlatrs, zlatrz, - zpbcon, zpbequ, zpbrfs, zpbstf, zpbsv, - zpbsvx, zpbtf2, zpbtrf, zpbtrs, zpocon, zpoequ, zporfs, - zposv, zposvx, zpotrs, zpstrf, zpstf2, - zppcon, zppequ, zpprfs, zppsv, zppsvx, zpptrf, zpptri, zpptrs, - zptcon, zpteqr, zptrfs, zptsv, zptsvx, zpttrf, zpttrs, zptts2, - zrot, zspcon, zspmv, zspr, zsprfs, zspsv, - zspsvx, zsptrf, zsptri, zsptrs, zdrscl, zstedc, - zstegr, zstein, zsteqr, - zsycon, - zsyr, zsyrfs, zsysv, zsysvx, zsytf2, zsytrf, zsytri, zsytri2, zsytri2x, - zsyswapr, zsytrs, zsytrs2, zsyconv, - ztbcon, ztbrfs, ztbtrs, ztgevc, ztgex2, - ztgexc, ztgsen, ztgsja, ztgsna, ztgsy2, ztgsyl, ztpcon, - ztprfs, ztptri, - ztptrs, ztrcon, ztrevc, ztrexc, ztrrfs, ztrsen, ztrsna, - ztrsyl, ztrtrs, ztzrzf, zung2l, - zung2r, zungbr, zunghr, zungl2, zunglq, zungql, zungqr, zungr2, - zungrq, zungtr, zunm2l, zunm2r, zunmbr, zunmhr, zunml2, - zunmlq, zunmql, zunmqr, zunmr2, zunmr3, zunmrq, zunmrz, - zunmtr, zupgtr, - zupmtr, izmax1, dzsum1, zstemr, - zcgesv, zcposv, zlag2c, clag2z, zlat2c, - zhfrk, ztfttp, zlanhf, zpftrf, zpftri, zpftrs, ztfsm, ztftri, - ztfttr, ztpttf, ztpttr, ztrttf, ztrttp, - zgeequb, zgbequb, zsyequb, zpoequb, zheequb, - zbbcsd, zlapmr, zunbdb, zunbdb1, zunbdb2, zunbdb3, zunbdb4, - zunbdb5, zunbdb6, zuncsd, zuncsd2by1, - zgeqrt, zgeqrt2, zgeqrt3, zgemqrt, - ztpqrt, ztpqrt2, ztpmqrt, ztprfb, - # functions added for lapack-3.6.0 - - cgejsv, - cgesvdx, - cgesvj, - cgetrf2, - cgges3, - cggev3, - cgghd3, - cggsvd3, - cggsvp3, - cgsvj0, - cgsvj1, - clagge, - claghe, - clagsy, - clahilb, - clakf2, - clarge, - clarnd, - claror, - clarot, - clatm1, - clatm2, - clatm3, - clatm5, - clatm6, - clatme, - clatmr, - clatms, - clatmt, - cpotrf2, - csbmv, - cspr2, - csyr2, - cunm22, - dbdsvdx, - dgesvdx, - dgetrf2, - dgges3, - dggev3, - dgghd3, - dggsvd3, - dggsvp3, - dladiv2, - dlagge, - dlagsy, - dlahilb, - dlakf2, - dlaran, - dlarge, - dlarnd, - dlaror, - dlarot, - dlatm1, - dlatm2, - dlatm3, - dlatm5, - dlatm6, - dlatm7, - dlatme, - dlatmr, - dlatms, - dlatmt, - dorm22, - dpotrf2, - dsecnd, - sbdsvdx, - second, - sgesvdx, - sgetrf2, - sgges3, - sggev3, - sgghd3, - sggsvd3, - sggsvp3, - sladiv2, - slagge, - slagsy, - slahilb, - slakf2, - slaran, - slarge, - slarnd, - slaror, - slarot, - slatm1, - slatm2, - slatm3, - slatm5, - slatm6, - slatm7, - slatme, - slatmr, - slatms, - slatmt, - sorm22, - spotrf2, - zgejsv, - zgesvdx, - zgesvj, - zgetrf2, - zgges3, - zggev3, - zgghd3, - zggsvd3, - zggsvp3, - zgsvj0, - zgsvj1, - zlagge, - zlaghe, - zlagsy, - zlahilb, - zlakf2, - zlarge, - zlarnd, - zlaror, - zlarot, - zlatm1, - zlatm2, - zlatm3, - zlatm5, - zlatm6, - zlatme, - zlatmr, - zlatms, - zlatmt, - zpotrf2, - zsbmv, - zspr2, - zsyr2, - zunm22 - - ); + # These routines are provided by LAPACK (reference implementation). + # + # This list is prepared by copying all routines listed in + # `lapack-3.4.1/SRC/Makefile` and replacing the '.o' suffix with a comma. + # Thereafter the following routines should be removed: + # - those provided by OpenBLAS (see @lapackobjs) + # - extra precision routines (see @lapack_extendedprecision_objs) + # Each of these have been marked individually with "already provided" or "excluded". + + # ALLAUX -- Auxiliary routines called from all precisions + # already provided by @blasobjs: xerbla, lsame + ilaenv, ieeeck, lsamen, iparmq, + ilaprec, ilatrans, ilauplo, iladiag, + ilaver, slamch, slamc3, + + # SCLAUX -- Auxiliary routines called from both REAL and COMPLEX. + # excluded: second_$(TIMER) + sbdsdc, + sbdsqr, sdisna, slabad, slacpy, sladiv, slae2, slaebz, + slaed0, slaed1, slaed2, slaed3, slaed4, slaed5, slaed6, + slaed7, slaed8, slaed9, slaeda, slaev2, slagtf, + slagts, slamrg, slanst, + slapy2, slapy3, slarnv, + slarra, slarrb, slarrc, slarrd, slarre, slarrf, slarrj, + slarrk, slarrr, slaneg, + slartg, slaruv, slas2, slascl, + slasd0, slasd1, slasd2, slasd3, slasd4, slasd5, slasd6, + slasd7, slasd8, slasda, slasdq, slasdt, + slaset, slasq1, slasq2, slasq3, slasq4, slasq5, slasq6, + slasr, slasrt, slassq, slasv2, spttrf, sstebz, sstedc, + ssteqr, ssterf, slaisnan, sisnan, + slartgp, slartgs, + + # DZLAUX -- Auxiliary routines called from both DOUBLE and COMPLEX*16. + # excluded: dsecnd_$(TIMER) + dbdsdc, + dbdsqr, ddisna, dlabad, dlacpy, dladiv, dlae2, dlaebz, + dlaed0, dlaed1, dlaed2, dlaed3, dlaed4, dlaed5, dlaed6, + dlaed7, dlaed8, dlaed9, dlaeda, dlaev2, dlagtf, + dlagts, dlamrg, dlanst, + dlapy2, dlapy3, dlarnv, + dlarra, dlarrb, dlarrc, dlarrd, dlarre, dlarrf, dlarrj, + dlarrk, dlarrr, dlaneg, + dlartg, dlaruv, dlas2, dlascl, + dlasd0, dlasd1, dlasd2, dlasd3, dlasd4, dlasd5, dlasd6, + dlasd7, dlasd8, dlasda, dlasdq, dlasdt, + dlaset, dlasq1, dlasq2, dlasq3, dlasq4, dlasq5, dlasq6, + dlasr, dlasrt, dlassq, dlasv2, dpttrf, dstebz, dstedc, + dsteqr, dsterf, dlaisnan, disnan, + dlartgp, dlartgs, + dlamch, dlamc3, + + # SLASRC -- Single precision real LAPACK routines + # already provided by @lapackobjs: + # sgesv, sgetf2, slaswp, slauu2, slauum, spotf2, spotri, strti2, strtri + sgbbrd, sgbcon, sgbequ, sgbrfs, sgbsv, + sgbsvx, sgbtf2, sgbtrf, sgbtrs, sgebak, sgebal, sgebd2, + sgebrd, sgecon, sgeequ, sgees, sgeesx, sgeev, sgeevx, + sgehd2, sgehrd, sgelq2, sgelqf, + sgels, sgelsd, sgelss, sgelsy, sgeql2, sgeqlf, + sgeqp3, sgeqr2, sgeqr2p, sgeqrf, sgeqrfp, sgerfs, + sgerq2, sgerqf, sgesc2, sgesdd, sgesvd, sgesvx, + sgetc2, sgetri, + sggbak, sggbal, sgges, sggesx, sggev, sggevx, + sggglm, sgghrd, sgglse, sggqrf, + sggrqf, sgtcon, sgtrfs, sgtsv, + sgtsvx, sgttrf, sgttrs, sgtts2, shgeqz, + shsein, shseqr, slabrd, slacon, slacn2, + slaein, slaexc, slag2, slags2, slagtm, slagv2, slahqr, + slahr2, slaic1, slaln2, slals0, slalsa, slalsd, + slangb, slange, slangt, slanhs, slansb, slansp, + slansy, slantb, slantp, slantr, slanv2, + slapll, slapmt, + slaqgb, slaqge, slaqp2, slaqps, slaqsb, slaqsp, slaqsy, + slaqr0, slaqr1, slaqr2, slaqr3, slaqr4, slaqr5, + slaqtr, slar1v, slar2v, ilaslr, ilaslc, + slarf, slarfb, slarfg, slarfgp, slarft, slarfx, slargv, + slarrv, slartv, + slarz, slarzb, slarzt, slasy2, slasyf, + slatbs, slatdf, slatps, slatrd, slatrs, slatrz, + sopgtr, sopmtr, sorg2l, sorg2r, + sorgbr, sorghr, sorgl2, sorglq, sorgql, sorgqr, sorgr2, + sorgrq, sorgtr, sorm2l, sorm2r, + sormbr, sormhr, sorml2, sormlq, sormql, sormqr, sormr2, + sormr3, sormrq, sormrz, sormtr, spbcon, spbequ, spbrfs, + spbstf, spbsv, spbsvx, + spbtf2, spbtrf, spbtrs, spocon, spoequ, sporfs, sposv, + sposvx, spstrf, spstf2, + sppcon, sppequ, + spprfs, sppsv, sppsvx, spptrf, spptri, spptrs, sptcon, + spteqr, sptrfs, sptsv, sptsvx, spttrs, sptts2, srscl, + ssbev, ssbevd, ssbevx, ssbgst, ssbgv, ssbgvd, ssbgvx, + ssbtrd, sspcon, sspev, sspevd, sspevx, sspgst, + sspgv, sspgvd, sspgvx, ssprfs, sspsv, sspsvx, ssptrd, + ssptrf, ssptri, ssptrs, sstegr, sstein, sstev, sstevd, sstevr, + sstevx, + ssycon, ssyev, ssyevd, ssyevr, ssyevx, ssygs2, + ssygst, ssygv, ssygvd, ssygvx, ssyrfs, ssysv, ssysvx, + ssytd2, ssytf2, ssytrd, ssytrf, ssytri, ssytri2, ssytri2x, + ssyswapr, ssytrs, ssytrs2, ssyconv, + stbcon, + stbrfs, stbtrs, stgevc, stgex2, stgexc, stgsen, + stgsja, stgsna, stgsy2, stgsyl, stpcon, stprfs, stptri, + stptrs, + strcon, strevc, strexc, strrfs, strsen, strsna, strsyl, + strtrs, stzrzf, sstemr, + slansf, spftrf, spftri, spftrs, ssfrk, stfsm, stftri, stfttp, + stfttr, stpttf, stpttr, strttf, strttp, + sgejsv, sgesvj, sgsvj0, sgsvj1, + sgeequb, ssyequb, spoequb, sgbequb, + sbbcsd, slapmr, sorbdb, sorbdb1, sorbdb2, sorbdb3, sorbdb4, + sorbdb5, sorbdb6, sorcsd, sorcsd2by1, + sgeqrt, sgeqrt2, sgeqrt3, sgemqrt, + stpqrt, stpqrt2, stpmqrt, stprfb, + + # DSLASRC -- Double-single mixed precision real routines called from + # single, single-extra and double precision real LAPACK + # routines (i.e. from SLASRC, SXLASRC, DLASRC). + # + # already provided by @lapackobjs: + # sgetrs, spotrf, sgetrf + spotrs, + + # CLASRC -- Single precision complex LAPACK routines + # already provided by @blasobjs: + # already provided by @lapackobjs: + # cgesv, cgetf2, claswp, clauu2, clauum, cpotf2, cpotri, ctrti2, ctrtri + cbdsqr, cgbbrd, cgbcon, cgbequ, cgbrfs, cgbsv, cgbsvx, + cgbtf2, cgbtrf, cgbtrs, cgebak, cgebal, cgebd2, cgebrd, + cgecon, cgeequ, cgees, cgeesx, cgeev, cgeevx, + cgehd2, cgehrd, cgelq2, cgelqf, + cgels, cgelsd, cgelss, cgelsy, cgeql2, cgeqlf, cgeqp3, + cgeqr2, cgeqr2p, cgeqrf, cgeqrfp, cgerfs, + cgerq2, cgerqf, cgesc2, cgesdd, cgesvd, + cgesvx, cgetc2, cgetri, + cggbak, cggbal, cgges, cggesx, cggev, cggevx, cggglm, + cgghrd, cgglse, cggqrf, cggrqf, + cgtcon, cgtrfs, cgtsv, cgtsvx, cgttrf, cgttrs, cgtts2, chbev, + chbevd, chbevx, chbgst, chbgv, chbgvd, chbgvx, chbtrd, + checon, cheev, cheevd, cheevr, cheevx, chegs2, chegst, + chegv, chegvd, chegvx, cherfs, chesv, chesvx, chetd2, + chetf2, chetrd, + chetrf, chetri, chetri2, chetri2x, cheswapr, + chetrs, chetrs2, chgeqz, chpcon, chpev, chpevd, + chpevx, chpgst, chpgv, chpgvd, chpgvx, chprfs, chpsv, + chpsvx, + chptrd, chptrf, chptri, chptrs, chsein, chseqr, clabrd, + clacgv, clacon, clacn2, clacp2, clacpy, clacrm, clacrt, cladiv, + claed0, claed7, claed8, + claein, claesy, claev2, clags2, clagtm, + clahef, clahqr, + clahr2, claic1, clals0, clalsa, clalsd, clangb, clange, clangt, + clanhb, clanhe, + clanhp, clanhs, clanht, clansb, clansp, clansy, clantb, + clantp, clantr, clapll, clapmt, clarcm, claqgb, claqge, + claqhb, claqhe, claqhp, claqp2, claqps, claqsb, + claqr0, claqr1, claqr2, claqr3, claqr4, claqr5, + claqsp, claqsy, clar1v, clar2v, ilaclr, ilaclc, + clarf, clarfb, clarfg, clarft, clarfgp, + clarfx, clargv, clarnv, clarrv, clartg, clartv, + clarz, clarzb, clarzt, clascl, claset, clasr, classq, + clasyf, clatbs, clatdf, clatps, clatrd, clatrs, clatrz, + cpbcon, cpbequ, cpbrfs, cpbstf, cpbsv, + cpbsvx, cpbtf2, cpbtrf, cpbtrs, cpocon, cpoequ, cporfs, + cposv, cposvx, cpstrf, cpstf2, + cppcon, cppequ, cpprfs, cppsv, cppsvx, cpptrf, cpptri, cpptrs, + cptcon, cpteqr, cptrfs, cptsv, cptsvx, cpttrf, cpttrs, cptts2, + crot, cspcon, cspmv, cspr, csprfs, cspsv, + cspsvx, csptrf, csptri, csptrs, csrscl, cstedc, + cstegr, cstein, csteqr, + csycon, + csymv, + csyr, csyrfs, csysv, csysvx, csytf2, csytrf, csytri, csytri2, csytri2x, + csyswapr, csytrs, csytrs2, csyconv, + ctbcon, ctbrfs, ctbtrs, ctgevc, ctgex2, + ctgexc, ctgsen, ctgsja, ctgsna, ctgsy2, ctgsyl, ctpcon, + ctprfs, ctptri, + ctptrs, ctrcon, ctrevc, ctrexc, ctrrfs, ctrsen, ctrsna, + ctrsyl, ctrtrs, ctzrzf, cung2l, cung2r, + cungbr, cunghr, cungl2, cunglq, cungql, cungqr, cungr2, + cungrq, cungtr, cunm2l, cunm2r, cunmbr, cunmhr, cunml2, + cunmlq, cunmql, cunmqr, cunmr2, cunmr3, cunmrq, cunmrz, + cunmtr, cupgtr, cupmtr, icmax1, scsum1, cstemr, + chfrk, ctfttp, clanhf, cpftrf, cpftri, cpftrs, ctfsm, ctftri, + ctfttr, ctpttf, ctpttr, ctrttf, ctrttp, + cgeequb, cgbequb, csyequb, cpoequb, cheequb, + cbbcsd, clapmr, cunbdb, cunbdb1, cunbdb2, cunbdb3, cunbdb4, + cunbdb5, cunbdb6, cuncsd, cuncsd2by1, + cgeqrt, cgeqrt2, cgeqrt3, cgemqrt, + ctpqrt, ctpqrt2, ctpmqrt, ctprfb, + + # ZCLASRC -- Double-single mixed precision complex routines called from + # single, single-extra and double precision complex LAPACK + # routines (i.e. from CLASRC, CXLASRC, ZLASRC). + # + # already provided by @lapackobjs: + # cgetrs, cpotrf, cgetrf + cpotrs, + + # DLASRC -- Double precision real LAPACK routines + # already provided by @lapackobjs: + # dgesv, dgetf2, dgetrs, dlaswp, dlauu2, dlauum, dpotf2, dpotrf, dpotri, + # dtrti2, dtrtri + dgbbrd, dgbcon, dgbequ, dgbrfs, dgbsv, + dgbsvx, dgbtf2, dgbtrf, dgbtrs, dgebak, dgebal, dgebd2, + dgebrd, dgecon, dgeequ, dgees, dgeesx, dgeev, dgeevx, + dgehd2, dgehrd, dgelq2, dgelqf, + dgels, dgelsd, dgelss, dgelsy, dgeql2, dgeqlf, + dgeqp3, dgeqr2, dgeqr2p, dgeqrf, dgeqrfp, dgerfs, + dgerq2, dgerqf, dgesc2, dgesdd, dgesvd, dgesvx, + dgetc2, dgetri, + dggbak, dggbal, dgges, dggesx, dggev, dggevx, + dggglm, dgghrd, dgglse, dggqrf, + dggrqf, dgtcon, dgtrfs, dgtsv, + dgtsvx, dgttrf, dgttrs, dgtts2, dhgeqz, + dhsein, dhseqr, dlabrd, dlacon, dlacn2, + dlaein, dlaexc, dlag2, dlags2, dlagtm, dlagv2, dlahqr, + dlahr2, dlaic1, dlaln2, dlals0, dlalsa, dlalsd, + dlangb, dlange, dlangt, dlanhs, dlansb, dlansp, + dlansy, dlantb, dlantp, dlantr, dlanv2, + dlapll, dlapmt, + dlaqgb, dlaqge, dlaqp2, dlaqps, dlaqsb, dlaqsp, dlaqsy, + dlaqr0, dlaqr1, dlaqr2, dlaqr3, dlaqr4, dlaqr5, + dlaqtr, dlar1v, dlar2v, iladlr, iladlc, + dlarf, dlarfb, dlarfg, dlarfgp, dlarft, dlarfx, + dlargv, dlarrv, dlartv, + dlarz, dlarzb, dlarzt, dlasy2, dlasyf, + dlatbs, dlatdf, dlatps, dlatrd, dlatrs, dlatrz, + dopgtr, dopmtr, dorg2l, dorg2r, + dorgbr, dorghr, dorgl2, dorglq, dorgql, dorgqr, dorgr2, + dorgrq, dorgtr, dorm2l, dorm2r, + dormbr, dormhr, dorml2, dormlq, dormql, dormqr, dormr2, + dormr3, dormrq, dormrz, dormtr, dpbcon, dpbequ, dpbrfs, + dpbstf, dpbsv, dpbsvx, + dpbtf2, dpbtrf, dpbtrs, dpocon, dpoequ, dporfs, dposv, + dposvx, dpotrs, dpstrf, dpstf2, + dppcon, dppequ, + dpprfs, dppsv, dppsvx, dpptrf, dpptri, dpptrs, dptcon, + dpteqr, dptrfs, dptsv, dptsvx, dpttrs, dptts2, drscl, + dsbev, dsbevd, dsbevx, dsbgst, dsbgv, dsbgvd, dsbgvx, + dsbtrd, dspcon, dspev, dspevd, dspevx, dspgst, + dspgv, dspgvd, dspgvx, dsprfs, dspsv, dspsvx, dsptrd, + dsptrf, dsptri, dsptrs, dstegr, dstein, dstev, dstevd, dstevr, + dstevx, + dsycon, dsyev, dsyevd, dsyevr, + dsyevx, dsygs2, dsygst, dsygv, dsygvd, dsygvx, dsyrfs, + dsysv, dsysvx, + dsytd2, dsytf2, dsytrd, dsytrf, dsytri, dsytri2, dsytri2x, + dsyswapr, dsytrs, dsytrs2, dsyconv, + dtbcon, dtbrfs, dtbtrs, dtgevc, dtgex2, dtgexc, dtgsen, + dtgsja, dtgsna, dtgsy2, dtgsyl, dtpcon, dtprfs, dtptri, + dtptrs, + dtrcon, dtrevc, dtrexc, dtrrfs, dtrsen, dtrsna, dtrsyl, + dtrtrs, dtzrzf, dstemr, + dsgesv, dsposv, dlag2s, slag2d, dlat2s, + dlansf, dpftrf, dpftri, dpftrs, dsfrk, dtfsm, dtftri, dtfttp, + dtfttr, dtpttf, dtpttr, dtrttf, dtrttp, + dgejsv, dgesvj, dgsvj0, dgsvj1, + dgeequb, dsyequb, dpoequb, dgbequb, + dbbcsd, dlapmr, dorbdb, dorbdb1, dorbdb2, dorbdb3, dorbdb4, + dorbdb5, dorbdb6, dorcsd, dorcsd2by1, + dgeqrt, dgeqrt2, dgeqrt3, dgemqrt, + dtpqrt, dtpqrt2, dtpmqrt, dtprfb, + + # ZLASRC -- Double precision complex LAPACK routines + # already provided by @blasobjs: + # already provided by @lapackobjs: + # zgesv, zgetrs, zgetf2, zlaswp, zlauu2, zlauum, zpotf2, zpotrf, zpotri, + # ztrti2, ztrtri + zbdsqr, zgbbrd, zgbcon, zgbequ, zgbrfs, zgbsv, zgbsvx, + zgbtf2, zgbtrf, zgbtrs, zgebak, zgebal, zgebd2, zgebrd, + zgecon, zgeequ, zgees, zgeesx, zgeev, zgeevx, + zgehd2, zgehrd, zgelq2, zgelqf, + zgels, zgelsd, zgelss, zgelsy, zgeql2, zgeqlf, zgeqp3, + zgeqr2, zgeqr2p, zgeqrf, zgeqrfp, zgerfs, zgerq2, zgerqf, + zgesc2, zgesdd, zgesvd, zgesvx, zgetc2, + zgetri, + zggbak, zggbal, zgges, zggesx, zggev, zggevx, zggglm, + zgghrd, zgglse, zggqrf, zggrqf, + zgtcon, zgtrfs, zgtsv, zgtsvx, zgttrf, zgttrs, zgtts2, zhbev, + zhbevd, zhbevx, zhbgst, zhbgv, zhbgvd, zhbgvx, zhbtrd, + zhecon, zheev, zheevd, zheevr, zheevx, zhegs2, zhegst, + zhegv, zhegvd, zhegvx, zherfs, zhesv, zhesvx, zhetd2, + zhetf2, zhetrd, + zhetrf, zhetri, zhetri2, zhetri2x, zheswapr, + zhetrs, zhetrs2, zhgeqz, zhpcon, zhpev, zhpevd, + zhpevx, zhpgst, zhpgv, zhpgvd, zhpgvx, zhprfs, zhpsv, + zhpsvx, + zhptrd, zhptrf, zhptri, zhptrs, zhsein, zhseqr, zlabrd, + zlacgv, zlacon, zlacn2, zlacp2, zlacpy, zlacrm, zlacrt, zladiv, + zlaed0, zlaed7, zlaed8, + zlaein, zlaesy, zlaev2, zlags2, zlagtm, + zlahef, zlahqr, + zlahr2, zlaic1, zlals0, zlalsa, zlalsd, zlangb, zlange, + zlangt, zlanhb, + zlanhe, + zlanhp, zlanhs, zlanht, zlansb, zlansp, zlansy, zlantb, + zlantp, zlantr, zlapll, zlapmt, zlaqgb, zlaqge, + zlaqhb, zlaqhe, zlaqhp, zlaqp2, zlaqps, zlaqsb, + zlaqr0, zlaqr1, zlaqr2, zlaqr3, zlaqr4, zlaqr5, + zlaqsp, zlaqsy, zlar1v, zlar2v, ilazlr, ilazlc, + zlarcm, zlarf, zlarfb, + zlarfg, zlarft, zlarfgp, + zlarfx, zlargv, zlarnv, zlarrv, zlartg, zlartv, + zlarz, zlarzb, zlarzt, zlascl, zlaset, zlasr, + zlassq, zlasyf, + zlatbs, zlatdf, zlatps, zlatrd, zlatrs, zlatrz, + zpbcon, zpbequ, zpbrfs, zpbstf, zpbsv, + zpbsvx, zpbtf2, zpbtrf, zpbtrs, zpocon, zpoequ, zporfs, + zposv, zposvx, zpotrs, zpstrf, zpstf2, + zppcon, zppequ, zpprfs, zppsv, zppsvx, zpptrf, zpptri, zpptrs, + zptcon, zpteqr, zptrfs, zptsv, zptsvx, zpttrf, zpttrs, zptts2, + zrot, zspcon, zspmv, zspr, zsprfs, zspsv, + zspsvx, zsptrf, zsptri, zsptrs, zdrscl, zstedc, + zstegr, zstein, zsteqr, + zsycon, + zsymv, + zsyr, zsyrfs, zsysv, zsysvx, zsytf2, zsytrf, zsytri, zsytri2, zsytri2x, + zsyswapr, zsytrs, zsytrs2, zsyconv, + ztbcon, ztbrfs, ztbtrs, ztgevc, ztgex2, + ztgexc, ztgsen, ztgsja, ztgsna, ztgsy2, ztgsyl, ztpcon, + ztprfs, ztptri, + ztptrs, ztrcon, ztrevc, ztrexc, ztrrfs, ztrsen, ztrsna, + ztrsyl, ztrtrs, ztzrzf, zung2l, + zung2r, zungbr, zunghr, zungl2, zunglq, zungql, zungqr, zungr2, + zungrq, zungtr, zunm2l, zunm2r, zunmbr, zunmhr, zunml2, + zunmlq, zunmql, zunmqr, zunmr2, zunmr3, zunmrq, zunmrz, + zunmtr, zupgtr, + zupmtr, izmax1, dzsum1, zstemr, + zcgesv, zcposv, zlag2c, clag2z, zlat2c, + zhfrk, ztfttp, zlanhf, zpftrf, zpftri, zpftrs, ztfsm, ztftri, + ztfttr, ztpttf, ztpttr, ztrttf, ztrttp, + zgeequb, zgbequb, zsyequb, zpoequb, zheequb, + zbbcsd, zlapmr, zunbdb, zunbdb1, zunbdb2, zunbdb3, zunbdb4, + zunbdb5, zunbdb6, zuncsd, zuncsd2by1, + zgeqrt, zgeqrt2, zgeqrt3, zgemqrt, + ztpqrt, ztpqrt2, ztpmqrt, ztprfb, + # functions added for lapack-3.6.0 + + cgejsv, + cgesvdx, + cgesvj, + cgetrf2, + cgges3, + cggev3, + cgghd3, + cggsvd3, + cggsvp3, + cgsvj0, + cgsvj1, + clagge, + claghe, + clagsy, + clahilb, + clakf2, + clarge, + clarnd, + claror, + clarot, + clatm1, + clatm2, + clatm3, + clatm5, + clatm6, + clatme, + clatmr, + clatms, + clatmt, + cpotrf2, + csbmv, + cspr2, + csyr2, + cunm22, + dbdsvdx, + dgesvdx, + dgetrf2, + dgges3, + dggev3, + dgghd3, + dggsvd3, + dggsvp3, + dladiv2, + dlagge, + dlagsy, + dlahilb, + dlakf2, + dlaran, + dlarge, + dlarnd, + dlaror, + dlarot, + dlatm1, + dlatm2, + dlatm3, + dlatm5, + dlatm6, + dlatm7, + dlatme, + dlatmr, + dlatms, + dlatmt, + dorm22, + dpotrf2, + dsecnd, + sbdsvdx, + second, + sgesvdx, + sgetrf2, + sgges3, + sggev3, + sgghd3, + sggsvd3, + sggsvp3, + sladiv2, + slagge, + slagsy, + slahilb, + slakf2, + slaran, + slarge, + slarnd, + slaror, + slarot, + slatm1, + slatm2, + slatm3, + slatm5, + slatm6, + slatm7, + slatme, + slatmr, + slatms, + slatmt, + sorm22, + spotrf2, + zgejsv, + zgesvdx, + zgesvj, + zgetrf2, + zgges3, + zggev3, + zgghd3, + zggsvd3, + zggsvp3, + zgsvj0, + zgsvj1, + zlagge, + zlaghe, + zlagsy, + zlahilb, + zlakf2, + zlarge, + zlarnd, + zlaror, + zlarot, + zlatm1, + zlatm2, + zlatm3, + zlatm5, + zlatm6, + zlatme, + zlatmr, + zlatms, + zlatmt, + zpotrf2, + zsbmv, + zspr2, + zsyr2, + zunm22, + + # functions added for lapack-3.7.0 + + slarfy, + slasyf_rk, + ssyconvf_rook, + ssytf2_rk, + ssytrf_rk, + ssytrs_3, + ssytri_3, + ssytri_3x, + ssycon_3, + ssysv_rk, + slasyf_aa, + ssysv_aa, + ssytrf_aa, + ssytrs_aa, + strevc3, + sgelqt, + sgelqt3, + sgemlqt, + sgetsls, + sgeqr, + slatsqr, + slamtsqr, + sgemqr, + sgelq, + slaswlq, + slamswlq, + sgemlq, + stplqt, + stplqt2, + stpmlqt, + ssytrd_2stage, + ssytrd_sy2sb, + ssytrd_sb2st, + ssb2st_kernels, + ssyevd_2stage, + ssyev_2stage, + ssyevx_2stage, + ssyevr_2stage, + ssbev_2stage, + ssbevx_2stage, + ssbevd_2stage, + ssygv_2stage, + dlarfy, + dlasyf_rk, + dsyconvf, + dsyconvf_rook, + dsytf2_rk, + dsytrf_rk, + dsytrs_3, + dsytri_3, + dsytri_3x, + dsycon_3, + dsysv_rk, + dlasyf_aa, + dsysv_aa, + dsytrf_aa, + dsytrs_aa, + dtrevc3, + dgelqt, + dgelqt3, + dgemlqt, + dgetsls, + dgeqr, + dlatsqr, + dlamtsqr, + dgemqr, + dgelq, + dlaswlq, + dlamswlq, + dgemlq, + dtplqt, + dtplqt2, + dtpmlqt, + dsytrd_2stage, + dsytrd_sy2sb, + dsytrd_sb2st, + dsb2st_kernels, + dsyevd_2stage, + dsyev_2stage, + dsyevx_2stage, + dsyevr_2stage, + dsbev_2stage, + dsbevx_2stage, + dsbevd_2stage, + dsygv_2stage, + chetf2_rk, + chetrf_rk, + chetri_3, + chetri_3x, + chetrs_3, + checon_3, + chesv_rk, + chesv_aa, + chetrf_aa, + chetrs_aa, + clahef_aa, + clahef_rk, + clarfy, + clasyf_rk, + clasyf_aa, + csyconvf, + csyconvf_rook, + csytf2_rk, + csytrf_rk, + csytrf_aa, + csytrs_3, + csytrs_aa, + csytri_3, + csytri_3x, + csycon_3, + csysv_rk, + csysv_aa, + ctrevc3, + cgelqt, + cgelqt3, + cgemlqt, + cgetsls, + cgeqr, + clatsqr, + clamtsqr, + cgemqr, + cgelq, + claswlq, + clamswlq, + cgemlq, + ctplqt, + ctplqt2, + ctpmlqt, + chetrd_2stage, + chetrd_he2hb, + chetrd_hb2st, + chb2st_kernels, + cheevd_2stage, + cheev_2stage, + cheevx_2stage, + cheevr_2stage, + chbev_2stage, + chbevx_2stage, + chbevd_2stage, + chegv_2stage, + zhetf2_rk, + zhetrf_rk, + zhetri_3, + zhetri_3x, + zhetrs_3, + zhecon_3, + zhesv_rk, + zhesv_aa, + zhetrf_aa, + zhetrs_aa, + zlahef_aa, + zlahef_rk, + zlarfy, + zlasyf_rk, + zlasyf_aa, + zsyconvf, + zsyconvf_rook, + zsytrs_aa, + zsytf2_rk, + zsytrf_rk, + zsytrf_aa, + zsytrs_3, + zsytri_3, + zsytri_3x, + zsycon_3, + zsysv_rk, + zsysv_aa, + ztrevc3, + ztplqt, + ztplqt2, + ztpmlqt, + zgelqt, + zgelqt3, + zgemlqt, + zgetsls, + zgeqr, + zlatsqr, + zlamtsqr, + zgemqr, + zgelq, + zlaswlq, + zlamswlq, + zgemlq, + zhetrd_2stage, + zhetrd_he2hb, + zhetrd_hb2st, + zhb2st_kernels, + zheevd_2stage, + zheev_2stage, + zheevx_2stage, + zheevr_2stage, + zhbev_2stage, + zhbevx_2stage, + zhbevd_2stage, + zhegv_2stage, + sladiv1, + dladiv1, + iparam2stage, +); @lapack_extendedprecision_objs = ( - zposvxx, clagge, clatms, chesvxx, cposvxx, cgesvxx, ssyrfssx, csyrfsx, - dlagsy, dsysvxx, sporfsx, slatms, zlatms, zherfsx, csysvxx, - ); + zposvxx, clagge, clatms, chesvxx, cposvxx, cgesvxx, ssyrfssx, csyrfsx, + dlagsy, dsysvxx, sporfsx, slatms, zlatms, zherfsx, csysvxx, +); @lapack_deprecated_objs = ( cgegs, cggsvd, ctzrqf, dgeqpf, dlatzm, sgelsx, slahrd, zgegv, zggsvp, cgegv, cggsvp, dgegs, dggsvd, dtzrqf, sgeqpf, slatzm, zgelsx, zlahrd, cgelsx, clahrd, dgegv, dggsvp, sgegs, sggsvd, stzrqf, zgeqpf, zlatzm, cgeqpf, clatzm, dgelsx, dlahrd, sgegv, sggsvp, zgegs, zggsvd, ztzrqf, - ); +); + +@lapacke_deprecated_objs = ( + LAPACKE_cggsvp, + LAPACKE_cggsvp_work, + LAPACKE_dggsvp, + LAPACKE_dggsvp_work, + LAPACKE_sggsvp, + LAPACKE_sggsvp_work, + LAPACKE_zggsvp, + LAPACKE_zggsvp_work, + LAPACKE_cggsvd, + LAPACKE_cggsvd_work, + LAPACKE_dggsvd, + LAPACKE_dggsvd_work, + LAPACKE_sggsvd, + LAPACKE_sggsvd_work, + LAPACKE_zggsvd, + LAPACKE_zggsvd_work, + LAPACKE_cgeqpf, + LAPACKE_cgeqpf_work, + LAPACKE_dgeqpf, + LAPACKE_dgeqpf_work, + LAPACKE_sgeqpf, + LAPACKE_sgeqpf_work, + LAPACKE_zgeqpf, + LAPACKE_zgeqpf_work, +); + @lapackeobjs = ( - # LAPACK C interface routines. - # - # This list is prepared in a similar manner to @lapackobjs2, however the - # functions all begin with an uppercase prefix (with the exception of the - # make_complex_* routines). - # - # The functions corresponding to @(MATGEN_OBJ) and @(SRCX_OBJ) are not - # exported since the respective LAPACK routines are not built by default. - - # @(OBJ) from `lapack-3.4.1/lapacke/utils/Makefile` - LAPACKE_cgb_nancheck, - LAPACKE_cgb_trans, - LAPACKE_cge_nancheck, - LAPACKE_cge_trans, - LAPACKE_cgg_nancheck, - LAPACKE_cgg_trans, - LAPACKE_cgt_nancheck, - LAPACKE_chb_nancheck, - LAPACKE_chb_trans, - LAPACKE_che_nancheck, - LAPACKE_che_trans, - LAPACKE_chp_nancheck, - LAPACKE_chp_trans, - LAPACKE_chs_nancheck, - LAPACKE_chs_trans, - LAPACKE_c_nancheck, - LAPACKE_cpb_nancheck, - LAPACKE_cpb_trans, - LAPACKE_cpf_nancheck, - LAPACKE_cpf_trans, - LAPACKE_cpo_nancheck, - LAPACKE_cpo_trans, - LAPACKE_cpp_nancheck, - LAPACKE_cpp_trans, - LAPACKE_cpt_nancheck, - LAPACKE_csp_nancheck, - LAPACKE_csp_trans, - LAPACKE_cst_nancheck, - LAPACKE_csy_nancheck, - LAPACKE_csy_trans, - LAPACKE_ctb_nancheck, - LAPACKE_ctb_trans, - LAPACKE_ctf_nancheck, - LAPACKE_ctf_trans, - LAPACKE_ctp_nancheck, - LAPACKE_ctp_trans, - LAPACKE_ctr_nancheck, - LAPACKE_ctr_trans, - LAPACKE_dgb_nancheck, - LAPACKE_dgb_trans, - LAPACKE_dge_nancheck, - LAPACKE_dge_trans, - LAPACKE_dgg_nancheck, - LAPACKE_dgg_trans, - LAPACKE_dgt_nancheck, - LAPACKE_dhs_nancheck, - LAPACKE_dhs_trans, - LAPACKE_d_nancheck, - LAPACKE_dpb_nancheck, - LAPACKE_dpb_trans, - LAPACKE_dpf_nancheck, - LAPACKE_dpf_trans, - LAPACKE_dpo_nancheck, - LAPACKE_dpo_trans, - LAPACKE_dpp_nancheck, - LAPACKE_dpp_trans, - LAPACKE_dpt_nancheck, - LAPACKE_dsb_nancheck, - LAPACKE_dsb_trans, - LAPACKE_dsp_nancheck, - LAPACKE_dsp_trans, - LAPACKE_dst_nancheck, - LAPACKE_dsy_nancheck, - LAPACKE_dsy_trans, - LAPACKE_dtb_nancheck, - LAPACKE_dtb_trans, - LAPACKE_dtf_nancheck, - LAPACKE_dtf_trans, - LAPACKE_dtp_nancheck, - LAPACKE_dtp_trans, - LAPACKE_dtr_nancheck, - LAPACKE_dtr_trans, - LAPACKE_lsame, - LAPACKE_sgb_nancheck, - LAPACKE_sgb_trans, - LAPACKE_sge_nancheck, - LAPACKE_sge_trans, - LAPACKE_sgg_nancheck, - LAPACKE_sgg_trans, - LAPACKE_sgt_nancheck, - LAPACKE_shs_nancheck, - LAPACKE_shs_trans, - LAPACKE_s_nancheck, - LAPACKE_spb_nancheck, - LAPACKE_spb_trans, - LAPACKE_spf_nancheck, - LAPACKE_spf_trans, - LAPACKE_spo_nancheck, - LAPACKE_spo_trans, - LAPACKE_spp_nancheck, - LAPACKE_spp_trans, - LAPACKE_spt_nancheck, - LAPACKE_ssb_nancheck, - LAPACKE_ssb_trans, - LAPACKE_ssp_nancheck, - LAPACKE_ssp_trans, - LAPACKE_sst_nancheck, - LAPACKE_ssy_nancheck, - LAPACKE_ssy_trans, - LAPACKE_stb_nancheck, - LAPACKE_stb_trans, - LAPACKE_stf_nancheck, - LAPACKE_stf_trans, - LAPACKE_stp_nancheck, - LAPACKE_stp_trans, - LAPACKE_str_nancheck, - LAPACKE_str_trans, - LAPACKE_xerbla, - LAPACKE_zgb_nancheck, - LAPACKE_zgb_trans, - LAPACKE_zge_nancheck, - LAPACKE_zge_trans, - LAPACKE_zgg_nancheck, - LAPACKE_zgg_trans, - LAPACKE_zgt_nancheck, - LAPACKE_zhb_nancheck, - LAPACKE_zhb_trans, - LAPACKE_zhe_nancheck, - LAPACKE_zhe_trans, - LAPACKE_zhp_nancheck, - LAPACKE_zhp_trans, - LAPACKE_zhs_nancheck, - LAPACKE_zhs_trans, - LAPACKE_z_nancheck, - LAPACKE_zpb_nancheck, - LAPACKE_zpb_trans, - LAPACKE_zpf_nancheck, - LAPACKE_zpf_trans, - LAPACKE_zpo_nancheck, - LAPACKE_zpo_trans, - LAPACKE_zpp_nancheck, - LAPACKE_zpp_trans, - LAPACKE_zpt_nancheck, - LAPACKE_zsp_nancheck, - LAPACKE_zsp_trans, - LAPACKE_zst_nancheck, - LAPACKE_zsy_nancheck, - LAPACKE_zsy_trans, - LAPACKE_ztb_nancheck, - LAPACKE_ztb_trans, - LAPACKE_ztf_nancheck, - LAPACKE_ztf_trans, - LAPACKE_ztp_nancheck, - LAPACKE_ztp_trans, - LAPACKE_ztr_nancheck, - LAPACKE_ztr_trans, - lapack_make_complex_float, - lapack_make_complex_double, - - # @(SRC_OBJ) from `lapack-3.5.0/lapacke/src/Makefile` + # LAPACK C interface routines. + # + # This list is prepared in a similar manner to @lapackobjs2, however the + # functions all begin with an uppercase prefix (with the exception of the + # make_complex_* routines). + # + # The functions corresponding to @(MATGEN_OBJ) and @(SRCX_OBJ) are not + # exported since the respective LAPACK routines are not built by default. + + # @(OBJ) from `lapack-3.4.1/lapacke/utils/Makefile` + LAPACKE_cgb_nancheck, + LAPACKE_cgb_trans, + LAPACKE_cge_nancheck, + LAPACKE_cge_trans, + LAPACKE_cgg_nancheck, + LAPACKE_cgg_trans, + LAPACKE_cgt_nancheck, + LAPACKE_chb_nancheck, + LAPACKE_chb_trans, + LAPACKE_che_nancheck, + LAPACKE_che_trans, + LAPACKE_chp_nancheck, + LAPACKE_chp_trans, + LAPACKE_chs_nancheck, + LAPACKE_chs_trans, + LAPACKE_c_nancheck, + LAPACKE_cpb_nancheck, + LAPACKE_cpb_trans, + LAPACKE_cpf_nancheck, + LAPACKE_cpf_trans, + LAPACKE_cpo_nancheck, + LAPACKE_cpo_trans, + LAPACKE_cpp_nancheck, + LAPACKE_cpp_trans, + LAPACKE_cpt_nancheck, + LAPACKE_csp_nancheck, + LAPACKE_csp_trans, + LAPACKE_cst_nancheck, + LAPACKE_csy_nancheck, + LAPACKE_csy_trans, + LAPACKE_ctb_nancheck, + LAPACKE_ctb_trans, + LAPACKE_ctf_nancheck, + LAPACKE_ctf_trans, + LAPACKE_ctp_nancheck, + LAPACKE_ctp_trans, + LAPACKE_ctr_nancheck, + LAPACKE_ctr_trans, + LAPACKE_dgb_nancheck, + LAPACKE_dgb_trans, + LAPACKE_dge_nancheck, + LAPACKE_dge_trans, + LAPACKE_dgg_nancheck, + LAPACKE_dgg_trans, + LAPACKE_dgt_nancheck, + LAPACKE_dhs_nancheck, + LAPACKE_dhs_trans, + LAPACKE_d_nancheck, + LAPACKE_dpb_nancheck, + LAPACKE_dpb_trans, + LAPACKE_dpf_nancheck, + LAPACKE_dpf_trans, + LAPACKE_dpo_nancheck, + LAPACKE_dpo_trans, + LAPACKE_dpp_nancheck, + LAPACKE_dpp_trans, + LAPACKE_dpt_nancheck, + LAPACKE_dsb_nancheck, + LAPACKE_dsb_trans, + LAPACKE_dsp_nancheck, + LAPACKE_dsp_trans, + LAPACKE_dst_nancheck, + LAPACKE_dsy_nancheck, + LAPACKE_dsy_trans, + LAPACKE_dtb_nancheck, + LAPACKE_dtb_trans, + LAPACKE_dtf_nancheck, + LAPACKE_dtf_trans, + LAPACKE_dtp_nancheck, + LAPACKE_dtp_trans, + LAPACKE_dtr_nancheck, + LAPACKE_dtr_trans, + LAPACKE_lsame, + LAPACKE_sgb_nancheck, + LAPACKE_sgb_trans, + LAPACKE_sge_nancheck, + LAPACKE_sge_trans, + LAPACKE_sgg_nancheck, + LAPACKE_sgg_trans, + LAPACKE_sgt_nancheck, + LAPACKE_shs_nancheck, + LAPACKE_shs_trans, + LAPACKE_s_nancheck, + LAPACKE_spb_nancheck, + LAPACKE_spb_trans, + LAPACKE_spf_nancheck, + LAPACKE_spf_trans, + LAPACKE_spo_nancheck, + LAPACKE_spo_trans, + LAPACKE_spp_nancheck, + LAPACKE_spp_trans, + LAPACKE_spt_nancheck, + LAPACKE_ssb_nancheck, + LAPACKE_ssb_trans, + LAPACKE_ssp_nancheck, + LAPACKE_ssp_trans, + LAPACKE_sst_nancheck, + LAPACKE_ssy_nancheck, + LAPACKE_ssy_trans, + LAPACKE_stb_nancheck, + LAPACKE_stb_trans, + LAPACKE_stf_nancheck, + LAPACKE_stf_trans, + LAPACKE_stp_nancheck, + LAPACKE_stp_trans, + LAPACKE_str_nancheck, + LAPACKE_str_trans, + LAPACKE_xerbla, + LAPACKE_zgb_nancheck, + LAPACKE_zgb_trans, + LAPACKE_zge_nancheck, + LAPACKE_zge_trans, + LAPACKE_zgg_nancheck, + LAPACKE_zgg_trans, + LAPACKE_zgt_nancheck, + LAPACKE_zhb_nancheck, + LAPACKE_zhb_trans, + LAPACKE_zhe_nancheck, + LAPACKE_zhe_trans, + LAPACKE_zhp_nancheck, + LAPACKE_zhp_trans, + LAPACKE_zhs_nancheck, + LAPACKE_zhs_trans, + LAPACKE_z_nancheck, + LAPACKE_zpb_nancheck, + LAPACKE_zpb_trans, + LAPACKE_zpf_nancheck, + LAPACKE_zpf_trans, + LAPACKE_zpo_nancheck, + LAPACKE_zpo_trans, + LAPACKE_zpp_nancheck, + LAPACKE_zpp_trans, + LAPACKE_zpt_nancheck, + LAPACKE_zsp_nancheck, + LAPACKE_zsp_trans, + LAPACKE_zst_nancheck, + LAPACKE_zsy_nancheck, + LAPACKE_zsy_trans, + LAPACKE_ztb_nancheck, + LAPACKE_ztb_trans, + LAPACKE_ztf_nancheck, + LAPACKE_ztf_trans, + LAPACKE_ztp_nancheck, + LAPACKE_ztp_trans, + LAPACKE_ztr_nancheck, + LAPACKE_ztr_trans, + lapack_make_complex_float, + lapack_make_complex_double, + + # @(SRC_OBJ) from `lapack-3.5.0/lapacke/src/Makefile` LAPACKE_cbbcsd, LAPACKE_cbbcsd_work, LAPACKE_cbdsqr, @@ -2714,288 +2974,464 @@ LAPACKE_csyr_work, LAPACKE_ilaver, - ## @(SRCX_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` - ## Not exported: requires LAPACKE_EXTENDED to be set and depends on the - ## corresponding LAPACK extended precision routines. - #LAPACKE_cgbrfsx, - #LAPACKE_cporfsx, - #LAPACKE_dgerfsx, - #LAPACKE_sgbrfsx, - #LAPACKE_ssyrfsx, - #LAPACKE_zherfsx, - #LAPACKE_cgbrfsx_work, - #LAPACKE_cporfsx_work, - #LAPACKE_dgerfsx_work, - #LAPACKE_sgbrfsx_work, - #LAPACKE_ssyrfsx_work, - #LAPACKE_zherfsx_work, - #LAPACKE_cgerfsx, - #LAPACKE_csyrfsx, - #LAPACKE_dporfsx, - #LAPACKE_sgerfsx, - #LAPACKE_zgbrfsx, - #LAPACKE_zporfsx, - #LAPACKE_cgerfsx_work, - #LAPACKE_csyrfsx_work, - #LAPACKE_dporfsx_work, - #LAPACKE_sgerfsx_work, - #LAPACKE_zgbrfsx_work, - #LAPACKE_zporfsx_work, - #LAPACKE_cherfsx, - #LAPACKE_dgbrfsx, - #LAPACKE_dsyrfsx, - #LAPACKE_sporfsx, - #LAPACKE_zgerfsx, - #LAPACKE_zsyrfsx, - #LAPACKE_cherfsx_work, - #LAPACKE_dgbrfsx_work, - #LAPACKE_dsyrfsx_work, - #LAPACKE_sporfsx_work, - #LAPACKE_zgerfsx_work, - #LAPACKE_zsyrfsx_work, - #LAPACKE_cgbsvxx, - #LAPACKE_cposvxx, - #LAPACKE_dgesvxx, - #LAPACKE_sgbsvxx, - #LAPACKE_ssysvxx, - #LAPACKE_zhesvxx, - #LAPACKE_cgbsvxx_work, - #LAPACKE_cposvxx_work, - #LAPACKE_dgesvxx_work, - #LAPACKE_sgbsvxx_work, - #LAPACKE_ssysvxx_work, - #LAPACKE_zhesvxx_work, - #LAPACKE_cgesvxx, - #LAPACKE_csysvxx, - #LAPACKE_dposvxx, - #LAPACKE_sgesvxx, - #LAPACKE_zgbsvxx, - #LAPACKE_zposvxx, - #LAPACKE_cgesvxx_work, - #LAPACKE_csysvxx_work, - #LAPACKE_dposvxx_work, - #LAPACKE_sgesvxx_work, - #LAPACKE_zgbsvxx_work, - #LAPACKE_zposvxx_work, - #LAPACKE_chesvxx, - #LAPACKE_dgbsvxx, - #LAPACKE_dsysvxx, - #LAPACKE_sposvxx, - #LAPACKE_zgesvxx, - #LAPACKE_zsysvxx, - #LAPACKE_chesvxx_work, - #LAPACKE_dgbsvxx_work, - #LAPACKE_dsysvxx_work, - #LAPACKE_sposvxx_work, - #LAPACKE_zgesvxx_work, - #LAPACKE_zsysvxx_work, - - ## @(MATGEN_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` - ## Not exported: requires LAPACKE_TESTING to be set and depends on libtmg - ## (see `lapack-3.4.1/TESTING/MATGEN`). - LAPACKE_clatms, - LAPACKE_clatms_work, - LAPACKE_dlatms, - LAPACKE_dlatms_work, - LAPACKE_slatms, - LAPACKE_slatms_work, - LAPACKE_zlatms, - LAPACKE_zlatms_work, - LAPACKE_clagge, - LAPACKE_clagge_work, - LAPACKE_dlagge, - LAPACKE_dlagge_work, - LAPACKE_slagge, - LAPACKE_slagge_work, - LAPACKE_zlagge, - LAPACKE_zlagge_work, - LAPACKE_claghe, - LAPACKE_claghe_work, - LAPACKE_zlaghe, - LAPACKE_zlaghe_work, - LAPACKE_clagsy, - LAPACKE_clagsy_work, - LAPACKE_dlagsy, - LAPACKE_dlagsy_work, - LAPACKE_slagsy, - LAPACKE_slagsy_work, - LAPACKE_zlagsy, - LAPACKE_zlagsy_work, - ## new function from lapack-3.6.0 - - LAPACKE_cgejsv, - LAPACKE_cgejsv_work, - LAPACKE_cgesvdx, - LAPACKE_cgesvdx_work, - LAPACKE_cgesvj, - LAPACKE_cgesvj_work, - LAPACKE_cgetrf2, - LAPACKE_cgetrf2_work, - LAPACKE_cgges3, - LAPACKE_cgges3_work, - LAPACKE_cggev3, - LAPACKE_cggev3_work, - LAPACKE_cgghd3, - LAPACKE_cgghd3_work, - LAPACKE_cggsvd3, - LAPACKE_cggsvd3_work, - LAPACKE_cggsvp3, - LAPACKE_cggsvp3_work, - LAPACKE_chetrf_rook, - LAPACKE_chetrf_rook_work, - LAPACKE_chetrs_rook, - LAPACKE_chetrs_rook_work, - LAPACKE_clapmt, - LAPACKE_clapmt_work, - LAPACKE_clascl, - LAPACKE_clascl_work, - LAPACKE_cpotrf2, - LAPACKE_cpotrf2_work, - LAPACKE_csytrf_rook, - LAPACKE_csytrf_rook_work, - LAPACKE_csytrs_rook, - LAPACKE_csytrs_rook_work, - LAPACKE_cuncsd2by1, - LAPACKE_cuncsd2by1_work, - LAPACKE_dbdsvdx, - LAPACKE_dbdsvdx_work, - LAPACKE_dgesvdx, - LAPACKE_dgesvdx_work, - LAPACKE_dgetrf2, - LAPACKE_dgetrf2_work, - LAPACKE_dgges3, - LAPACKE_dgges3_work, - LAPACKE_dggev3, - LAPACKE_dggev3_work, - LAPACKE_dgghd3, - LAPACKE_dgghd3_work, - LAPACKE_dggsvd3, - LAPACKE_dggsvd3_work, - LAPACKE_dggsvp3, - LAPACKE_dggsvp3_work, - LAPACKE_dlapmt, - LAPACKE_dlapmt_work, - LAPACKE_dlascl, - LAPACKE_dlascl_work, - LAPACKE_dorcsd2by1, - LAPACKE_dorcsd2by1_work, - LAPACKE_dpotrf2, - LAPACKE_dpotrf2_work, - LAPACKE_dsytrf_rook, - LAPACKE_dsytrf_rook_work, - LAPACKE_dsytrs_rook, - LAPACKE_dsytrs_rook_work, - LAPACKE_sbdsvdx, - LAPACKE_sbdsvdx_work, - LAPACKE_sgesvdx, - LAPACKE_sgesvdx_work, - LAPACKE_sgetrf2, - LAPACKE_sgetrf2_work, - LAPACKE_sgges3, - LAPACKE_sgges3_work, - LAPACKE_sggev3, - LAPACKE_sggev3_work, - LAPACKE_sgghd3, - LAPACKE_sgghd3_work, - LAPACKE_sggsvd3, - LAPACKE_sggsvd3_work, - LAPACKE_sggsvp3, - LAPACKE_sggsvp3_work, - LAPACKE_slapmt, - LAPACKE_slapmt_work, - LAPACKE_slascl, - LAPACKE_slascl_work, - LAPACKE_sorcsd2by1, - LAPACKE_sorcsd2by1_work, - LAPACKE_spotrf2, - LAPACKE_spotrf2_work, - LAPACKE_ssytrf_rook, - LAPACKE_ssytrf_rook_work, - LAPACKE_ssytrs_rook, - LAPACKE_ssytrs_rook_work, - LAPACKE_stpqrt, - LAPACKE_stpqrt_work, - LAPACKE_zgejsv, - LAPACKE_zgejsv_work, - LAPACKE_zgesvdx, - LAPACKE_zgesvdx_work, - LAPACKE_zgesvj, - LAPACKE_zgesvj_work, - LAPACKE_zgetrf2, - LAPACKE_zgetrf2_work, - LAPACKE_zgges3, - LAPACKE_zgges3_work, - LAPACKE_zggev3, - LAPACKE_zggev3_work, - LAPACKE_zgghd3, - LAPACKE_zgghd3_work, - LAPACKE_zggsvd3, - LAPACKE_zggsvd3_work, - LAPACKE_zggsvp3, - LAPACKE_zggsvp3_work, - LAPACKE_zhetrf_rook, - LAPACKE_zhetrf_rook_work, - LAPACKE_zhetrs_rook, - LAPACKE_zhetrs_rook_work, - LAPACKE_zlapmt, - LAPACKE_zlapmt_work, - LAPACKE_zlascl, - LAPACKE_zlascl_work, - LAPACKE_zpotrf2, - LAPACKE_zpotrf2_work, - LAPACKE_zsytrf_rook, - LAPACKE_zsytrf_rook_work, - LAPACKE_zsytrs_rook, - LAPACKE_zsytrs_rook_work, - LAPACKE_zuncsd2by1, - LAPACKE_zuncsd2by1_work - ); + ## @(SRCX_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` + ## Not exported: requires LAPACKE_EXTENDED to be set and depends on the + ## corresponding LAPACK extended precision routines. + #LAPACKE_cgbrfsx, + #LAPACKE_cporfsx, + #LAPACKE_dgerfsx, + #LAPACKE_sgbrfsx, + #LAPACKE_ssyrfsx, + #LAPACKE_zherfsx, + #LAPACKE_cgbrfsx_work, + #LAPACKE_cporfsx_work, + #LAPACKE_dgerfsx_work, + #LAPACKE_sgbrfsx_work, + #LAPACKE_ssyrfsx_work, + #LAPACKE_zherfsx_work, + #LAPACKE_cgerfsx, + #LAPACKE_csyrfsx, + #LAPACKE_dporfsx, + #LAPACKE_sgerfsx, + #LAPACKE_zgbrfsx, + #LAPACKE_zporfsx, + #LAPACKE_cgerfsx_work, + #LAPACKE_csyrfsx_work, + #LAPACKE_dporfsx_work, + #LAPACKE_sgerfsx_work, + #LAPACKE_zgbrfsx_work, + #LAPACKE_zporfsx_work, + #LAPACKE_cherfsx, + #LAPACKE_dgbrfsx, + #LAPACKE_dsyrfsx, + #LAPACKE_sporfsx, + #LAPACKE_zgerfsx, + #LAPACKE_zsyrfsx, + #LAPACKE_cherfsx_work, + #LAPACKE_dgbrfsx_work, + #LAPACKE_dsyrfsx_work, + #LAPACKE_sporfsx_work, + #LAPACKE_zgerfsx_work, + #LAPACKE_zsyrfsx_work, + #LAPACKE_cgbsvxx, + #LAPACKE_cposvxx, + #LAPACKE_dgesvxx, + #LAPACKE_sgbsvxx, + #LAPACKE_ssysvxx, + #LAPACKE_zhesvxx, + #LAPACKE_cgbsvxx_work, + #LAPACKE_cposvxx_work, + #LAPACKE_dgesvxx_work, + #LAPACKE_sgbsvxx_work, + #LAPACKE_ssysvxx_work, + #LAPACKE_zhesvxx_work, + #LAPACKE_cgesvxx, + #LAPACKE_csysvxx, + #LAPACKE_dposvxx, + #LAPACKE_sgesvxx, + #LAPACKE_zgbsvxx, + #LAPACKE_zposvxx, + #LAPACKE_cgesvxx_work, + #LAPACKE_csysvxx_work, + #LAPACKE_dposvxx_work, + #LAPACKE_sgesvxx_work, + #LAPACKE_zgbsvxx_work, + #LAPACKE_zposvxx_work, + #LAPACKE_chesvxx, + #LAPACKE_dgbsvxx, + #LAPACKE_dsysvxx, + #LAPACKE_sposvxx, + #LAPACKE_zgesvxx, + #LAPACKE_zsysvxx, + #LAPACKE_chesvxx_work, + #LAPACKE_dgbsvxx_work, + #LAPACKE_dsysvxx_work, + #LAPACKE_sposvxx_work, + #LAPACKE_zgesvxx_work, + #LAPACKE_zsysvxx_work, + + ## @(MATGEN_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` + ## Not exported: requires LAPACKE_TESTING to be set and depends on libtmg + ## (see `lapack-3.4.1/TESTING/MATGEN`). + LAPACKE_clatms, + LAPACKE_clatms_work, + LAPACKE_dlatms, + LAPACKE_dlatms_work, + LAPACKE_slatms, + LAPACKE_slatms_work, + LAPACKE_zlatms, + LAPACKE_zlatms_work, + LAPACKE_clagge, + LAPACKE_clagge_work, + LAPACKE_dlagge, + LAPACKE_dlagge_work, + LAPACKE_slagge, + LAPACKE_slagge_work, + LAPACKE_zlagge, + LAPACKE_zlagge_work, + LAPACKE_claghe, + LAPACKE_claghe_work, + LAPACKE_zlaghe, + LAPACKE_zlaghe_work, + LAPACKE_clagsy, + LAPACKE_clagsy_work, + LAPACKE_dlagsy, + LAPACKE_dlagsy_work, + LAPACKE_slagsy, + LAPACKE_slagsy_work, + LAPACKE_zlagsy, + LAPACKE_zlagsy_work, + ## new function from lapack-3.6.0 + + LAPACKE_cgejsv, + LAPACKE_cgejsv_work, + LAPACKE_cgesvdx, + LAPACKE_cgesvdx_work, + LAPACKE_cgesvj, + LAPACKE_cgesvj_work, + LAPACKE_cgetrf2, + LAPACKE_cgetrf2_work, + LAPACKE_cgges3, + LAPACKE_cgges3_work, + LAPACKE_cggev3, + LAPACKE_cggev3_work, + LAPACKE_cgghd3, + LAPACKE_cgghd3_work, + LAPACKE_cggsvd3, + LAPACKE_cggsvd3_work, + LAPACKE_cggsvp3, + LAPACKE_cggsvp3_work, + LAPACKE_chetrf_rook, + LAPACKE_chetrf_rook_work, + LAPACKE_chetrs_rook, + LAPACKE_chetrs_rook_work, + LAPACKE_clapmt, + LAPACKE_clapmt_work, + LAPACKE_clascl, + LAPACKE_clascl_work, + LAPACKE_cpotrf2, + LAPACKE_cpotrf2_work, + LAPACKE_csytrf_rook, + LAPACKE_csytrf_rook_work, + LAPACKE_csytrs_rook, + LAPACKE_csytrs_rook_work, + LAPACKE_cuncsd2by1, + LAPACKE_cuncsd2by1_work, + LAPACKE_dbdsvdx, + LAPACKE_dbdsvdx_work, + LAPACKE_dgesvdx, + LAPACKE_dgesvdx_work, + LAPACKE_dgetrf2, + LAPACKE_dgetrf2_work, + LAPACKE_dgges3, + LAPACKE_dgges3_work, + LAPACKE_dggev3, + LAPACKE_dggev3_work, + LAPACKE_dgghd3, + LAPACKE_dgghd3_work, + LAPACKE_dggsvd3, + LAPACKE_dggsvd3_work, + LAPACKE_dggsvp3, + LAPACKE_dggsvp3_work, + LAPACKE_dlapmt, + LAPACKE_dlapmt_work, + LAPACKE_dlascl, + LAPACKE_dlascl_work, + LAPACKE_dorcsd2by1, + LAPACKE_dorcsd2by1_work, + LAPACKE_dpotrf2, + LAPACKE_dpotrf2_work, + LAPACKE_dsytrf_rook, + LAPACKE_dsytrf_rook_work, + LAPACKE_dsytrs_rook, + LAPACKE_dsytrs_rook_work, + LAPACKE_sbdsvdx, + LAPACKE_sbdsvdx_work, + LAPACKE_sgesvdx, + LAPACKE_sgesvdx_work, + LAPACKE_sgetrf2, + LAPACKE_sgetrf2_work, + LAPACKE_sgges3, + LAPACKE_sgges3_work, + LAPACKE_sggev3, + LAPACKE_sggev3_work, + LAPACKE_sgghd3, + LAPACKE_sgghd3_work, + LAPACKE_sggsvd3, + LAPACKE_sggsvd3_work, + LAPACKE_sggsvp3, + LAPACKE_sggsvp3_work, + LAPACKE_slapmt, + LAPACKE_slapmt_work, + LAPACKE_slascl, + LAPACKE_slascl_work, + LAPACKE_sorcsd2by1, + LAPACKE_sorcsd2by1_work, + LAPACKE_spotrf2, + LAPACKE_spotrf2_work, + LAPACKE_ssytrf_rook, + LAPACKE_ssytrf_rook_work, + LAPACKE_ssytrs_rook, + LAPACKE_ssytrs_rook_work, + LAPACKE_stpqrt, + LAPACKE_stpqrt_work, + LAPACKE_zgejsv, + LAPACKE_zgejsv_work, + LAPACKE_zgesvdx, + LAPACKE_zgesvdx_work, + LAPACKE_zgesvj, + LAPACKE_zgesvj_work, + LAPACKE_zgetrf2, + LAPACKE_zgetrf2_work, + LAPACKE_zgges3, + LAPACKE_zgges3_work, + LAPACKE_zggev3, + LAPACKE_zggev3_work, + LAPACKE_zgghd3, + LAPACKE_zgghd3_work, + LAPACKE_zggsvd3, + LAPACKE_zggsvd3_work, + LAPACKE_zggsvp3, + LAPACKE_zggsvp3_work, + LAPACKE_zhetrf_rook, + LAPACKE_zhetrf_rook_work, + LAPACKE_zhetrs_rook, + LAPACKE_zhetrs_rook_work, + LAPACKE_zlapmt, + LAPACKE_zlapmt_work, + LAPACKE_zlascl, + LAPACKE_zlascl_work, + LAPACKE_zpotrf2, + LAPACKE_zpotrf2_work, + LAPACKE_zsytrf_rook, + LAPACKE_zsytrf_rook_work, + LAPACKE_zsytrs_rook, + LAPACKE_zsytrs_rook_work, + LAPACKE_zuncsd2by1, + LAPACKE_zuncsd2by1_work, + + ## new function from lapack-3.7.0 + + LAPACKE_cgemqr, + LAPACKE_cgemqr_work, + LAPACKE_cgetsls, + LAPACKE_cgetsls_work, + LAPACKE_chbev_2stage, + LAPACKE_chbev_2stage_work, + LAPACKE_chbevd_2stage, + LAPACKE_chbevd_2stage_work, + LAPACKE_chbevx_2stage, + LAPACKE_chbevx_2stage_work, + LAPACKE_checon_3, + LAPACKE_checon_3_work, + LAPACKE_cheev_2stage, + LAPACKE_cheev_2stage_work, + LAPACKE_cheevd_2stage, + LAPACKE_cheevd_2stage_work, + LAPACKE_cheevr_2stage, + LAPACKE_cheevr_2stage_work, + LAPACKE_cheevx_2stage, + LAPACKE_cheevx_2stage_work, + LAPACKE_chegv_2stage, + LAPACKE_chegv_2stage_work, + LAPACKE_chesv_aa, + LAPACKE_chesv_aa_work, + LAPACKE_chesv_rk, + LAPACKE_chesv_rk_work, + LAPACKE_chetrf_aa, + LAPACKE_chetrf_aa_work, + LAPACKE_chetrf_rk, + LAPACKE_chetrf_rk_work, + LAPACKE_chetri_3, + LAPACKE_chetri_3_work, + LAPACKE_chetrs_aa, + LAPACKE_chetrs_aa_work, + LAPACKE_chetrs_3, + LAPACKE_chetrs_3_work, + LAPACKE_csycon_3, + LAPACKE_csycon_3_work, + LAPACKE_csysv_aa, + LAPACKE_csysv_aa_work, + LAPACKE_csysv_rk, + LAPACKE_csysv_rk_work, + LAPACKE_csytrf_aa, + LAPACKE_csytrf_aa_work, + LAPACKE_csytrf_rk, + LAPACKE_csytrf_rk_work, + LAPACKE_csytri_3, + LAPACKE_csytri_3_work, + LAPACKE_csytrs_aa, + LAPACKE_csytrs_aa_work, + LAPACKE_csytrs_3, + LAPACKE_csytrs_3_work, + LAPACKE_dgemqr, + LAPACKE_dgemqr_work, + LAPACKE_dgetsls, + LAPACKE_dgetsls_work, + LAPACKE_dsbev_2stage, + LAPACKE_dsbev_2stage_work, + LAPACKE_dsbevd_2stage, + LAPACKE_dsbevd_2stage_work, + LAPACKE_dsbevx_2stage, + LAPACKE_dsbevx_2stage_work, + LAPACKE_dsycon_3, + LAPACKE_dsycon_3_work, + LAPACKE_dsyev_2stage, + LAPACKE_dsyev_2stage_work, + LAPACKE_dsyevd_2stage, + LAPACKE_dsyevd_2stage_work, + LAPACKE_dsyevr_2stage, + LAPACKE_dsyevr_2stage_work, + LAPACKE_dsyevx_2stage, + LAPACKE_dsyevx_2stage_work, + LAPACKE_dsygv_2stage, + LAPACKE_dsygv_2stage_work, + LAPACKE_dsysv_aa, + LAPACKE_dsysv_aa_work, + LAPACKE_dsysv_rk, + LAPACKE_dsysv_rk_work, + LAPACKE_dsytrf_aa, + LAPACKE_dsytrf_aa_work, + LAPACKE_dsytrf_rk, + LAPACKE_dsytrf_rk_work, + LAPACKE_dsytri_3, + LAPACKE_dsytri_3_work, + LAPACKE_dsytrs_aa, + LAPACKE_dsytrs_aa_work, + LAPACKE_dsytrs_3, + LAPACKE_dsytrs_3_work, + LAPACKE_sgemqr, + LAPACKE_sgemqr_work, + LAPACKE_sgetsls, + LAPACKE_sgetsls_work, + LAPACKE_ssbev_2stage, + LAPACKE_ssbev_2stage_work, + LAPACKE_ssbevd_2stage, + LAPACKE_ssbevd_2stage_work, + LAPACKE_ssbevx_2stage, + LAPACKE_ssbevx_2stage_work, + LAPACKE_ssycon_3, + LAPACKE_ssycon_3_work, + LAPACKE_ssyev_2stage, + LAPACKE_ssyev_2stage_work, + LAPACKE_ssyevd_2stage, + LAPACKE_ssyevd_2stage_work, + LAPACKE_ssyevr_2stage, + LAPACKE_ssyevr_2stage_work, + LAPACKE_ssyevx_2stage, + LAPACKE_ssyevx_2stage_work, + LAPACKE_ssygv_2stage, + LAPACKE_ssygv_2stage_work, + LAPACKE_ssysv_aa, + LAPACKE_ssysv_aa_work, + LAPACKE_ssysv_rk, + LAPACKE_ssysv_rk_work, + LAPACKE_ssytrf_aa, + LAPACKE_ssytrf_aa_work, + LAPACKE_ssytrf_rk, + LAPACKE_ssytrf_rk_work, + LAPACKE_ssytri_3, + LAPACKE_ssytri_3_work, + LAPACKE_ssytrs_aa, + LAPACKE_ssytrs_aa_work, + LAPACKE_ssytrs_3, + LAPACKE_ssytrs_3_work, + LAPACKE_zgemqr, + LAPACKE_zgemqr_work, + LAPACKE_zgetsls, + LAPACKE_zgetsls_work, + LAPACKE_zhbev_2stage, + LAPACKE_zhbev_2stage_work, + LAPACKE_zhbevd_2stage, + LAPACKE_zhbevd_2stage_work, + LAPACKE_zhbevx_2stage, + LAPACKE_zhbevx_2stage_work, + LAPACKE_zhecon_3, + LAPACKE_zhecon_3_work, + LAPACKE_zheev_2stage, + LAPACKE_zheev_2stage_work, + LAPACKE_zheevd_2stage, + LAPACKE_zheevd_2stage_work, + LAPACKE_zheevr_2stage, + LAPACKE_zheevr_2stage_work, + LAPACKE_zheevx_2stage, + LAPACKE_zheevx_2stage_work, + LAPACKE_zhegv_2stage, + LAPACKE_zhegv_2stage_work, + LAPACKE_zhesv_aa, + LAPACKE_zhesv_aa_work, + LAPACKE_zhesv_rk, + LAPACKE_zhesv_rk_work, + LAPACKE_zhetrf_aa, + LAPACKE_zhetrf_aa_work, + LAPACKE_zhetrf_rk, + LAPACKE_zhetrf_rk_work, + LAPACKE_zhetri_3, + LAPACKE_zhetri_3_work, + LAPACKE_zhetrs_aa, + LAPACKE_zhetrs_aa_work, + LAPACKE_zhetrs_3, + LAPACKE_zhetrs_3_work, + LAPACKE_zsycon_3, + LAPACKE_zsycon_3_work, + LAPACKE_zsysv_aa, + LAPACKE_zsysv_aa_work, + LAPACKE_zsysv_rk, + LAPACKE_zsysv_rk_work, + LAPACKE_zsytrf_aa, + LAPACKE_zsytrf_aa_work, + LAPACKE_zsytrf_rk, + LAPACKE_zsytrf_rk_work, + LAPACKE_zsytri_3, + LAPACKE_zsytri_3_work, + LAPACKE_zsytrs_aa, + LAPACKE_zsytrs_aa_work, + LAPACKE_zsytrs_3, + LAPACKE_zsytrs_3_work, +); #These function may need 2 underscores. -@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype, slasyf_rook, - ssytf2_rook, ssytrf_rook, ssytrs_rook, - ssytri_rook, ssycon_rook, ssysv_rook, - chetf2_rook, chetrf_rook, chetri_rook, - chetrs_rook, checon_rook, chesv_rook, - clahef_rook, clasyf_rook, - csytf2_rook, csytrf_rook, csytrs_rook, - csytri_rook, csycon_rook, csysv_rook, - dlasyf_rook, - dsytf2_rook, dsytrf_rook, dsytrs_rook, - dsytri_rook, dsycon_rook, dsysv_rook, - zhetf2_rook, zhetrf_rook, zhetri_rook, - zhetrs_rook, zhecon_rook, zhesv_rook, - zlahef_rook, zlasyf_rook, - zsytf2_rook, zsytrf_rook, zsytrs_rook, - zsytri_rook, zsycon_rook, zsysv_rook, - - - - ); +@lapack_embeded_underscore_objs=( + xerbla_array, chla_transtype, slasyf_rook, + ssytf2_rook, ssytrf_rook, ssytrs_rook, + ssytri_rook, ssycon_rook, ssysv_rook, + chetf2_rook, chetrf_rook, chetri_rook, + chetrs_rook, checon_rook, chesv_rook, + clahef_rook, clasyf_rook, + csytf2_rook, csytrf_rook, csytrs_rook, + csytri_rook, csycon_rook, csysv_rook, + dlasyf_rook, + dsytf2_rook, dsytrf_rook, dsytrs_rook, + dsytri_rook, dsycon_rook, dsysv_rook, + zhetf2_rook, zhetrf_rook, zhetri_rook, + zhetrs_rook, zhecon_rook, zhesv_rook, + zlahef_rook, zlasyf_rook, + zsytf2_rook, zsytrf_rook, zsytrs_rook, + zsytri_rook, zsycon_rook, zsysv_rook, +); + if ($ARGV[8] == 1) { #ONLY_CBLAS=1 @underscore_objs = (@misc_underscore_objs); } elsif ($ARGV[5] == 1) { - #NO_LAPACK=1 - @underscore_objs = (@blasobjs, @misc_underscore_objs); + #NO_LAPACK=1 + @underscore_objs = (@blasobjs, @misc_underscore_objs); } elsif (-d "../lapack-netlib") { - - if ($ARGV[7] == 0){ - # NEED2UNDERSCORES=0 - # Don't need 2 underscores - @underscore_objs = (@blasobjs, @lapackobjs, @lapackobjs2, @misc_underscore_objs, @lapack_embeded_underscore_objs); - }else{ - # Need 2 underscores - @underscore_objs = (@blasobjs, @lapackobjs, @lapackobjs2, @misc_underscore_objs); - @need_2underscore_objs = (@lapack_embeded_underscore_objs); + if ($ARGV[7] == 0) { + # NEED2UNDERSCORES=0 + # Don't need 2 underscores + @underscore_objs = (@blasobjs, @lapackobjs, @lapackobjs2, @misc_underscore_objs, @lapack_embeded_underscore_objs); + } else { + # Need 2 underscores + @underscore_objs = (@blasobjs, @lapackobjs, @lapackobjs2, @misc_underscore_objs); + @need_2underscore_objs = (@lapack_embeded_underscore_objs); }; - if ($ARGV[11] == 1){ - #BUILD_LAPACK_DEPRECATED=1 - @underscore_objs =(@underscore_objs, @lapack_deprecated_objs); + if ($ARGV[11] == 1) { + #BUILD_LAPACK_DEPRECATED=1 + @underscore_objs = (@underscore_objs, @lapack_deprecated_objs); } - } else { @underscore_objs = (@blasobjs, @lapackobjs, @misc_underscore_objs); } @@ -3006,15 +3442,15 @@ if ($ARGV[8] == 1) { @exblasobjs=(); } -if ($ARGV[3] == 1){ @underscore_objs = (@underscore_objs, @exblasobjs); }; - -if ($ARGV[1] eq "x86_64"){ @underscore_objs = (@underscore_objs, @gemm3mobjs); }; +if ($ARGV[3] == 1) { + @underscore_objs = (@underscore_objs, @exblasobjs); +}; -if ($ARGV[1] eq "x86"){ @underscore_objs = (@underscore_objs, @gemm3mobjs); }; +if ($ARGV[1] eq "x86_64") { @underscore_objs = (@underscore_objs, @gemm3mobjs); }; +if ($ARGV[1] eq "x86") { @underscore_objs = (@underscore_objs, @gemm3mobjs); }; +if ($ARGV[1] eq "ia64") { @underscore_objs = (@underscore_objs, @gemm3mobjs); }; +if ($ARGV[1] eq "MIPS") { @underscore_objs = (@underscore_objs, @gemm3mobjs); }; -if ($ARGV[1] eq "ia64"){ @underscore_objs = (@underscore_objs, @gemm3mobjs); }; - -if ($ARGV[1] eq "MIPS"){ @underscore_objs = (@underscore_objs, @gemm3mobjs); }; if ($ARGV[4] == 0) { @no_underscore_objs = (@cblasobjs, @misc_no_underscore_objs); @@ -3026,7 +3462,12 @@ if ($ARGV[6] == 1) { #NO_LAPACKE=1 @no_underscore_objs = (@no_underscore_objs); } else { - @no_underscore_objs = (@no_underscore_objs, @lapackeobjs); + if ($ARGV[11] == 1) { + #BUILD_LAPACK_DEPRECATED=1 + @no_underscore_objs = (@no_underscore_objs, @lapackeobjs, @lapacke_deprecated_objs); + } else { + @no_underscore_objs = (@no_underscore_objs, @lapackeobjs); + } } @hplobjs = (daxpy, dcopy, dscal, idamax, dgemv, dtrsv, dger, dgemm, dtrsm); @@ -3040,87 +3481,75 @@ $symbolprefix = $ARGV[9]; $symbolsuffix = $ARGV[10]; -if ($ARGV[0] eq "osx"){ - +if ($ARGV[0] eq "osx") { @underscore_objs = (@underscore_objs, @misc_common_objs); @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); foreach $objs (@underscore_objs) { - print "_", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; + print "_", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; } foreach $objs (@need_2underscore_objs) { - print "_", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; + print "_", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; } -# if ($ARGV[4] == 0) { - foreach $objs (@no_underscore_objs) { - print "_", $symbolprefix, $objs, $symbolsuffix, "\n"; - } -# } + foreach $objs (@no_underscore_objs) { + print "_", $symbolprefix, $objs, $symbolsuffix, "\n"; + } exit(0); } if ($ARGV[0] eq "aix"){ - @underscore_objs = (@underscore_objs, @misc_common_objs); @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); foreach $objs (@underscore_objs) { - print $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; + print $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; } foreach $objs (@need_2underscore_objs) { - print $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; + print $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; } -# if ($ARGV[4] == 0) { - foreach $objs (@no_underscore_objs) { - print $symbolprefix, $objs, $symbolsuffix, "\n"; - } -# } + foreach $objs (@no_underscore_objs) { + print $symbolprefix, $objs, $symbolsuffix, "\n"; + } exit(0); } -if ($ARGV[0] eq "objcopy"){ - +if ($ARGV[0] eq "objcopy") { @underscore_objs = (@underscore_objs, @misc_common_objs); @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); foreach $objs (@underscore_objs) { - print $objs, $bu, " ", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; + print $objs, $bu, " ", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; } foreach $objs (@need_2underscore_objs) { - print $objs, $bu, $bu, " ", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; + print $objs, $bu, $bu, " ", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; } -# if ($ARGV[4] == 0) { - foreach $objs (@no_underscore_objs) { - print $objs, " ", $symbolprefix, $objs, $symbolsuffix, "\n"; - } -# } + foreach $objs (@no_underscore_objs) { + print $objs, " ", $symbolprefix, $objs, $symbolsuffix, "\n"; + } exit(0); } -if ($ARGV[0] eq "objconv"){ - +if ($ARGV[0] eq "objconv") { @underscore_objs = (@underscore_objs, @misc_common_objs); @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); foreach $objs (@underscore_objs) { - print "-nr:_", $objs, $bu, ":_", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; + print "-nr:_", $objs, $bu, ":_", $symbolprefix, $objs, $bu, $symbolsuffix, "\n"; } foreach $objs (@need_2underscore_objs) { - print "-nr:_", $objs, $bu, $bu, ":_", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; + print "-nr:_", $objs, $bu, $bu, ":_", $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "\n"; } -# if ($ARGV[4] == 0) { - foreach $objs (@no_underscore_objs) { - print "-nr:_", $objs, ":_", $symbolprefix, $objs, $symbolsuffix, "\n"; - } -# } + foreach $objs (@no_underscore_objs) { + print "-nr:_", $objs, ":_", $symbolprefix, $objs, $symbolsuffix, "\n"; + } exit(0); } @@ -3131,126 +3560,112 @@ if ($ARGV[0] eq "win2k"){ @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); foreach $objs (@underscore_objs) { - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","_ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","_ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; + $count ++; } foreach $objs (@need_2underscore_objs) { - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","__ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $objs, "__", $symbolsuffix, "=$objs","__ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "__ \@", $count, "\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","__ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $objs, "__", $symbolsuffix, "=$objs","__ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "__ \@", $count, "\n"; + $count ++; } #for misc_common_objs foreach $objs (@misc_common_objs) { - - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; + $count ++; } foreach $objs (@no_underscore_objs) { - print "\t",$symbolprefix,$objs,$symbolsuffix,"=$objs"," \@", $count, "\n"; - $count ++; + print "\t",$symbolprefix,$objs,$symbolsuffix,"=$objs"," \@", $count, "\n"; + $count ++; } exit(0); } -if ($ARGV[0] eq "win2khpl"){ +if ($ARGV[0] eq "win2khpl") { print "EXPORTS\n"; $count = 1; foreach $objs (@hplobjs) { - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","_ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","_ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $objs, "_", $symbolsuffix, "=$objs","_ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "_ \@", $count, "\n"; + $count ++; } -# foreach $objs (@hplobjs2) { -# print "\t$objs=$objs"," \@", $count, "\n"; -# $count ++; -# } - exit(0); } if ($ARGV[0] eq "microsoft"){ - @underscore_objs = (@underscore_objs, @misc_common_objs); print "EXPORTS\n"; $count = 1; foreach $objs (@underscore_objs) { - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, $symbolsuffix, " = $objs","_\n"; - $count ++; - print "\t",$symbolprefix, $objs, "\_", $symbolsuffix, " = $objs","_\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, " = $objs","_\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, "\_", $symbolsuffix, " = $objs","_\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, $symbolsuffix, " = $objs","_\n"; + $count ++; + print "\t",$symbolprefix, $objs, "\_", $symbolsuffix, " = $objs","_\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, " = $objs","_\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, "\_", $symbolsuffix, " = $objs","_\n"; + $count ++; } foreach $objs (@need_2underscore_objs) { - $uppercase = $objs; - $uppercase =~ tr/[a-z]/[A-Z]/; - print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","__ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $objs, "__", $symbolsuffix, "=$objs","__ \@", $count, "\n"; - $count ++; - print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "__ \@", $count, "\n"; - $count ++; + $uppercase = $objs; + $uppercase =~ tr/[a-z]/[A-Z]/; + print "\t",$symbolprefix, $objs, $symbolsuffix, "=$objs","__ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $objs, "__", $symbolsuffix, "=$objs","__ \@", $count, "\n"; + $count ++; + print "\t",$symbolprefix, $uppercase, $symbolsuffix, "=$objs", "__ \@", $count, "\n"; + $count ++; } exit(0); } -if ($ARGV[0] eq "linktest"){ - +if ($ARGV[0] eq "linktest") { @underscore_objs = (@underscore_objs, @misc_common_objs); @no_underscore_objs = (@no_underscore_objs, @misc_common_objs); print "int main(void){\n"; foreach $objs (@underscore_objs) { - print $symbolprefix, $objs, $bu, $symbolsuffix, "();\n" if $objs ne "xerbla"; + print $symbolprefix, $objs, $bu, $symbolsuffix, "();\n" if $objs ne "xerbla"; } foreach $objs (@need_2underscore_objs) { - print $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "();\n"; + print $symbolprefix, $objs, $bu, $bu, $symbolsuffix, "();\n"; } -# if ($ARGV[4] == 0) { - foreach $objs (@no_underscore_objs) { - print $symbolprefix, $objs, $symbolsuffix, "();\n"; - } -# } - - - + foreach $objs (@no_underscore_objs) { + print $symbolprefix, $objs, $symbolsuffix, "();\n"; + } print "return 0;}\n"; exit(0); } - diff --git a/f_check b/f_check index 2f01f1c447..f4380604b8 100644 --- a/f_check +++ b/f_check @@ -33,6 +33,7 @@ if ($compiler eq "") { "ppuf77", "ppuf95", "ppuf90", "ppuxlf", "pathf90", "pathf95", "pgf95", "pgf90", "pgf77", + "flang", "ifort"); OUTER: @@ -78,8 +79,13 @@ if ($compiler eq "") { $vendor = GFORTRAN; $openmp = "-fopenmp"; } else { - $vendor = G77; - $openmp = ""; + if ($compiler =~ /flang/) { + $vendor = FLANG; + $openmp = "-fopenmp"; + } else { + $vendor = G77; + $openmp = ""; + } } } @@ -197,6 +203,12 @@ if ($compiler eq "") { $openmp = "-mp"; } + if ($compiler =~ /flang/) { + $vendor = FLANG; + $bu = "_"; + $openmp = "-fopenmp"; + } + if ($vendor eq "") { $nofortran = 1; $compiler = "gfortran"; @@ -283,6 +295,12 @@ if ($link ne "") { $linker_L .= "-Wl,". $flags . " "; } + if ($flags =~ /^\--exclude-libs/) { + $linker_L .= "-Wl,". $flags . " "; + $flags=""; + } + + if ($flags =~ /^\-rpath\@/) { $flags =~ s/\@/\,/g; if ($vendor eq "PGI") { @@ -325,6 +343,10 @@ if ($vendor eq "INTEL"){ $linker_a .= "-lgfortran" } +if ($vendor eq "FLANG"){ + $linker_a .= "-lflang" +} + open(MAKEFILE, ">> $makefile") || die "Can't append $makefile"; open(CONFFILE, ">> $config" ) || die "Can't append $config"; diff --git a/gen_config_h.c b/gen_config_h.c new file mode 100644 index 0000000000..dda06f285b --- /dev/null +++ b/gen_config_h.c @@ -0,0 +1,36 @@ +#include +#include +#include +int main(int argc, char**argv) { +FILE *fp; +char line[100]; +char line2[80]; +char *s; +int i; + +fprintf(stdout,"#ifndef OPENBLAS_CONFIG_H\n"); +fprintf(stdout,"#define OPENBLAS_CONFIG_H\n"); +fp=fopen(argv[1],"r"); +do{ +s=fgets(line,80,fp); +if (s== NULL) break; +memset(line2,0,80); +i=sscanf(line,"#define %70c",line2); +if (i!=0) { + fprintf(stdout,"#define OPENBLAS_%s",line2); +} else { + fprintf(stdout,"\n"); +} +} while (1); +fclose(fp); +fprintf(stdout,"#define OPENBLAS_VERSION \"OpenBLAS %s\"\n", VERSION); +fp=fopen(argv[2],"r"); +do{ +s=fgets(line,100,fp); +if (s== NULL) break; +fprintf(stdout,"%s",line); +} while(1); +fclose(fp); +fprintf(stdout,"#endif /* OPENBLAS_CONFIG_H */\n"); +exit(0); +} diff --git a/getarch.c b/getarch.c index f8069e5078..e388572f47 100644 --- a/getarch.c +++ b/getarch.c @@ -473,6 +473,25 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define CORENAME "EXCAVATOR" #endif +#if defined (FORCE_ZEN) +#define FORCE +#define FORCE_INTEL +#define ARCHITECTURE "X86" +#define SUBARCHITECTURE "ZEN" +#define ARCHCONFIG "-DZEN " \ + "-DL1_CODE_SIZE=32768 -DL1_CODE_LINESIZE=64 -DL1_CODE_ASSOCIATIVE=8 " \ + "-DL1_DATA_SIZE=32768 -DL1_DATA_LINESIZE=64 -DL2_CODE_ASSOCIATIVE=8 " \ + "-DL2_SIZE=524288 -DL2_LINESIZE=64 -DL2_ASSOCIATIVE=8 " \ + "-DL3_SIZE=16777216 -DL3_LINESIZE=64 -DL3_ASSOCIATIVE=8 " \ + "-DITB_DEFAULT_ENTRIES=64 -DITB_SIZE=4096 " \ + "-DDTB_DEFAULT_ENTRIES=64 -DDTB_SIZE=4096 " \ + "-DHAVE_MMX -DHAVE_SSE -DHAVE_SSE2 -DHAVE_SSE3 -DHAVE_SSE4_1 -DHAVE_SSE4_2 " \ + "-DHAVE_SSE4A -DHAVE_MISALIGNSSE -DHAVE_128BITFPU -DHAVE_FASTMOVU -DHAVE_CFLUSH " \ + "-DHAVE_AVX -DHAVE_FMA3 -DFMA3" +#define LIBNAME "zen" +#define CORENAME "ZEN" +#endif + #ifdef FORCE_SSE_GENERIC #define FORCE @@ -884,7 +903,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifdef FORCE_CORTEXA57 #define FORCE #define ARCHITECTURE "ARM64" -#define SUBARCHITECTURE "ARMV8" +#define SUBARCHITECTURE "CORTEXA57" #define SUBDIRNAME "arm64" #define ARCHCONFIG "-DCORTEXA57 " \ "-DL1_CODE_SIZE=49152 -DL1_CODE_LINESIZE=64 -DL1_CODE_ASSOCIATIVE=3 " \ @@ -897,6 +916,54 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #else #endif +#ifdef FORCE_VULCAN +#define FORCE +#define ARCHITECTURE "ARM64" +#define SUBARCHITECTURE "VULCAN" +#define SUBDIRNAME "arm64" +#define ARCHCONFIG "-DVULCAN " \ + "-DL1_CODE_SIZE=32768 -DL1_CODE_LINESIZE=64 -DL1_CODE_ASSOCIATIVE=8 " \ + "-DL1_DATA_SIZE=32768 -DL1_DATA_LINESIZE=64 -DL1_DATA_ASSOCIATIVE=8 " \ + "-DL2_SIZE=262144 -DL2_LINESIZE=64 -DL2_ASSOCIATIVE=8 " \ + "-DL3_SIZE=33554432 -DL3_LINESIZE=64 -DL3_ASSOCIATIVE=32 " \ + "-DDTB_DEFAULT_ENTRIES=64 -DDTB_SIZE=4096 " \ + "-DHAVE_VFPV4 -DHAVE_VFPV3 -DHAVE_VFP -DHAVE_NEON" +#define LIBNAME "vulcan" +#define CORENAME "VULCAN" +#else +#endif + +#ifdef FORCE_THUNDERX +#define FORCE +#define ARCHITECTURE "ARM64" +#define SUBARCHITECTURE "THUNDERX" +#define SUBDIRNAME "arm64" +#define ARCHCONFIG "-DTHUNDERX " \ + "-DL1_DATA_SIZE=32768 -DL1_DATA_LINESIZE=128 " \ + "-DL2_SIZE=16777216 -DL2_LINESIZE=128 -DL2_ASSOCIATIVE=16 " \ + "-DDTB_DEFAULT_ENTRIES=64 -DDTB_SIZE=4096 " +#define LIBNAME "thunderx" +#define CORENAME "THUNDERX" +#else +#endif + +#ifdef FORCE_THUNDERX2T99 +#define FORCE +#define ARCHITECTURE "ARM64" +#define SUBARCHITECTURE "THUNDERX2T99" +#define SUBDIRNAME "arm64" +#define ARCHCONFIG "-DTHUNDERX2T99 " \ + "-DL1_CODE_SIZE=32768 -DL1_CODE_LINESIZE=64 -DL1_CODE_ASSOCIATIVE=8 " \ + "-DL1_DATA_SIZE=32768 -DL1_DATA_LINESIZE=64 -DL1_DATA_ASSOCIATIVE=8 " \ + "-DL2_SIZE=262144 -DL2_LINESIZE=64 -DL2_ASSOCIATIVE=8 " \ + "-DL3_SIZE=33554432 -DL3_LINESIZE=64 -DL3_ASSOCIATIVE=32 " \ + "-DDTB_DEFAULT_ENTRIES=64 -DDTB_SIZE=4096 " \ + "-DHAVE_VFPV4 -DHAVE_VFPV3 -DHAVE_VFP -DHAVE_NEON" +#define LIBNAME "thunderx2t99" +#define CORENAME "THUNDERX2T99" +#else +#endif + #ifndef FORCE #if defined(__powerpc__) || defined(__powerpc) || defined(powerpc) || \ @@ -907,6 +974,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define OPENBLAS_SUPPORTED #endif +#if defined(__zarch__) || defined(__s390x__) +#define ZARCH +#include "cpuid_zarch.c" +#define OPENBLAS_SUPPORTED +#endif + #ifdef INTEL_AMD #include "cpuid_x86.c" #define OPENBLAS_SUPPORTED @@ -971,7 +1044,7 @@ static int get_num_cores(void) { #if defined(linux) || defined(__sun__) //returns the number of processors which are currently online - return sysconf(_SC_NPROCESSORS_ONLN); + return sysconf(_SC_NPROCESSORS_CONF); #elif defined(OS_WINDOWS) @@ -1006,7 +1079,7 @@ int main(int argc, char *argv[]){ #ifdef FORCE printf("CORE=%s\n", CORENAME); #else -#if defined(INTEL_AMD) || defined(POWER) || defined(__mips__) || defined(__arm__) || defined(__aarch64__) +#if defined(INTEL_AMD) || defined(POWER) || defined(__mips__) || defined(__arm__) || defined(__aarch64__) || defined(ZARCH) printf("CORE=%s\n", get_corename()); #endif #endif @@ -1098,6 +1171,7 @@ int main(int argc, char *argv[]){ p ++; } } else { + if (*p != '\n') printf("%c", *p); p ++; } @@ -1113,7 +1187,7 @@ int main(int argc, char *argv[]){ #ifdef FORCE printf("#define CHAR_CORENAME \"%s\"\n", CORENAME); #else -#if defined(INTEL_AMD) || defined(POWER) || defined(__mips__) || defined(__arm__) || defined(__aarch64__) +#if defined(INTEL_AMD) || defined(POWER) || defined(__mips__) || defined(__arm__) || defined(__aarch64__) || defined(ZARCH) printf("#define CHAR_CORENAME \"%s\"\n", get_corename()); #endif #endif diff --git a/interface/Makefile b/interface/Makefile index 1666d9145a..9b2b93b835 100644 --- a/interface/Makefile +++ b/interface/Makefile @@ -84,10 +84,10 @@ CBLAS1OBJS = \ CBLAS2OBJS = \ cgemv.$(SUFFIX) cgeru.$(SUFFIX) cgerc.$(SUFFIX) \ - ctrsv.$(SUFFIX) ctrmv.$(SUFFIX) csymv.$(SUFFIX) \ - csyr.$(SUFFIX) csyr2.$(SUFFIX) cgbmv.$(SUFFIX) \ - csbmv.$(SUFFIX) cspmv.$(SUFFIX) \ - cspr.$(SUFFIX) cspr2.$(SUFFIX) \ + ctrsv.$(SUFFIX) ctrmv.$(SUFFIX) \ + csyr2.$(SUFFIX) cgbmv.$(SUFFIX) \ + csbmv.$(SUFFIX) \ + cspr2.$(SUFFIX) \ ctbsv.$(SUFFIX) ctbmv.$(SUFFIX) \ ctpsv.$(SUFFIX) ctpmv.$(SUFFIX) \ chemv.$(SUFFIX) chbmv.$(SUFFIX) \ @@ -113,10 +113,10 @@ ZBLAS1OBJS = \ ZBLAS2OBJS = \ zgemv.$(SUFFIX) zgeru.$(SUFFIX) zgerc.$(SUFFIX) \ - ztrsv.$(SUFFIX) ztrmv.$(SUFFIX) zsymv.$(SUFFIX) \ - zsyr.$(SUFFIX) zsyr2.$(SUFFIX) zgbmv.$(SUFFIX) \ - zsbmv.$(SUFFIX) zspmv.$(SUFFIX) \ - zspr.$(SUFFIX) zspr2.$(SUFFIX) \ + ztrsv.$(SUFFIX) ztrmv.$(SUFFIX) \ + zsyr2.$(SUFFIX) zgbmv.$(SUFFIX) \ + zsbmv.$(SUFFIX) \ + zspr2.$(SUFFIX) \ ztbsv.$(SUFFIX) ztbmv.$(SUFFIX) \ ztpsv.$(SUFFIX) ztpmv.$(SUFFIX) \ zhemv.$(SUFFIX) zhbmv.$(SUFFIX) \ @@ -315,7 +315,7 @@ CCBLAS3OBJS = \ cblas_csyrk.$(SUFFIX) cblas_csyr2k.$(SUFFIX) \ cblas_chemm.$(SUFFIX) cblas_cherk.$(SUFFIX) cblas_cher2k.$(SUFFIX) \ cblas_comatcopy.$(SUFFIX) cblas_cimatcopy.$(SUFFIX)\ - cblas_cgeadd.$(SUFFIX) + cblas_cgeadd.$(SUFFIX) cblas_xerbla.$(SUFFIX) @@ -2137,3 +2137,5 @@ cblas_cgeadd.$(SUFFIX) cblas_cgeadd.$(PSUFFIX) : zgeadd.c cblas_zgeadd.$(SUFFIX) cblas_zgeadd.$(PSUFFIX) : zgeadd.c $(CC) -c $(CFLAGS) -DCBLAS $< -o $(@F) +cblas_xerbla.$(SUFFIX) cblas_xerbla.$(PSUFFIX) : xerbla.c + $(CC) -c $(CFLAGS) -DCBLAS $< -o $(@F) diff --git a/interface/swap.c b/interface/swap.c index 7d47d600bd..f7642edf1a 100644 --- a/interface/swap.c +++ b/interface/swap.c @@ -42,9 +42,13 @@ #include "functable.h" #endif +#if defined(THUNDERX2T99) || defined(VULCAN) +// Multithreaded swap gives performance benefits in ThunderX2T99 +#else // Disable multi-threading as it does not show any performance // benefits. Keep the multi-threading code for the record. #undef SMP +#endif #ifndef CBLAS @@ -81,7 +85,6 @@ void CNAME(blasint n, FLOAT *x, blasint incx, FLOAT *y, blasint incy){ if (incy < 0) y -= (n - 1) * incy; #ifdef SMP - //disable multi-thread when incx==0 or incy==0 //In that case, the threads would be dependent. if (incx == 0 || incy == 0 || n < 2097152 * GEMM_MULTITHREAD_THRESHOLD / sizeof(FLOAT)) diff --git a/interface/xerbla.c b/interface/xerbla.c new file mode 100644 index 0000000000..c3a1745523 --- /dev/null +++ b/interface/xerbla.c @@ -0,0 +1,22 @@ +#ifdef CBLAS + +#include +#include +#include +#include +#include "common.h" + +void CNAME(blasint p, char *rout, char *form, ...) +{ + va_list args; + + va_start(args, form); + + if (p) + fprintf(stderr, "Parameter %d to routine %s was incorrect\n", p, rout); + vfprintf(stderr, form, args); + va_end(args); + exit(-1); +} +#endif + diff --git a/interface/zdot.c b/interface/zdot.c index d4d0fab921..cd956b0754 100644 --- a/interface/zdot.c +++ b/interface/zdot.c @@ -160,9 +160,10 @@ OPENBLAS_COMPLEX_FLOAT CNAME(blasint n, FLOAT *x, blasint incx, FLOAT *y, blasin if (n <= 0) { #ifdef FORCE_USE_STACK - //*result = OPENBLAS_MAKE_COMPLEX_FLOAT(0.0, 0.0); - CREAL(*result) = 0.0; - CIMAG(*result) = 0.0; + OPENBLAS_COMPLEX_FLOAT zero=OPENBLAS_MAKE_COMPLEX_FLOAT(0.0, 0.0); + *result = zero; +// CREAL(*result) = 0.0; +// CIMAG(*result) = 0.0; return; #else return zero; diff --git a/interface/zimatcopy.c b/interface/zimatcopy.c index b1e1d15dc8..87964e20d8 100644 --- a/interface/zimatcopy.c +++ b/interface/zimatcopy.c @@ -125,9 +125,8 @@ void CNAME( enum CBLAS_ORDER CORDER, enum CBLAS_TRANSPOSE CTRANS, blasint crows, BLASFUNC(xerbla)(ERROR_NAME, &info, sizeof(ERROR_NAME)); return; } - #ifdef NEW_IMATCOPY - if (*lda == *ldb) { + if (*lda == *ldb && *cols == *rows) { if ( order == BlasColMajor ) { @@ -180,7 +179,7 @@ void CNAME( enum CBLAS_ORDER CORDER, enum CBLAS_TRANSPOSE CTRANS, blasint crows, b = malloc(msize); if ( b == NULL ) { - printf("Memory alloc failed\n"); + printf("Memory alloc failed in zimatcopy\n"); exit(1); } @@ -205,14 +204,14 @@ void CNAME( enum CBLAS_ORDER CORDER, enum CBLAS_TRANSPOSE CTRANS, blasint crows, if ( trans == BlasTrans ) { OMATCOPY_K_CT(*rows, *cols, alpha[0], alpha[1], a, *lda, b, *ldb ); - OMATCOPY_K_CN(*rows, *cols, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); + OMATCOPY_K_CN(*cols, *rows, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); free(b); return; } if ( trans == BlasTransConj ) { OMATCOPY_K_CTC(*rows, *cols, alpha[0], alpha[1], a, *lda, b, *ldb ); - OMATCOPY_K_CN(*rows, *cols, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); + OMATCOPY_K_CN(*cols, *rows, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); free(b); return; } @@ -238,20 +237,20 @@ void CNAME( enum CBLAS_ORDER CORDER, enum CBLAS_TRANSPOSE CTRANS, blasint crows, if ( trans == BlasTrans ) { OMATCOPY_K_RT(*rows, *cols, alpha[0], alpha[1], a, *lda, b, *ldb ); - OMATCOPY_K_RN(*rows, *cols, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); + OMATCOPY_K_RN(*cols, *rows, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); free(b); return; } if ( trans == BlasTransConj ) { OMATCOPY_K_RTC(*rows, *cols, alpha[0], alpha[1], a, *lda, b, *ldb ); - OMATCOPY_K_RN(*rows, *cols, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); + OMATCOPY_K_RN(*cols, *rows, (FLOAT) 1.0, (FLOAT) 0.0 , b, *ldb, a, *ldb ); free(b); return; } } - + free(b); return; } diff --git a/kernel/CMakeLists.txt b/kernel/CMakeLists.txt index 435478c986..8bfcccf17f 100644 --- a/kernel/CMakeLists.txt +++ b/kernel/CMakeLists.txt @@ -118,7 +118,7 @@ endforeach () # Makefile.L3 set(USE_TRMM false) -if (${ARCH} STREQUAL "arm" OR ${ARCH} STREQUAL "arm64" OR "${TARGET}" STREQUAL "LONGSOON3B" OR "${TARGET}" STREQUAL "GENERIC" OR "${CORE}" STREQUAL "generic" OR "${TARGET}" STREQUAL "HASWELL" OR "${CORE}" STREQUAL "HASWELL") +if (${ARCH} STREQUAL "arm" OR ${ARCH} STREQUAL "arm64" OR "${TARGET}" STREQUAL "LONGSOON3B" OR "${TARGET}" STREQUAL "GENERIC" OR "${CORE}" STREQUAL "generic" OR "${TARGET}" STREQUAL "HASWELL" OR "${CORE}" STREQUAL "haswell" OR "{CORE}" STREQUAL "zen") set(USE_TRMM true) endif () diff --git a/kernel/Makefile.L3 b/kernel/Makefile.L3 index e55f153f59..0664263967 100644 --- a/kernel/Makefile.L3 +++ b/kernel/Makefile.L3 @@ -32,10 +32,18 @@ ifeq ($(CORE), HASWELL) USE_TRMM = 1 endif +ifeq ($(CORE), ZEN) +USE_TRMM = 1 +endif + ifeq ($(CORE), POWER8) USE_TRMM = 1 endif +ifeq ($(CORE), Z13) +USE_TRMM = 1 +endif + diff --git a/kernel/arm/KERNEL.ARMV6 b/kernel/arm/KERNEL.ARMV6 index 16bde105b3..960dae67b0 100644 --- a/kernel/arm/KERNEL.ARMV6 +++ b/kernel/arm/KERNEL.ARMV6 @@ -1,7 +1,5 @@ +include $(KERNELDIR)/KERNEL.ARMV5 - - -############################################################################### SAMAXKERNEL = iamax_vfp.S DAMAXKERNEL = iamax_vfp.S CAMAXKERNEL = iamax_vfp.S @@ -44,10 +42,10 @@ DAXPYKERNEL = axpy_vfp.S CAXPYKERNEL = axpy_vfp.S ZAXPYKERNEL = axpy_vfp.S -SCOPYKERNEL = copy.c -DCOPYKERNEL = copy.c -CCOPYKERNEL = zcopy.c -ZCOPYKERNEL = zcopy.c +SROTKERNEL = rot_vfp.S +DROTKERNEL = rot_vfp.S +CROTKERNEL = rot_vfp.S +ZROTKERNEL = rot_vfp.S SDOTKERNEL = sdot_vfp.S DDOTKERNEL = ddot_vfp.S @@ -59,16 +57,6 @@ DNRM2KERNEL = nrm2_vfp.S CNRM2KERNEL = nrm2_vfp.S ZNRM2KERNEL = nrm2_vfp.S -SROTKERNEL = rot_vfp.S -DROTKERNEL = rot_vfp.S -CROTKERNEL = rot_vfp.S -ZROTKERNEL = rot_vfp.S - -SSCALKERNEL = scal.c -DSCALKERNEL = scal.c -CSCALKERNEL = zscal.c -ZSCALKERNEL = zscal.c - SSWAPKERNEL = swap_vfp.S DSWAPKERNEL = swap_vfp.S CSWAPKERNEL = swap_vfp.S @@ -84,26 +72,25 @@ DGEMVTKERNEL = gemv_t_vfp.S CGEMVTKERNEL = cgemv_t_vfp.S ZGEMVTKERNEL = zgemv_t_vfp.S -STRMMKERNEL = strmm_kernel_4x2_vfp.S -DTRMMKERNEL = dtrmm_kernel_4x2_vfp.S -CTRMMKERNEL = ctrmm_kernel_2x2_vfp.S -ZTRMMKERNEL = ztrmm_kernel_2x2_vfp.S - SGEMMKERNEL = sgemm_kernel_4x2_vfp.S +ifneq ($(SGEMM_UNROLL_M), $(SGEMM_UNROLL_N)) SGEMMINCOPY = sgemm_ncopy_4_vfp.S SGEMMITCOPY = sgemm_tcopy_4_vfp.S SGEMMINCOPYOBJ = sgemm_incopy.o SGEMMITCOPYOBJ = sgemm_itcopy.o +endif SGEMMONCOPY = sgemm_ncopy_2_vfp.S -SGEMMOTCOPY = ../generic/gemm_tcopy_2.c -SGEMMONCOPYOBJ = sgemm_oncopy.o -SGEMMOTCOPYOBJ = sgemm_otcopy.o +SGEMMOTCOPY = ../generic/gemm_tcopy_2.c +SGEMMONCOPYOBJ = sgemm_oncopy.o +SGEMMOTCOPYOBJ = sgemm_otcopy.o DGEMMKERNEL = dgemm_kernel_4x2_vfp.S +ifneq ($(DGEMM_UNROLL_M), $(DGEMM_UNROLL_N)) DGEMMINCOPY = dgemm_ncopy_4_vfp.S DGEMMITCOPY = dgemm_tcopy_4_vfp.S DGEMMINCOPYOBJ = dgemm_incopy.o DGEMMITCOPYOBJ = dgemm_itcopy.o +endif DGEMMONCOPY = dgemm_ncopy_2_vfp.S DGEMMOTCOPY = ../generic/gemm_tcopy_2.c DGEMMONCOPYOBJ = dgemm_oncopy.o @@ -121,26 +108,8 @@ ZGEMMOTCOPY = zgemm_tcopy_2_vfp.S ZGEMMONCOPYOBJ = zgemm_oncopy.o ZGEMMOTCOPYOBJ = zgemm_otcopy.o -STRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -STRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -STRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -STRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -DTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -DTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -DTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -DTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -CTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -CTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -CTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -CTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -ZTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -ZTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -ZTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -ZTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - - - +STRMMKERNEL = strmm_kernel_4x2_vfp.S +DTRMMKERNEL = dtrmm_kernel_4x2_vfp.S +CTRMMKERNEL = ctrmm_kernel_2x2_vfp.S +ZTRMMKERNEL = ztrmm_kernel_2x2_vfp.S diff --git a/kernel/arm/KERNEL.ARMV7 b/kernel/arm/KERNEL.ARMV7 index d5cd94fbdb..5e0b4cfb81 100644 --- a/kernel/arm/KERNEL.ARMV7 +++ b/kernel/arm/KERNEL.ARMV7 @@ -1,91 +1,12 @@ - -################################################################################# -SAMAXKERNEL = iamax_vfp.S -DAMAXKERNEL = iamax_vfp.S -CAMAXKERNEL = iamax_vfp.S -ZAMAXKERNEL = iamax_vfp.S - -SAMINKERNEL = iamax_vfp.S -DAMINKERNEL = iamax_vfp.S -CAMINKERNEL = iamax_vfp.S -ZAMINKERNEL = iamax_vfp.S - -SMAXKERNEL = iamax_vfp.S -DMAXKERNEL = iamax_vfp.S - -SMINKERNEL = iamax_vfp.S -DMINKERNEL = iamax_vfp.S - -ISAMAXKERNEL = iamax_vfp.S -IDAMAXKERNEL = iamax_vfp.S -ICAMAXKERNEL = iamax_vfp.S -IZAMAXKERNEL = iamax_vfp.S - -ISAMINKERNEL = iamax_vfp.S -IDAMINKERNEL = iamax_vfp.S -ICAMINKERNEL = iamax_vfp.S -IZAMINKERNEL = iamax_vfp.S - -ISMAXKERNEL = iamax_vfp.S -IDMAXKERNEL = iamax_vfp.S - -ISMINKERNEL = iamax_vfp.S -IDMINKERNEL = iamax_vfp.S - -SSWAPKERNEL = swap_vfp.S -DSWAPKERNEL = swap_vfp.S -CSWAPKERNEL = swap_vfp.S -ZSWAPKERNEL = swap_vfp.S - -SASUMKERNEL = asum_vfp.S -DASUMKERNEL = asum_vfp.S -CASUMKERNEL = asum_vfp.S -ZASUMKERNEL = asum_vfp.S - -SAXPYKERNEL = axpy_vfp.S -DAXPYKERNEL = axpy_vfp.S -CAXPYKERNEL = axpy_vfp.S -ZAXPYKERNEL = axpy_vfp.S - -SCOPYKERNEL = copy.c -DCOPYKERNEL = copy.c -CCOPYKERNEL = zcopy.c -ZCOPYKERNEL = zcopy.c - -SDOTKERNEL = sdot_vfp.S -DDOTKERNEL = ddot_vfp.S -CDOTKERNEL = cdot_vfp.S -ZDOTKERNEL = zdot_vfp.S +include $(KERNELDIR)/KERNEL.ARMV6 SNRM2KERNEL = nrm2_vfpv3.S DNRM2KERNEL = nrm2_vfpv3.S CNRM2KERNEL = nrm2_vfpv3.S ZNRM2KERNEL = nrm2_vfpv3.S -SROTKERNEL = rot_vfp.S -DROTKERNEL = rot_vfp.S -CROTKERNEL = rot_vfp.S -ZROTKERNEL = rot_vfp.S - -SSCALKERNEL = scal.c -DSCALKERNEL = scal.c -CSCALKERNEL = zscal.c -ZSCALKERNEL = zscal.c - SGEMVNKERNEL = gemv_n_vfpv3.S DGEMVNKERNEL = gemv_n_vfpv3.S -CGEMVNKERNEL = cgemv_n_vfp.S -ZGEMVNKERNEL = zgemv_n_vfp.S - -SGEMVTKERNEL = gemv_t_vfp.S -DGEMVTKERNEL = gemv_t_vfp.S -CGEMVTKERNEL = cgemv_t_vfp.S -ZGEMVTKERNEL = zgemv_t_vfp.S - -STRMMKERNEL = strmm_kernel_4x4_vfpv3.S -DTRMMKERNEL = dtrmm_kernel_4x4_vfpv3.S -CTRMMKERNEL = ctrmm_kernel_2x2_vfpv3.S -ZTRMMKERNEL = ztrmm_kernel_2x2_vfpv3.S SGEMMKERNEL = sgemm_kernel_4x4_vfpv3.S SGEMMONCOPY = sgemm_ncopy_4_vfp.S @@ -100,35 +21,10 @@ DGEMMONCOPYOBJ = dgemm_oncopy.o DGEMMOTCOPYOBJ = dgemm_otcopy.o CGEMMKERNEL = cgemm_kernel_2x2_vfpv3.S -CGEMMONCOPY = cgemm_ncopy_2_vfp.S -CGEMMOTCOPY = cgemm_tcopy_2_vfp.S -CGEMMONCOPYOBJ = cgemm_oncopy.o -CGEMMOTCOPYOBJ = cgemm_otcopy.o - ZGEMMKERNEL = zgemm_kernel_2x2_vfpv3.S -ZGEMMONCOPY = zgemm_ncopy_2_vfp.S -ZGEMMOTCOPY = zgemm_tcopy_2_vfp.S -ZGEMMONCOPYOBJ = zgemm_oncopy.o -ZGEMMOTCOPYOBJ = zgemm_otcopy.o - -STRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -STRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -STRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -STRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -DTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -DTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -DTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -DTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -CTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -CTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -CTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -CTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c - -ZTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c -ZTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c -ZTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c -ZTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c +STRMMKERNEL = strmm_kernel_4x4_vfpv3.S +DTRMMKERNEL = dtrmm_kernel_4x4_vfpv3.S +CTRMMKERNEL = ctrmm_kernel_2x2_vfpv3.S +ZTRMMKERNEL = ztrmm_kernel_2x2_vfpv3.S diff --git a/kernel/arm/asum_vfp.S b/kernel/arm/asum_vfp.S index fe6242a5b8..5b08e5028c 100644 --- a/kernel/arm/asum_vfp.S +++ b/kernel/arm/asum_vfp.S @@ -475,6 +475,14 @@ asum_kernel_L999: vadd.f32 s0 , s0, s1 // set return value #endif +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov r0, s0 +#else + vmov r0, r1, d0 +#endif +#endif + bx lr EPILOGUE diff --git a/kernel/arm/axpy_vfp.S b/kernel/arm/axpy_vfp.S index acc5757076..37515f3996 100644 --- a/kernel/arm/axpy_vfp.S +++ b/kernel/arm/axpy_vfp.S @@ -38,10 +38,51 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 +#if !defined(__ARM_PCS_VFP) + +#if !defined(COMPLEX) + +#if !defined(DOUBLE) +#define OLD_ALPHA r3 +#define OLD_X [fp, #0 ] +#define OLD_INC_X [fp, #4 ] +#define OLD_Y [fp, #8 ] +#define OLD_INC_Y [fp, #12 ] +#else +#define OLD_ALPHA [fp, #0] +#define OLD_X [fp, #8 ] +#define OLD_INC_X [fp, #12 ] +#define OLD_Y [fp, #16 ] +#define OLD_INC_Y [fp, #20 ] +#endif + +#else //COMPLEX + +#if !defined(DOUBLE) +#define OLD_ALPHAR r3 +#define OLD_ALPHAI [fp, #0 ] +#define OLD_X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define OLD_Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#else +#define OLD_ALPHAR [fp, #0] +#define OLD_ALPHAI [fp, #8] +#define OLD_X [fp, #16 ] +#define OLD_INC_X [fp, #20 ] +#define OLD_Y [fp, #24 ] +#define OLD_INC_Y [fp, #28 ] +#endif + +#endif //!defined(COMPLEX) + +#else //__ARM_PCS_VFP + #define OLD_INC_X [fp, #0 ] #define OLD_Y [fp, #4 ] #define OLD_INC_Y [fp, #8 ] +#endif //!defined(__ARM_PCS_VFP) #define N r0 #define Y r1 @@ -64,14 +105,14 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(DOUBLE) #define FMAC_R1 fmacd -#define FMAC_R2 fnmacd +#define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #else #define FMAC_R1 fmacs -#define FMAC_R2 fnmacs +#define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs @@ -83,14 +124,14 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FMAC_R1 fmacd #define FMAC_R2 fmacd -#define FMAC_I1 fnmacd +#define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #else #define FMAC_R1 fmacs #define FMAC_R2 fmacs -#define FMAC_I1 fnmacs +#define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #endif @@ -363,6 +404,28 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #8 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) +#if !defined(COMPLEX) +#if !defined(DOUBLE) + vmov s0, OLD_ALPHA + ldr X, OLD_X +#else + vldr d0, OLD_ALPHA + ldr X, OLD_X +#endif +#else //COMPLEX +#if !defined(DOUBLE) + vmov s0, OLD_ALPHAR + vldr s1, OLD_ALPHAI + ldr X, OLD_X +#else + vldr d0, OLD_ALPHAR + vldr d1, OLD_ALPHAI + ldr X, OLD_X +#endif +#endif +#endif + ldr INC_X , OLD_INC_X ldr Y, OLD_Y ldr INC_Y , OLD_INC_Y diff --git a/kernel/arm/cdot_vfp.S b/kernel/arm/cdot_vfp.S index 0497b6d83e..e5a6e4d35a 100644 --- a/kernel/arm/cdot_vfp.S +++ b/kernel/arm/cdot_vfp.S @@ -41,8 +41,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define N r0 #define X r1 #define INC_X r2 -#define OLD_Y r3 - /****************************************************** * [fp, #-128] - [fp, #-64] is reserved @@ -50,7 +48,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * registers *******************************************************/ -#define OLD_INC_Y [fp, #4 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_RETURN_ADDR r0 +#define OLD_N r1 +#define OLD_X r2 +#define OLD_INC_X r3 +#define OLD_Y [fp, #0 ] +#define OLD_INC_Y [fp, #4 ] +#define RETURN_ADDR r8 +#else +#define OLD_Y r3 +#define OLD_INC_Y [fp, #0 ] +#endif #define I r5 #define Y r6 @@ -179,7 +188,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. .align 5 push {r4 - r9, fp} - add fp, sp, #24 + add fp, sp, #28 sub sp, sp, #STACKSIZE // reserve stack sub r4, fp, #128 @@ -191,8 +200,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmov s2, s0 vmov s3, s0 +#if !defined(__ARM_PCS_VFP) + mov RETURN_ADDR, OLD_RETURN_ADDR + mov N, OLD_N + mov X, OLD_X + mov INC_X, OLD_INC_X + ldr Y, OLD_Y + ldr INC_Y, OLD_INC_Y +#else mov Y, OLD_Y ldr INC_Y, OLD_INC_Y +#endif cmp N, #0 ble cdot_kernel_L999 @@ -265,7 +283,6 @@ cdot_kernel_S10: cdot_kernel_L999: - sub r3, fp, #128 vldm r3, { s8 - s15} // restore floating point registers @@ -276,8 +293,11 @@ cdot_kernel_L999: vadd.f32 s0 , s0, s2 vsub.f32 s1 , s1, s3 #endif +#if !defined(__ARM_PCS_VFP) + vstm RETURN_ADDR, {s0 - s1} +#endif - sub sp, fp, #24 + sub sp, fp, #28 pop {r4 - r9, fp} bx lr diff --git a/kernel/arm/cgemm_kernel_2x2_vfp.S b/kernel/arm/cgemm_kernel_2x2_vfp.S index f0517cb47e..71bc50efd3 100644 --- a/kernel/arm/cgemm_kernel_2x2_vfp.S +++ b/kernel/arm/cgemm_kernel_2x2_vfp.S @@ -64,9 +64,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP r3 +#define OLD_ALPHAI_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #8 ] +#define B [fp, #12 ] +#define C [fp, #16 ] +#define OLD_LDC [fp, #20 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -94,42 +103,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NN) || defined(NT) || defined(TN) || defined(TT) - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(CN) || defined(CT) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(NC) || defined(TC) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #else - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #endif @@ -816,6 +825,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/cgemm_kernel_2x2_vfpv3.S b/kernel/arm/cgemm_kernel_2x2_vfpv3.S index cf132a1849..9d473ad78c 100644 --- a/kernel/arm/cgemm_kernel_2x2_vfpv3.S +++ b/kernel/arm/cgemm_kernel_2x2_vfpv3.S @@ -80,9 +80,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP r3 +#define OLD_ALPHAI_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #8 ] +#define B [fp, #12 ] +#define C [fp, #16 ] +#define OLD_LDC [fp, #20 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -106,10 +115,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubs #define FADD_I fadds - #define FMAC_R1 fnmacs - #define FMAC_R2 fnmacs + #define FMAC_R1 vmls.f32 + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs - #define FMAC_I2 fnmacs + #define FMAC_I2 vmls.f32 #elif defined(CN) || defined(CT) @@ -118,7 +127,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #elif defined(NC) || defined(TC) @@ -127,7 +136,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_I fsubs #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs @@ -136,10 +145,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubs #define FADD_I fadds - #define FMAC_R1 fnmacs + #define FMAC_R1 vmls.f32 #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs - #define FMAC_I2 fnmacs + #define FMAC_I1 vmls.f32 + #define FMAC_I2 vmls.f32 #endif @@ -873,6 +882,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/cgemv_n_vfp.S b/kernel/arm/cgemv_n_vfp.S index 5d27486443..62ee33bb9b 100644 --- a/kernel/arm/cgemv_n_vfp.S +++ b/kernel/arm/cgemv_n_vfp.S @@ -38,11 +38,23 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR r3 +#define OLD_ALPHAI [fp, #0 ] +#define OLD_A_SOFTFP [fp, #4 ] +#define OLD_LDA [fp, #8 ] +#define X [fp, #12 ] +#define OLD_INC_X [fp, #16 ] +#define Y [fp, #20 ] +#define OLD_INC_Y [fp, #24 ] +#else +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#endif + #define OLD_A r3 #define OLD_M r0 @@ -78,42 +90,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(CONJ) && !defined(XCONJ) - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(CONJ) && !defined(XCONJ) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif !defined(CONJ) && defined(XCONJ) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #else - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #endif @@ -462,6 +474,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp N, #0 ble cgemvn_kernel_L999 +#if !defined(__ARM_PCS_VFP) + vmov s0, OLD_ALPHAR + vldr s1, OLD_ALPHAI + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_M, M vstr s0 , ALPHA_R diff --git a/kernel/arm/cgemv_t_vfp.S b/kernel/arm/cgemv_t_vfp.S index 76c8a8f189..c07b6d6f83 100644 --- a/kernel/arm/cgemv_t_vfp.S +++ b/kernel/arm/cgemv_t_vfp.S @@ -38,11 +38,23 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR r3 +#define OLD_ALPHAI [fp, #0 ] +#define OLD_A_SOFTFP [fp, #4 ] +#define OLD_LDA [fp, #8 ] +#define X [fp, #12 ] +#define OLD_INC_X [fp, #16 ] +#define Y [fp, #20 ] +#define OLD_INC_Y [fp, #24 ] +#else +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#endif + #define OLD_A r3 #define OLD_N r1 @@ -76,42 +88,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(CONJ) && !defined(XCONJ) - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(CONJ) && !defined(XCONJ) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif !defined(CONJ) && defined(XCONJ) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #else - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #endif @@ -359,6 +371,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp OLD_N, #0 ble cgemvt_kernel_L999 +#if !defined(__ARM_PCS_VFP) + vmov s0, OLD_ALPHAR + vldr s1, OLD_ALPHAI + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_N, N diff --git a/kernel/arm/ctrmm_kernel_2x2_vfp.S b/kernel/arm/ctrmm_kernel_2x2_vfp.S index 8cb7ede9da..aae890ea9a 100644 --- a/kernel/arm/ctrmm_kernel_2x2_vfp.S +++ b/kernel/arm/ctrmm_kernel_2x2_vfp.S @@ -67,10 +67,20 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP r3 +#define OLD_ALPHAI_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #8 ] +#define B [fp, #12 ] +#define C [fp, #16 ] +#define OLD_LDC [fp, #20 ] +#define OFFSET [fp, #24 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -98,42 +108,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NN) || defined(NT) || defined(TN) || defined(TT) - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(CN) || defined(CT) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmacs #define FMAC_I2 fmacs #elif defined(NC) || defined(TC) #define KMAC_R fmacs - #define KMAC_I fnmacs + #define KMAC_I vmls.f32 #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #else - #define KMAC_R fnmacs + #define KMAC_R vmls.f32 #define KMAC_I fmacs #define FMAC_R1 fmacs #define FMAC_R2 fmacs - #define FMAC_I1 fnmacs + #define FMAC_I1 vmls.f32 #define FMAC_I2 fmacs #endif @@ -826,6 +836,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/ctrmm_kernel_2x2_vfpv3.S b/kernel/arm/ctrmm_kernel_2x2_vfpv3.S index 97bd88c69c..79e7ed07fc 100644 --- a/kernel/arm/ctrmm_kernel_2x2_vfpv3.S +++ b/kernel/arm/ctrmm_kernel_2x2_vfpv3.S @@ -66,10 +66,20 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP r3 +#define OLD_ALPHAI_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #8 ] +#define B [fp, #12 ] +#define C [fp, #16 ] +#define OLD_LDC [fp, #20 ] +#define OFFSET [fp, #24 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -93,10 +103,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubs #define FADD_I fadds - #define FMAC_R1 fnmuls - #define FMAC_R2 fnmacs + #define FMAC_R1 vnmul.f32 + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmuls - #define FMAC_I2 fnmacs + #define FMAC_I2 vmls.f32 #elif defined(CN) || defined(CT) @@ -105,7 +115,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FMAC_R1 fmuls #define FMAC_R2 fmacs - #define FMAC_I1 fnmuls + #define FMAC_I1 vnmul.f32 #define FMAC_I2 fmacs #elif defined(NC) || defined(TC) @@ -114,7 +124,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_I fsubs #define FMAC_R1 fmuls - #define FMAC_R2 fnmacs + #define FMAC_R2 vmls.f32 #define FMAC_I1 fmuls #define FMAC_I2 fmacs @@ -123,10 +133,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubs #define FADD_I fadds - #define FMAC_R1 fnmuls + #define FMAC_R1 vnmul.f32 #define FMAC_R2 fmacs - #define FMAC_I1 fnmuls - #define FMAC_I2 fnmacs + #define FMAC_I1 vnmul.f32 + #define FMAC_I2 vmls.f32 #endif @@ -846,6 +856,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/ddot_vfp.S b/kernel/arm/ddot_vfp.S index f28acbae3a..fb294d8b46 100644 --- a/kernel/arm/ddot_vfp.S +++ b/kernel/arm/ddot_vfp.S @@ -246,6 +246,9 @@ ddot_kernel_L999: vldm r3, { d8 - d15} // restore floating point registers vadd.f64 d0 , d0, d1 // set return value +#if !defined(__ARM_PCS_VFP) + vmov r0, r1, d0 +#endif sub sp, fp, #24 pop {r4 - r9, fp} bx lr diff --git a/kernel/arm/dgemm_kernel_4x2_vfp.S b/kernel/arm/dgemm_kernel_4x2_vfp.S index 183269d1be..001a6050c7 100644 --- a/kernel/arm/dgemm_kernel_4x2_vfp.S +++ b/kernel/arm/dgemm_kernel_4x2_vfp.S @@ -62,10 +62,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-280] - +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #12 ] +#define B [fp, #16 ] +#define C [fp, #20 ] +#define OLD_LDC [fp, #24 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -429,6 +436,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/dgemm_kernel_4x4_vfpv3.S b/kernel/arm/dgemm_kernel_4x4_vfpv3.S index b14052e068..1744b54d8a 100644 --- a/kernel/arm/dgemm_kernel_4x4_vfpv3.S +++ b/kernel/arm/dgemm_kernel_4x4_vfpv3.S @@ -79,9 +79,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #12 ] +#define B [fp, #16 ] +#define C [fp, #20 ] +#define OLD_LDC [fp, #24 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -878,6 +886,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/dtrmm_kernel_4x2_vfp.S b/kernel/arm/dtrmm_kernel_4x2_vfp.S index c578d2b1e6..3d6fbf8e9d 100644 --- a/kernel/arm/dtrmm_kernel_4x2_vfp.S +++ b/kernel/arm/dtrmm_kernel_4x2_vfp.S @@ -65,10 +65,19 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-276 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #12 ] +#define B [fp, #16 ] +#define OLD_C [fp, #20 ] +#define OLD_LDC [fp, #24 ] +#define OFFSET [fp, #28 ] +#else #define B [fp, #4 ] #define OLD_C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -404,6 +413,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/dtrmm_kernel_4x4_vfpv3.S b/kernel/arm/dtrmm_kernel_4x4_vfpv3.S index c7e455f160..c0c6a16777 100644 --- a/kernel/arm/dtrmm_kernel_4x4_vfpv3.S +++ b/kernel/arm/dtrmm_kernel_4x4_vfpv3.S @@ -66,10 +66,19 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-276 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP [fp, #4] +#define OLD_A_SOFTFP [fp, #12 ] +#define B [fp, #16 ] +#define OLD_C [fp, #20 ] +#define OLD_LDC [fp, #24 ] +#define OFFSET [fp, #28 ] +#else #define B [fp, #4 ] #define OLD_C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -846,6 +855,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/gemv_n_vfp.S b/kernel/arm/gemv_n_vfp.S index 385370b7fe..7c154d7418 100644 --- a/kernel/arm/gemv_n_vfp.S +++ b/kernel/arm/gemv_n_vfp.S @@ -38,11 +38,36 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) + +#if !defined(DOUBLE) +#define OLD_ALPHA r3 +#define OLD_A_SOFTFP [fp, #0 ] +#define OLD_LDA [fp, #4 ] +#define X [fp, #8 ] +#define OLD_INC_X [fp, #12 ] +#define Y [fp, #16 ] +#define OLD_INC_Y [fp, #20 ] +#else +#define OLD_ALPHA [fp, #0 ] +#define OLD_A_SOFTFP [fp, #8 ] +#define OLD_LDA [fp, #12] +#define X [fp, #16] +#define OLD_INC_X [fp, #20] +#define Y [fp, #24] +#define OLD_INC_Y [fp, #28] +#endif + +#else + +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] + +#endif + #define OLD_A r3 #define OLD_M r0 @@ -508,6 +533,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp N, #0 ble gemvn_kernel_L999 +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov s0, OLD_ALPHA +#else + vldr d0, OLD_ALPHA +#endif + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_M, M diff --git a/kernel/arm/gemv_n_vfpv3.S b/kernel/arm/gemv_n_vfpv3.S index e7938e81c0..54f958b7be 100644 --- a/kernel/arm/gemv_n_vfpv3.S +++ b/kernel/arm/gemv_n_vfpv3.S @@ -38,11 +38,36 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) + +#if !defined(DOUBLE) +#define OLD_ALPHA r3 +#define OLD_A_SOFTFP [fp, #0 ] +#define OLD_LDA [fp, #4 ] +#define X [fp, #8 ] +#define OLD_INC_X [fp, #12 ] +#define Y [fp, #16 ] +#define OLD_INC_Y [fp, #20 ] +#else +#define OLD_ALPHA [fp, #0 ] +#define OLD_A_SOFTFP [fp, #8 ] +#define OLD_LDA [fp, #12] +#define X [fp, #16] +#define OLD_INC_X [fp, #20] +#define Y [fp, #24] +#define OLD_INC_Y [fp, #28] +#endif + +#else + +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] + +#endif + #define OLD_A r3 #define OLD_M r0 @@ -552,6 +577,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp N, #0 ble gemvn_kernel_L999 +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov s0, OLD_ALPHA +#else + vldr d0, OLD_ALPHA +#endif + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_M, M diff --git a/kernel/arm/gemv_t_vfp.S b/kernel/arm/gemv_t_vfp.S index c3b4e0525e..9559d18296 100644 --- a/kernel/arm/gemv_t_vfp.S +++ b/kernel/arm/gemv_t_vfp.S @@ -38,11 +38,36 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) + +#if !defined(DOUBLE) +#define OLD_ALPHA r3 +#define OLD_A_SOFTFP [fp, #0 ] +#define OLD_LDA [fp, #4 ] +#define X [fp, #8 ] +#define OLD_INC_X [fp, #12 ] +#define Y [fp, #16 ] +#define OLD_INC_Y [fp, #20 ] +#else +#define OLD_ALPHA [fp, #0 ] +#define OLD_A_SOFTFP [fp, #8 ] +#define OLD_LDA [fp, #12] +#define X [fp, #16] +#define OLD_INC_X [fp, #20] +#define Y [fp, #24] +#define OLD_INC_Y [fp, #28] +#endif + +#else + +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] + +#endif + #define OLD_A r3 #define OLD_N r1 @@ -505,6 +530,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp OLD_N, #0 ble gemvt_kernel_L999 +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov s0, OLD_ALPHA +#else + vldr d0, OLD_ALPHA +#endif + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_N, N diff --git a/kernel/arm/gemv_t_vfpv3.S b/kernel/arm/gemv_t_vfpv3.S index 7ae5799bc8..b1d3dadf16 100644 --- a/kernel/arm/gemv_t_vfpv3.S +++ b/kernel/arm/gemv_t_vfpv3.S @@ -38,11 +38,36 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) + +#if !defined(DOUBLE) +#define OLD_ALPHA r3 +#define OLD_A_SOFTFP [fp, #0 ] +#define OLD_LDA [fp, #4 ] +#define X [fp, #8 ] +#define OLD_INC_X [fp, #12 ] +#define Y [fp, #16 ] +#define OLD_INC_Y [fp, #20 ] +#else +#define OLD_ALPHA [fp, #0 ] +#define OLD_A_SOFTFP [fp, #8 ] +#define OLD_LDA [fp, #12] +#define X [fp, #16] +#define OLD_INC_X [fp, #20] +#define Y [fp, #24] +#define OLD_INC_Y [fp, #28] +#endif + +#else + +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] + +#endif + #define OLD_A r3 #define OLD_N r1 @@ -476,6 +501,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp OLD_N, #0 ble gemvt_kernel_L999 +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov s0, OLD_ALPHA +#else + vldr d0, OLD_ALPHA +#endif + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_N, N diff --git a/kernel/arm/nrm2_vfp.S b/kernel/arm/nrm2_vfp.S index b3bd28152c..16ac5a6324 100644 --- a/kernel/arm/nrm2_vfp.S +++ b/kernel/arm/nrm2_vfp.S @@ -573,6 +573,13 @@ nrm2_kernel_L999: #else vsqrt.f32 s1, s1 vmul.f32 s0, s0, s1 +#endif +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vmov r0, s0 +#else + vmov r0, r1, d0 +#endif #endif bx lr diff --git a/kernel/arm/nrm2_vfpv3.S b/kernel/arm/nrm2_vfpv3.S index f676f514af..84977901d7 100644 --- a/kernel/arm/nrm2_vfpv3.S +++ b/kernel/arm/nrm2_vfpv3.S @@ -505,6 +505,14 @@ nrm2_kernel_L999: vmul.f32 s0, s0, s1 #endif +#if !defined(__ARM_PCS_VFP) +#if defined(DOUBLE) + vmov r0, r1, d0 +#else + vmov r0, s0 +#endif +#endif + bx lr EPILOGUE diff --git a/kernel/arm/rot_vfp.S b/kernel/arm/rot_vfp.S index d053423b66..25f5636906 100644 --- a/kernel/arm/rot_vfp.S +++ b/kernel/arm/rot_vfp.S @@ -40,6 +40,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define OLD_INC_Y [fp, #0 ] +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) +#define OLD_C [fp, #4] +#define OLD_S [fp, #8] +#else +#define OLD_C [fp, #8] +#define OLD_S [fp, #16] +#endif +#endif #define N r0 #define X r1 @@ -73,7 +82,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -82,7 +91,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -91,7 +100,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -100,7 +109,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -114,7 +123,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -127,7 +136,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d5 vmul.f64 d3 , d0, d5 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X, { d2 } fstmiad Y, { d3 } @@ -145,7 +154,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -154,7 +163,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -163,7 +172,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -172,7 +181,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -186,7 +195,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -199,7 +208,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s5 vmul.f32 s3 , s0, s5 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X, { s2 } fstmias Y, { s3 } @@ -226,13 +235,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -241,13 +250,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -259,13 +268,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -274,13 +283,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -294,13 +303,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 fstmiad X!, { d2 } fstmiad Y!, { d3 } vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 fstmiad X!, { d2 } fstmiad Y!, { d3 } @@ -314,13 +323,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f64 d2 , d0, d4 fmacd d2 , d1, d6 vmul.f64 d3 , d0, d6 - fnmacd d3 , d1, d4 + vmls.f64 d3 , d1, d4 vstr d2 , [ X, #0 ] vstr d3 , [ Y, #0 ] vmul.f64 d2 , d0, d5 fmacd d2 , d1, d7 vmul.f64 d3 , d0, d7 - fnmacd d3 , d1, d5 + vmls.f64 d3 , d1, d5 vstr d2 , [ X, #8 ] vstr d3 , [ Y, #8 ] @@ -343,13 +352,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -358,13 +367,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -376,13 +385,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -391,13 +400,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -411,13 +420,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 fstmias X!, { s2 } fstmias Y!, { s3 } vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 fstmias X!, { s2 } fstmias Y!, { s3 } @@ -431,13 +440,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vmul.f32 s2 , s0, s4 fmacs s2 , s1, s6 vmul.f32 s3 , s0, s6 - fnmacs s3 , s1, s4 + vmls.f32 s3 , s1, s4 vstr s2 , [ X, #0 ] vstr s3 , [ Y, #0 ] vmul.f32 s2 , s0, s5 fmacs s2 , s1, s7 vmul.f32 s3 , s0, s7 - fnmacs s3 , s1, s5 + vmls.f32 s3 , s1, s5 vstr s2 , [ X, #4 ] vstr s3 , [ Y, #4 ] @@ -462,7 +471,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #8 ldr INC_Y , OLD_INC_Y - +#if !defined(__ARM_PCS_VFP) +#if !defined(DOUBLE) + vldr s0, OLD_C + vldr s1, OLD_S +#else + vldr d0, OLD_C + vldr d1, OLD_S +#endif +#endif cmp N, #0 ble rot_kernel_L999 diff --git a/kernel/arm/scal_vfp.S b/kernel/arm/scal_vfp.S index a8939c3a20..cc3e3b98d9 100644 --- a/kernel/arm/scal_vfp.S +++ b/kernel/arm/scal_vfp.S @@ -138,14 +138,14 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X!, { d2 - d3 } fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X!, { d2 - d3 } @@ -154,14 +154,14 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X!, { d2 - d3 } fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X!, { d2 - d3 } @@ -173,7 +173,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X!, { d2 - d3 } @@ -184,7 +184,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmiad X, { d4 - d5 } vmul.f64 d2, d0, d4 - fnmacd d2, d1, d5 + vmls.f64 d2, d1, d5 vmul.f64 d3, d0, d5 fmacd d3, d1, d4 fstmiad X, { d2 - d3 } @@ -201,28 +201,28 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X!, { s2 - s3 } fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X!, { s2 - s3 } fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X!, { s2 - s3 } fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X!, { s2 - s3 } @@ -234,7 +234,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X!, { s2 - s3 } @@ -245,7 +245,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fldmias X, { s4 - s5 } vmul.f32 s2, s0, s4 - fnmacs s2, s1, s5 + vmls.f32 s2, s1, s5 vmul.f32 s3, s0, s5 fmacs s3, s1, s4 fstmias X, { s2 - s3 } diff --git a/kernel/arm/sdot_vfp.S b/kernel/arm/sdot_vfp.S index aa6748c9f6..5f4f424bfc 100644 --- a/kernel/arm/sdot_vfp.S +++ b/kernel/arm/sdot_vfp.S @@ -329,14 +329,19 @@ sdot_kernel_L999: vldm r3, { s8 - s15} // restore floating point registers #if defined(DSDOT) - vadd.f64 d0 , d0, d1 // set return value - #else - vadd.f32 s0 , s0, s1 // set return value +#endif +#if !defined(__ARM_PCS_VFP) +#if defined(DSDOT) + vmov r0, r1, d0 +#else + vmov r0, s0 #endif +#endif + sub sp, fp, #24 pop {r4 - r9, fp} bx lr diff --git a/kernel/arm/sgemm_kernel_4x2_vfp.S b/kernel/arm/sgemm_kernel_4x2_vfp.S index e8b44b742d..1f21e5a1f8 100644 --- a/kernel/arm/sgemm_kernel_4x2_vfp.S +++ b/kernel/arm/sgemm_kernel_4x2_vfp.S @@ -62,9 +62,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP r3 +#define OLD_A_SOFTFP [fp, #4 ] +#define B [fp, #8 ] +#define C [fp, #12 ] +#define OLD_LDC [fp, #16 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -416,6 +424,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/sgemm_kernel_4x4_vfpv3.S b/kernel/arm/sgemm_kernel_4x4_vfpv3.S index 18527263d8..6491d35718 100644 --- a/kernel/arm/sgemm_kernel_4x4_vfpv3.S +++ b/kernel/arm/sgemm_kernel_4x4_vfpv3.S @@ -79,9 +79,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP r3 +#define OLD_A_SOFTFP [fp, #4 ] +#define B [fp, #8 ] +#define C [fp, #12 ] +#define OLD_LDC [fp, #16 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -851,6 +859,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/strmm_kernel_4x2_vfp.S b/kernel/arm/strmm_kernel_4x2_vfp.S index 8f97644eca..635b1dd13d 100644 --- a/kernel/arm/strmm_kernel_4x2_vfp.S +++ b/kernel/arm/strmm_kernel_4x2_vfp.S @@ -65,10 +65,19 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-276 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP r3 +#define OLD_A_SOFTFP [fp, #4 ] +#define B [fp, #8 ] +#define OLD_C [fp, #12 ] +#define OLD_LDC [fp, #16 ] +#define OFFSET [fp, #20 ] +#else #define B [fp, #4 ] #define OLD_C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -395,6 +404,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/strmm_kernel_4x4_vfpv3.S b/kernel/arm/strmm_kernel_4x4_vfpv3.S index 0dd03ac850..e24d24ebad 100644 --- a/kernel/arm/strmm_kernel_4x4_vfpv3.S +++ b/kernel/arm/strmm_kernel_4x4_vfpv3.S @@ -64,10 +64,19 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHA_SOFTFP r3 +#define OLD_A_SOFTFP [fp, #4 ] +#define B [fp, #8 ] +#define C [fp, #12 ] +#define OLD_LDC [fp, #16 ] +#define OFFSET [fp, #20 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -782,6 +791,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vmov OLD_ALPHA, OLD_ALPHA_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/swap_vfp.S b/kernel/arm/swap_vfp.S index 3528751887..76661da797 100644 --- a/kernel/arm/swap_vfp.S +++ b/kernel/arm/swap_vfp.S @@ -38,9 +38,43 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 +#if !defined(__ARM_PCS_VFP) + +#if !defined(COMPLEX) + +#if !defined(DOUBLE) +#define OLD_X [fp, #0 ] +#define OLD_INC_X [fp, #4 ] +#define OLD_Y [fp, #8 ] +#define OLD_INC_Y [fp, #12 ] +#else +#define OLD_X [fp, #8 ] +#define OLD_INC_X [fp, #12] +#define OLD_Y [fp, #16] +#define OLD_INC_Y [fp, #20] +#endif + +#else //COMPLEX + +#if !defined(DOUBLE) +#define OLD_X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define OLD_Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#else +#define OLD_X [fp, #16] +#define OLD_INC_X [fp, #20] +#define OLD_Y [fp, #24] +#define OLD_INC_Y [fp, #28] +#endif + +#endif // !defined(__ARM_PCS_VFP) + +#else #define OLD_INC_X [fp, #0 ] #define OLD_Y [fp, #4 ] #define OLD_INC_Y [fp, #8 ] +#endif #define N r0 @@ -229,6 +263,9 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. push {r4 , fp} add fp, sp, #8 +#if !defined(__ARM_PCS_VFP) + ldr X, OLD_X +#endif ldr INC_X , OLD_INC_X ldr Y, OLD_Y ldr INC_Y , OLD_INC_Y diff --git a/kernel/arm/zdot.c b/kernel/arm/zdot.c index 57f47e58e4..733c235c64 100644 --- a/kernel/arm/zdot.c +++ b/kernel/arm/zdot.c @@ -36,12 +36,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#ifndef _MSC_VER -#include -FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#else OPENBLAS_COMPLEX_FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#endif + { BLASLONG i=0; BLASLONG ix=0,iy=0; diff --git a/kernel/arm/zdot_vfp.S b/kernel/arm/zdot_vfp.S index 936ce9f60f..43f2c0c0bf 100644 --- a/kernel/arm/zdot_vfp.S +++ b/kernel/arm/zdot_vfp.S @@ -41,8 +41,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define N r0 #define X r1 #define INC_X r2 -#define OLD_Y r3 - /****************************************************** * [fp, #-128] - [fp, #-64] is reserved @@ -50,7 +48,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * registers *******************************************************/ -#define OLD_INC_Y [fp, #4 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_RETURN_ADDR r0 +#define OLD_N r1 +#define OLD_X r2 +#define OLD_INC_X r3 +#define OLD_Y [fp, #0 ] +#define OLD_INC_Y [fp, #4 ] +#define RETURN_ADDR r8 +#else +#define OLD_Y r3 +#define OLD_INC_Y [fp, #0 ] +#endif #define I r5 #define Y r6 @@ -181,7 +190,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. .align 5 push {r4 - r9, fp} - add fp, sp, #24 + add fp, sp, #28 sub sp, sp, #STACKSIZE // reserve stack sub r4, fp, #128 @@ -194,9 +203,17 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vcvt.f64.f32 d2, s0 vcvt.f64.f32 d3, s0 +#if !defined(__ARM_PCS_VFP) + mov RETURN_ADDR, OLD_RETURN_ADDR + mov N, OLD_N + mov X, OLD_X + mov INC_X, OLD_INC_X + ldr Y, OLD_Y + ldr INC_Y, OLD_INC_Y +#else mov Y, OLD_Y ldr INC_Y, OLD_INC_Y - +#endif cmp N, #0 ble zdot_kernel_L999 @@ -280,8 +297,11 @@ zdot_kernel_L999: vadd.f64 d0 , d0, d2 vsub.f64 d1 , d1, d3 #endif +#if !defined(__ARM_PCS_VFP) + vstm RETURN_ADDR, {d0 - d1} +#endif - sub sp, fp, #24 + sub sp, fp, #28 pop {r4 - r9, fp} bx lr diff --git a/kernel/arm/zgemm_kernel_2x2_vfp.S b/kernel/arm/zgemm_kernel_2x2_vfp.S index 46507c4d21..53d18b07b7 100644 --- a/kernel/arm/zgemm_kernel_2x2_vfp.S +++ b/kernel/arm/zgemm_kernel_2x2_vfp.S @@ -64,9 +64,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP [fp, #4] +#define OLD_ALPHAI_SOFTFP [fp, #12] +#define OLD_A_SOFTFP [fp, #20 ] +#define B [fp, #24 ] +#define C [fp, #28 ] +#define OLD_LDC [fp, #32 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -87,42 +96,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NN) || defined(NT) || defined(TN) || defined(TT) - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(CN) || defined(CT) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(NC) || defined(TC) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #else - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #endif @@ -863,6 +872,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/zgemm_kernel_2x2_vfpv3.S b/kernel/arm/zgemm_kernel_2x2_vfpv3.S index 5a99f792ff..a9d4eddebf 100644 --- a/kernel/arm/zgemm_kernel_2x2_vfpv3.S +++ b/kernel/arm/zgemm_kernel_2x2_vfpv3.S @@ -80,9 +80,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP [fp, #4] +#define OLD_ALPHAI_SOFTFP [fp, #12] +#define OLD_A_SOFTFP [fp, #20 ] +#define B [fp, #24 ] +#define C [fp, #28 ] +#define OLD_LDC [fp, #32 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] +#endif #define I r0 #define J r1 @@ -106,10 +115,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubd #define FADD_I faddd - #define FMAC_R1 fnmacd - #define FMAC_R2 fnmacd + #define FMAC_R1 vmls.f64 + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd - #define FMAC_I2 fnmacd + #define FMAC_I2 vmls.f64 #elif defined(CN) || defined(CT) @@ -118,7 +127,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #elif defined(NC) || defined(TC) @@ -127,7 +136,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_I fsubd #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd @@ -136,10 +145,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubd #define FADD_I faddd - #define FMAC_R1 fnmacd + #define FMAC_R1 vmls.f64 #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd - #define FMAC_I2 fnmacd + #define FMAC_I1 vmls.f64 + #define FMAC_I2 vmls.f64 #endif @@ -909,6 +918,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/zgemv_n_vfp.S b/kernel/arm/zgemv_n_vfp.S index da9a91043e..3e3a1bc075 100644 --- a/kernel/arm/zgemv_n_vfp.S +++ b/kernel/arm/zgemv_n_vfp.S @@ -38,11 +38,23 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR [fp, #0 ] +#define OLD_ALPHAI [fp, #8 ] +#define OLD_A_SOFTFP [fp, #16] +#define OLD_LDA [fp, #20] +#define X [fp, #24] +#define OLD_INC_X [fp, #28] +#define Y [fp, #32] +#define OLD_INC_Y [fp, #36] +#else +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#endif + #define OLD_A r3 #define OLD_M r0 @@ -79,42 +91,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(CONJ) && !defined(XCONJ) - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(CONJ) && !defined(XCONJ) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif !defined(CONJ) && defined(XCONJ) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #else - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #endif @@ -465,6 +477,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp N, #0 ble zgemvn_kernel_L999 +#if !defined(__ARM_PCS_VFP) + vldr d0, OLD_ALPHAR + vldr d1, OLD_ALPHAI + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_M, M vstr d0 , ALPHA_R diff --git a/kernel/arm/zgemv_t_vfp.S b/kernel/arm/zgemv_t_vfp.S index 211fa07011..2193083af9 100644 --- a/kernel/arm/zgemv_t_vfp.S +++ b/kernel/arm/zgemv_t_vfp.S @@ -38,11 +38,23 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define STACKSIZE 256 -#define OLD_LDA [fp, #0 ] -#define X [fp, #4 ] -#define OLD_INC_X [fp, #8 ] -#define Y [fp, #12 ] -#define OLD_INC_Y [fp, #16 ] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR [fp, #0 ] +#define OLD_ALPHAI [fp, #8 ] +#define OLD_A_SOFTFP [fp, #16] +#define OLD_LDA [fp, #20] +#define X [fp, #24] +#define OLD_INC_X [fp, #28] +#define Y [fp, #32] +#define OLD_INC_Y [fp, #36] +#else +#define OLD_LDA [fp, #0 ] +#define X [fp, #4 ] +#define OLD_INC_X [fp, #8 ] +#define Y [fp, #12 ] +#define OLD_INC_Y [fp, #16 ] +#endif + #define OLD_A r3 #define OLD_N r1 @@ -77,42 +89,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(CONJ) && !defined(XCONJ) - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(CONJ) && !defined(XCONJ) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif !defined(CONJ) && defined(XCONJ) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #else - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #endif @@ -360,6 +372,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cmp OLD_N, #0 ble zgemvt_kernel_L999 +#if !defined(__ARM_PCS_VFP) + vldr d0, OLD_ALPHAR + vldr d1, OLD_ALPHAI + ldr OLD_A, OLD_A_SOFTFP +#endif + str OLD_A, A str OLD_N, N diff --git a/kernel/arm/ztrmm_kernel_2x2_vfp.S b/kernel/arm/ztrmm_kernel_2x2_vfp.S index dc80b17b87..cb6bc050e4 100644 --- a/kernel/arm/ztrmm_kernel_2x2_vfp.S +++ b/kernel/arm/ztrmm_kernel_2x2_vfp.S @@ -66,10 +66,20 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP [fp, #4] +#define OLD_ALPHAI_SOFTFP [fp, #12] +#define OLD_A_SOFTFP [fp, #20 ] +#define B [fp, #24 ] +#define C [fp, #28 ] +#define OLD_LDC [fp, #32 ] +#define OFFSET [fp, #36 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -96,42 +106,42 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NN) || defined(NT) || defined(TN) || defined(TT) - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(CN) || defined(CT) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmacd #define FMAC_I2 fmacd #elif defined(NC) || defined(TC) #define KMAC_R fmacd - #define KMAC_I fnmacd + #define KMAC_I vmls.f64 #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #else - #define KMAC_R fnmacd + #define KMAC_R vmls.f64 #define KMAC_I fmacd #define FMAC_R1 fmacd #define FMAC_R2 fmacd - #define FMAC_I1 fnmacd + #define FMAC_I1 vmls.f64 #define FMAC_I2 fmacd #endif @@ -882,6 +892,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm/ztrmm_kernel_2x2_vfpv3.S b/kernel/arm/ztrmm_kernel_2x2_vfpv3.S index 5a808ccbc1..3e6962f06f 100644 --- a/kernel/arm/ztrmm_kernel_2x2_vfpv3.S +++ b/kernel/arm/ztrmm_kernel_2x2_vfpv3.S @@ -66,10 +66,20 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define ALPHA_I [fp, #-272] #define ALPHA_R [fp, #-280] +#if !defined(__ARM_PCS_VFP) +#define OLD_ALPHAR_SOFTFP [fp, #4] +#define OLD_ALPHAI_SOFTFP [fp, #12] +#define OLD_A_SOFTFP [fp, #20 ] +#define B [fp, #24 ] +#define C [fp, #28 ] +#define OLD_LDC [fp, #32 ] +#define OFFSET [fp, #36 ] +#else #define B [fp, #4 ] #define C [fp, #8 ] #define OLD_LDC [fp, #12 ] #define OFFSET [fp, #16 ] +#endif #define I r0 #define J r1 @@ -93,10 +103,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubd #define FADD_I faddd - #define FMAC_R1 fnmuld - #define FMAC_R2 fnmacd + #define FMAC_R1 vnmul.f64 + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmuld - #define FMAC_I2 fnmacd + #define FMAC_I2 vmls.f64 #elif defined(CN) || defined(CT) @@ -105,7 +115,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FMAC_R1 fmuld #define FMAC_R2 fmacd - #define FMAC_I1 fnmuld + #define FMAC_I1 vnmul.f64 #define FMAC_I2 fmacd #elif defined(NC) || defined(TC) @@ -114,7 +124,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_I fsubd #define FMAC_R1 fmuld - #define FMAC_R2 fnmacd + #define FMAC_R2 vmls.f64 #define FMAC_I1 fmuld #define FMAC_I2 fmacd @@ -123,10 +133,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define FADD_R fsubd #define FADD_I faddd - #define FMAC_R1 fnmuld + #define FMAC_R1 vnmul.f64 #define FMAC_R2 fmacd - #define FMAC_I1 fnmuld - #define FMAC_I2 fnmacd + #define FMAC_I1 vnmul.f64 + #define FMAC_I2 vmls.f64 #endif @@ -883,6 +893,11 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. add fp, sp, #24 sub sp, sp, #STACKSIZE // reserve stack +#if !defined(__ARM_PCS_VFP) + vldr OLD_ALPHA_R, OLD_ALPHAR_SOFTFP + vldr OLD_ALPHA_I, OLD_ALPHAI_SOFTFP + ldr OLD_A, OLD_A_SOFTFP +#endif str OLD_M, M str OLD_N, N str OLD_K, K diff --git a/kernel/arm64/KERNEL.CORTEXA57 b/kernel/arm64/KERNEL.CORTEXA57 index 64666f05ba..2bf88867e7 100644 --- a/kernel/arm64/KERNEL.CORTEXA57 +++ b/kernel/arm64/KERNEL.CORTEXA57 @@ -75,14 +75,29 @@ SGEMMOTCOPYOBJ = sgemm_otcopy.o DGEMMKERNEL = dgemm_kernel_$(DGEMM_UNROLL_M)x$(DGEMM_UNROLL_N).S DTRMMKERNEL = dtrmm_kernel_$(DGEMM_UNROLL_M)x$(DGEMM_UNROLL_N).S + ifneq ($(DGEMM_UNROLL_M), $(DGEMM_UNROLL_N)) + +ifeq ($(DGEMM_UNROLL_M), 8) +DGEMMINCOPY = dgemm_ncopy_$(DGEMM_UNROLL_M).S +DGEMMITCOPY = dgemm_tcopy_$(DGEMM_UNROLL_M).S +else DGEMMINCOPY = ../generic/gemm_ncopy_$(DGEMM_UNROLL_M).c DGEMMITCOPY = ../generic/gemm_tcopy_$(DGEMM_UNROLL_M).c +endif + DGEMMINCOPYOBJ = dgemm_incopy.o DGEMMITCOPYOBJ = dgemm_itcopy.o endif + +ifeq ($(DGEMM_UNROLL_N), 4) +DGEMMONCOPY = dgemm_ncopy_$(DGEMM_UNROLL_N).S +DGEMMOTCOPY = dgemm_tcopy_$(DGEMM_UNROLL_N).S +else DGEMMONCOPY = ../generic/gemm_ncopy_$(DGEMM_UNROLL_N).c DGEMMOTCOPY = ../generic/gemm_tcopy_$(DGEMM_UNROLL_N).c +endif + DGEMMONCOPYOBJ = dgemm_oncopy.o DGEMMOTCOPYOBJ = dgemm_otcopy.o diff --git a/kernel/arm64/KERNEL.THUNDERX b/kernel/arm64/KERNEL.THUNDERX new file mode 100644 index 0000000000..11b7a2ca8b --- /dev/null +++ b/kernel/arm64/KERNEL.THUNDERX @@ -0,0 +1,6 @@ +include $(KERNELDIR)/KERNEL.ARMV8 + +SDOTKERNEL=dot_thunderx.c +DDOTKERNEL=ddot_thunderx.c +DAXPYKERNEL=daxpy_thunderx.c + diff --git a/kernel/arm64/KERNEL.THUNDERX2T99 b/kernel/arm64/KERNEL.THUNDERX2T99 new file mode 100644 index 0000000000..b66cd0e8bc --- /dev/null +++ b/kernel/arm64/KERNEL.THUNDERX2T99 @@ -0,0 +1,51 @@ +include $(KERNELDIR)/KERNEL.CORTEXA57 + +SASUMKERNEL = sasum_thunderx2t99.c +DASUMKERNEL = dasum_thunderx2t99.c +CASUMKERNEL = casum_thunderx2t99.c +ZASUMKERNEL = zasum_thunderx2t99.c + +SCOPYKERNEL = copy_thunderx2t99.c +DCOPYKERNEL = copy_thunderx2t99.c +CCOPYKERNEL = copy_thunderx2t99.c +ZCOPYKERNEL = copy_thunderx2t99.c + +SSWAPKERNEL = swap_thunderx2t99.S +DSWAPKERNEL = swap_thunderx2t99.S +CSWAPKERNEL = swap_thunderx2t99.S +ZSWAPKERNEL = swap_thunderx2t99.S + +ISAMAXKERNEL = iamax_thunderx2t99.c +IDAMAXKERNEL = iamax_thunderx2t99.c +ICAMAXKERNEL = izamax_thunderx2t99.c +IZAMAXKERNEL = izamax_thunderx2t99.c + +SNRM2KERNEL = scnrm2_thunderx2t99.c +CNRM2KERNEL = scnrm2_thunderx2t99.c +#DNRM2KERNEL = dznrm2_thunderx2t99_fast.c +#ZNRM2KERNEL = dznrm2_thunderx2t99_fast.c +DNRM2KERNEL = dznrm2_thunderx2t99.c +ZNRM2KERNEL = dznrm2_thunderx2t99.c + +DAXPYKERNEL = daxpy_thunderx2t99.S + +DDOTKERNEL = dot_thunderx2t99.c +SDOTKERNEL = dot_thunderx2t99.c +CDOTKERNEL = zdot_thunderx2t99.c +ZDOTKERNEL = zdot_thunderx2t99.c + +ifeq ($(DGEMM_UNROLL_M)x$(DGEMM_UNROLL_N), 8x4) +DGEMMKERNEL = dgemm_kernel_8x4_thunderx2t99.S +endif + +ifeq ($(SGEMM_UNROLL_M)x$(SGEMM_UNROLL_N), 16x4) +SGEMMKERNEL = sgemm_kernel_16x4_thunderx2t99.S +endif + +ifeq ($(CGEMM_UNROLL_M)x$(CGEMM_UNROLL_N), 8x4) +CGEMMKERNEL = cgemm_kernel_8x4_thunderx2t99.S +endif + +ifeq ($(ZGEMM_UNROLL_M)x$(ZGEMM_UNROLL_N), 4x4) +ZGEMMKERNEL = zgemm_kernel_4x4_thunderx2t99.S +endif diff --git a/kernel/arm64/KERNEL.VULCAN b/kernel/arm64/KERNEL.VULCAN new file mode 100644 index 0000000000..8b02739519 --- /dev/null +++ b/kernel/arm64/KERNEL.VULCAN @@ -0,0 +1,3 @@ +include $(KERNELDIR)/KERNEL.THUNDERX2T99 + + diff --git a/kernel/arm64/casum_thunderx2t99.c b/kernel/arm64/casum_thunderx2t99.c new file mode 100644 index 0000000000..4dac2e8ab5 --- /dev/null +++ b/kernel/arm64/casum_thunderx2t99.c @@ -0,0 +1,268 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#include + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define J "x5" /* loop variable */ + +#define REG0 "wzr" +#define SUMF "s0" +#define SUMFD "d0" + +/******************************************************************************/ + +#define KERNEL_F1 \ + "ldr d1, ["X"] \n" \ + "add "X", "X", #8 \n" \ + "fabs v1.2s, v1.2s \n" \ + "ext v2.8b, v1.8b, v1.8b, #4 \n" \ + "fadd s1, s1, s2 \n" \ + "fadd "SUMF", "SUMF", s1 \n" + +#define KERNEL_F32 \ + "ldr q16, ["X"] \n" \ + "ldr q17, ["X", #16] \n" \ + "ldr q18, ["X", #32] \n" \ + "ldr q19, ["X", #48] \n" \ + "ldp q20, q21, ["X", #64] \n" \ + "ldp q22, q23, ["X", #96] \n" \ + "fabs v16.4s, v16.4s \n" \ + "fabs v17.4s, v17.4s \n" \ + "fabs v18.4s, v18.4s \n" \ + "fabs v19.4s, v19.4s \n" \ + "ldp q24, q25, ["X", #128] \n" \ + "ldp q26, q27, ["X", #160] \n" \ + "fabs v20.4s, v20.4s \n" \ + "fabs v21.4s, v21.4s \n" \ + "fabs v22.4s, v22.4s \n" \ + "fabs v23.4s, v23.4s \n" \ + "fadd v16.4s, v16.4s, v17.4s \n" \ + "fadd v18.4s, v18.4s, v19.4s \n" \ + "ldp q28, q29, ["X", #192] \n" \ + "ldp q30, q31, ["X", #224] \n" \ + "fabs v24.4s, v24.4s \n" \ + "fabs v25.4s, v25.4s \n" \ + "fabs v26.4s, v26.4s \n" \ + "fabs v27.4s, v27.4s \n" \ + "add "X", "X", #256 \n" \ + "fadd v20.4s, v20.4s, v21.4s \n" \ + "fadd v22.4s, v22.4s, v23.4s \n" \ + "fabs v28.4s, v28.4s \n" \ + "fabs v29.4s, v29.4s \n" \ + "fabs v30.4s, v30.4s \n" \ + "fabs v31.4s, v31.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "fadd v24.4s, v24.4s, v25.4s \n" \ + "fadd v26.4s, v26.4s, v27.4s \n" \ + "fadd v0.4s, v0.4s, v16.4s \n" \ + "fadd v1.4s, v1.4s, v18.4s \n" \ + "fadd v2.4s, v2.4s, v20.4s \n" \ + "fadd v3.4s, v3.4s, v22.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fadd v28.4s, v28.4s, v29.4s \n" \ + "fadd v30.4s, v30.4s, v31.4s \n" \ + "fadd v4.4s, v4.4s, v24.4s \n" \ + "fadd v5.4s, v5.4s, v26.4s \n" \ + "fadd v6.4s, v6.4s, v28.4s \n" \ + "fadd v7.4s, v7.4s, v30.4s \n" + +#define KERNEL_F32_FINALIZE \ + "fadd v0.4s, v0.4s, v1.4s \n" \ + "fadd v2.4s, v2.4s, v3.4s \n" \ + "fadd v4.4s, v4.4s, v5.4s \n" \ + "fadd v6.4s, v6.4s, v7.4s \n" \ + "fadd v0.4s, v0.4s, v2.4s \n" \ + "fadd v4.4s, v4.4s, v6.4s \n" \ + "fadd v0.4s, v0.4s, v4.4s \n" \ + "ext v1.16b, v0.16b, v0.16b, #8 \n" \ + "fadd v0.2s, v0.2s, v1.2s \n" \ + "faddp "SUMF", v0.2s \n" + +#define INIT_S \ + "lsl "INC_X", "INC_X", #3 \n" + +#define KERNEL_S1 \ + "ldr d1, ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fabs v1.2s, v1.2s \n" \ + "ext v2.8b, v1.8b, v1.8b, #4 \n" \ + "fadd s1, s1, s2 \n" \ + "fadd "SUMF", "SUMF", s1 \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static FLOAT casum_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + FLOAT asum = 0.0 ; + + if ( n < 0 ) return(asum); + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SUMF", "REG0" \n" + " fmov s1, "REG0" \n" + " fmov s2, "REG0" \n" + " fmov s3, "REG0" \n" + " fmov s4, "REG0" \n" + " fmov s5, "REG0" \n" + " fmov s6, "REG0" \n" + " fmov s7, "REG0" \n" + " cmp "N", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lasum_kernel_S_BEGIN \n" + + ".Lasum_kernel_F_BEGIN: \n" + " asr "J", "N", #5 \n" + " cmp "J", xzr \n" + " beq .Lasum_kernel_F1 \n" + + ".Lasum_kernel_F32: \n" + " "KERNEL_F32" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F32 \n" + " "KERNEL_F32_FINALIZE" \n" + + ".Lasum_kernel_F1: \n" + " ands "J", "N", #31 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F10 \n" + " b .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S_BEGIN: \n" + " "INIT_S" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lasum_kernel_S1 \n" + + ".Lasum_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S4 \n" + + ".Lasum_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S10 \n" + + ".Lasum_kernel_L999: \n" + " fmov %[ASUM_], "SUMFD" \n" + + : [ASUM_] "=r" (asum) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return asum; +} + +#if defined(SMP) +static int casum_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *result = casum_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + FLOAT asum = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + asum = casum_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT *ptr; + + mode = BLAS_SINGLE | BLAS_COMPLEX; + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)casum_thread_function, nthreads); + + ptr = (FLOAT *)result; + for (i = 0; i < nthreads; i++) { + asum = asum + (*ptr); + ptr = (FLOAT *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + asum = casum_compute(n, x, inc_x); +#endif + + return asum; +} diff --git a/kernel/arm64/cgemm_kernel_8x4_thunderx2t99.S b/kernel/arm64/cgemm_kernel_8x4_thunderx2t99.S new file mode 100644 index 0000000000..367cd02174 --- /dev/null +++ b/kernel/arm64/cgemm_kernel_8x4_thunderx2t99.S @@ -0,0 +1,2175 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* X0 X1 X2 s0 X3 x4 x5 x6 */ +/*int CNAME(BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha0,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc */ + +#define origM x0 +#define origN x1 +#define origK x2 +#define origPA x3 +#define origPB x4 +#define pC x5 +#define LDC x6 +#define temp x7 +#define counterL x8 +#define counterI x9 +#define counterJ x10 +#define pB x11 +#define pCRow0 x12 +#define pCRow1 x13 +#define pCRow2 x14 +#define pCRow3 x15 +#define pA x16 +#define alphaR w17 +#define alphaI w18 + +#define alpha0_R s10 +#define alphaV0_R v10.s[0] +#define alpha0_I s11 +#define alphaV0_I v11.s[0] + +#define A_PRE_SIZE 2560 +#define B_PRE_SIZE 448 +#define C_PRE_SIZE 128 + +#if defined(NN) || defined(NT) || defined(TN) || defined(TT) +#define OP_rr fmla +#define OP_ii fmls +#define OP_ri fmla +#define OP_ir fmla +#elif defined(NR) || defined(NC) || defined(TR) || defined(TC) +#define OP_rr fmla +#define OP_ii fmla +#define OP_ri fmls +#define OP_ir fmla +#elif defined(RN) || defined(RT) || defined(CN) || defined(CT) +#define OP_rr fmla +#define OP_ii fmla +#define OP_ri fmla +#define OP_ir fmls +#elif defined(RR) || defined(RC) || defined(CR) || defined(CC) +#define OP_rr fmla +#define OP_ii fmls +#define OP_ri fmls +#define OP_ir fmls +#endif + +// 00 origM +// 01 origN +// 02 origK +// 03 origPA +// 04 origPB +// 05 pC +// 06 origLDC -> LDC +// 07 offset -> temp +// 08 counterL +// 09 counterI +// 10 counterJ +// 11 pB +// 12 pCRow0 +// 13 pCRow1 +// 14 pCRow2 +// 15 pCRow3 +// 16 pA +// 17 +// 18 must save +// 19 must save +// 20 must save +// 21 must save +// 22 must save +// 23 must save +// 24 must save +// 25 must save +// 26 must save +// 27 must save +// 28 must save +// 29 frame +// 30 link +// 31 sp + +//v00 ALPHA_R -> pA0_00_R, pA0_01_R, pA0_02_R, pA0_03_R +//v01 ALPHA_I -> pA0_00_I, pA0_01_I, pA0_02_I, pA0_03_I +//v02 pA0_04_R, pA0_05_R, pA0_06_R, pA0_07_R +//v03 pA0_04_I, pA0_05_I, pA0_06_I, pA0_07_I +//v04 pA1_00_R, pA1_01_R, pA1_02_R, pA1_03_R +//v05 pA1_00_I, pA1_01_I, pA1_02_I, pA1_03_I +//v06 pA1_04_R, pA1_05_R, pA1_06_R, pA1_07_R +//v07 pA1_04_I, pA1_05_I, pA1_06_I, pA1_07_I +//v08 must save pB0_00_R, pB0_01_R +//v09 must save pB0_00_I, pB0_01_I +//v10 must save pB0_02_R, pB0_03_R --> ALPHA0_R +//v11 must save pB0_02_I, pB0_03_I --> ALPHA0_I +//v12 must save pB1_00_R, pB1_01_R +//v13 must save pB1_00_I, pB1_01_I +//v14 must save pB1_02_R, pB1_03_R +//v15 must save pB1_02_I, pB1_03_I +//v16 must save pC_00_R, pC_01_R, pC_02_R, pC_03_R +//v17 must save pC_00_I, pC_01_I, pC_02_I, pC_03_I +//v18 pC_04_R, pC_05_R, pC_06_R, pC_07_R +//v19 pC_04_I, pC_05_I, pC_06_I, pC_07_I +//v20 pC_08_R, pC_09_R, pC_10_R, pC_11_R +//v21 pC_08_I, pC_09_I, pC_10_I, pC_11_I +//v22 pC_12_R, pC_13_R, pC_14_R, pC_15_R +//v23 pC_12_I, pC_13_I, pC_14_I, pC_15_I +//v24 pC_16_R, pC_17_R, pC_18_R, pC_19_R +//v25 pC_16_I, pC_17_I, pC_18_I, pC_19_I +//v26 pC_20_R, pC_21_R, pC_22_R, pC_23_R +//v27 pC_20_I, pC_21_I, pC_22_I, pC_23_I +//v28 pC_24_R, pC_25_R, pC_26_R, pC_27_R +//v29 pC_24_I, pC_25_I, pC_26_I, pC_27_I +//v30 pC_28_R, pC_29_R, pC_30_R, pC_31_R +//v31 pC_28_I, pC_29_I, pC_30_I, pC_31_I + + +/******************************************************************************* +* Macro definitions +*******************************************************************************/ + +.macro INIT8x4 + fmov s16, wzr + fmov s17, wzr + fmov s18, wzr + fmov s19, s16 + fmov s20, wzr + fmov s21, s16 + fmov s22, s17 + fmov s23, s18 + fmov s24, wzr + fmov s25, s16 + fmov s26, s17 + fmov s27, s18 + fmov s28, wzr + fmov s29, s16 + fmov s30, s17 + fmov s31, s18 +.endm + +.macro KERNEL8x4_I + ldr q8, [pB] + add pB, pB, #16 + + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + ld2 {v2.4s, v3.4s}, [pA] + add pA, pA, #32 + + fmul v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v8.s[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v17.16b, v17.16b, v17.16b + fmls v17.4s, v0.4s, v8.s[1] +#else + fmul v17.4s, v0.4s, v8.s[1] +#endif + OP_ir v17.4s, v1.4s, v8.s[0] + + ldr q10, [pB] + add pB, pB, #16 + + fmul v18.4s, v2.4s, v8.s[0] + OP_ii v18.4s, v3.4s, v8.s[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v19.16b, v19.16b, v19.16b + fmls v19.4s, v2.4s, v8.s[1] +#else + fmul v19.4s, v2.4s, v8.s[1] +#endif + OP_ir v19.4s, v3.4s, v8.s[0] + + ldr q12, [pB] + add pB, pB, #16 + + fmul v20.4s, v0.4s, v8.s[2] + OP_ii v20.4s, v1.4s, v8.s[3] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v21.16b, v21.16b, v21.16b + fmls v21.4s, v0.4s, v8.s[3] +#else + fmul v21.4s, v0.4s, v8.s[3] +#endif + OP_ir v21.4s, v1.4s, v8.s[2] + + ldr q14, [pB] + add pB, pB, #16 + + fmul v22.4s, v2.4s, v8.s[2] + OP_ii v22.4s, v3.4s, v8.s[3] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v23.16b, v23.16b, v23.16b + fmls v23.4s, v2.4s, v8.s[3] +#else + fmul v23.4s, v2.4s, v8.s[3] +#endif + OP_ir v23.4s, v3.4s, v8.s[2] + + ld2 {v4.4s, v5.4s}, [pA] + add pA, pA, #32 + + fmul v24.4s, v0.4s, v10.s[0] + OP_ii v24.4s, v1.4s, v10.s[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v25.16b, v25.16b, v25.16b + fmls v25.4s, v0.4s, v10.s[1] +#else + fmul v25.4s, v0.4s, v10.s[1] +#endif + OP_ir v25.4s, v1.4s, v10.s[0] + + ld2 {v6.4s, v7.4s}, [pA] + add pA, pA, #32 + + fmul v26.4s, v2.4s, v10.s[0] + OP_ii v26.4s, v3.4s, v10.s[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v27.16b, v27.16b, v27.16b + fmls v27.4s, v2.4s, v10.s[1] +#else + fmul v27.4s, v2.4s, v10.s[1] +#endif + OP_ir v27.4s, v3.4s, v10.s[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + fmul v28.4s, v0.4s, v10.s[2] + OP_ii v28.4s, v1.4s, v10.s[3] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v29.16b, v29.16b, v29.16b + fmls v29.4s, v0.4s, v10.s[3] +#else + fmul v29.4s, v0.4s, v10.s[3] +#endif + OP_ir v29.4s, v1.4s, v10.s[2] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] + + fmul v30.4s, v2.4s, v10.s[2] + OP_ii v30.4s, v3.4s, v10.s[3] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v31.16b, v31.16b, v31.16b + fmls v31.4s, v2.4s, v10.s[3] +#else + fmul v31.4s, v2.4s, v10.s[3] +#endif + OP_ir v31.4s, v3.4s, v10.s[2] +.endm + +.macro KERNEL8x4_M1 + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v8.s[1] + OP_ri v17.4s, v0.4s, v8.s[1] + OP_ir v17.4s, v1.4s, v8.s[0] + + ldr q12, [pB] + add pB, pB, #16 + + OP_rr v18.4s, v2.4s, v8.s[0] + OP_ii v18.4s, v3.4s, v8.s[1] + OP_ri v19.4s, v2.4s, v8.s[1] + OP_ir v19.4s, v3.4s, v8.s[0] + + ld2 {v4.4s, v5.4s}, [pA] + add pA, pA, #32 + + OP_rr v20.4s, v0.4s, v8.s[2] + OP_ii v20.4s, v1.4s, v8.s[3] + OP_ri v21.4s, v0.4s, v8.s[3] + OP_ir v21.4s, v1.4s, v8.s[2] + + ld2 {v6.4s, v7.4s}, [pA] + add pA, pA, #32 + + OP_rr v22.4s, v2.4s, v8.s[2] + OP_ii v22.4s, v3.4s, v8.s[3] + OP_ri v23.4s, v2.4s, v8.s[3] + OP_ir v23.4s, v3.4s, v8.s[2] + + ldr q14, [pB] + add pB, pB, #16 + + OP_rr v24.4s, v0.4s, v10.s[0] + OP_ii v24.4s, v1.4s, v10.s[1] + OP_ri v25.4s, v0.4s, v10.s[1] + OP_ir v25.4s, v1.4s, v10.s[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + OP_rr v26.4s, v2.4s, v10.s[0] + OP_ii v26.4s, v3.4s, v10.s[1] + OP_ri v27.4s, v2.4s, v10.s[1] + OP_ir v27.4s, v3.4s, v10.s[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] + + OP_rr v28.4s, v0.4s, v10.s[2] + OP_ii v28.4s, v1.4s, v10.s[3] + OP_ri v29.4s, v0.4s, v10.s[3] + OP_ir v29.4s, v1.4s, v10.s[2] + + OP_rr v30.4s, v2.4s, v10.s[2] + OP_ii v30.4s, v3.4s, v10.s[3] + OP_ri v31.4s, v2.4s, v10.s[3] + OP_ir v31.4s, v3.4s, v10.s[2] +.endm + +.macro KERNEL8x4_M2 + OP_rr v16.4s, v4.4s, v12.s[0] + OP_ii v16.4s, v5.4s, v12.s[1] + OP_ri v17.4s, v4.4s, v12.s[1] + OP_ir v17.4s, v5.4s, v12.s[0] + + ldr q8, [pB] + add pB, pB, #16 + + OP_rr v18.4s, v6.4s, v12.s[0] + OP_ii v18.4s, v7.4s, v12.s[1] + OP_ri v19.4s, v6.4s, v12.s[1] + OP_ir v19.4s, v7.4s, v12.s[0] + + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + OP_rr v20.4s, v4.4s, v12.s[2] + OP_ii v20.4s, v5.4s, v12.s[3] + OP_ri v21.4s, v4.4s, v12.s[3] + OP_ir v21.4s, v5.4s, v12.s[2] + + ld2 {v2.4s, v3.4s}, [pA] + add pA, pA, #32 + + OP_rr v22.4s, v6.4s, v12.s[2] + OP_ii v22.4s, v7.4s, v12.s[3] + OP_ri v23.4s, v6.4s, v12.s[3] + OP_ir v23.4s, v7.4s, v12.s[2] + + ldr q10, [pB] + add pB, pB, #16 + + OP_rr v24.4s, v4.4s, v14.s[0] + OP_ii v24.4s, v5.4s, v14.s[1] + OP_ri v25.4s, v4.4s, v14.s[1] + OP_ir v25.4s, v5.4s, v14.s[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v26.4s, v6.4s, v14.s[0] + OP_ii v26.4s, v7.4s, v14.s[1] + OP_ri v27.4s, v6.4s, v14.s[1] + OP_ir v27.4s, v7.4s, v14.s[0] + + OP_rr v28.4s, v4.4s, v14.s[2] + OP_ii v28.4s, v5.4s, v14.s[3] + OP_ri v29.4s, v4.4s, v14.s[3] + OP_ir v29.4s, v5.4s, v14.s[2] + + OP_rr v30.4s, v6.4s, v14.s[2] + OP_ii v30.4s, v7.4s, v14.s[3] + OP_ri v31.4s, v6.4s, v14.s[3] + OP_ir v31.4s, v7.4s, v14.s[2] +.endm + +.macro KERNEL8x4_E + OP_rr v16.4s, v4.4s, v12.s[0] + OP_ii v16.4s, v5.4s, v12.s[1] + OP_ri v17.4s, v4.4s, v12.s[1] + OP_ir v17.4s, v5.4s, v12.s[0] + + OP_rr v18.4s, v6.4s, v12.s[0] + OP_ii v18.4s, v7.4s, v12.s[1] + OP_ri v19.4s, v6.4s, v12.s[1] + OP_ir v19.4s, v7.4s, v12.s[0] + + OP_rr v20.4s, v4.4s, v12.s[2] + OP_ii v20.4s, v5.4s, v12.s[3] + OP_ri v21.4s, v4.4s, v12.s[3] + OP_ir v21.4s, v5.4s, v12.s[2] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v22.4s, v6.4s, v12.s[2] + OP_ii v22.4s, v7.4s, v12.s[3] + OP_ri v23.4s, v6.4s, v12.s[3] + OP_ir v23.4s, v7.4s, v12.s[2] + + OP_rr v24.4s, v4.4s, v14.s[0] + OP_ii v24.4s, v5.4s, v14.s[1] + OP_ri v25.4s, v4.4s, v14.s[1] + OP_ir v25.4s, v5.4s, v14.s[0] + + OP_rr v26.4s, v6.4s, v14.s[0] + OP_ii v26.4s, v7.4s, v14.s[1] + OP_ri v27.4s, v6.4s, v14.s[1] + OP_ir v27.4s, v7.4s, v14.s[0] + + OP_rr v28.4s, v4.4s, v14.s[2] + OP_ii v28.4s, v5.4s, v14.s[3] + OP_ri v29.4s, v4.4s, v14.s[3] + OP_ir v29.4s, v5.4s, v14.s[2] + + OP_rr v30.4s, v6.4s, v14.s[2] + OP_ii v30.4s, v7.4s, v14.s[3] + OP_ri v31.4s, v6.4s, v14.s[3] + OP_ir v31.4s, v7.4s, v14.s[2] +.endm + +.macro KERNEL8x4_SUB + ldr q8, [pB] + add pB, pB, #16 + + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v8.s[1] + OP_ri v17.4s, v0.4s, v8.s[1] + OP_ir v17.4s, v1.4s, v8.s[0] + + ld2 {v2.4s, v3.4s}, [pA] + add pA, pA, #32 + + OP_rr v20.4s, v0.4s, v8.s[2] + OP_ii v20.4s, v1.4s, v8.s[3] + OP_ri v21.4s, v0.4s, v8.s[3] + OP_ir v21.4s, v1.4s, v8.s[2] + + ldr q10, [pB] + add pB, pB, #16 + + OP_rr v18.4s, v2.4s, v8.s[0] + OP_ii v18.4s, v3.4s, v8.s[1] + OP_ri v19.4s, v2.4s, v8.s[1] + OP_ir v19.4s, v3.4s, v8.s[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + OP_rr v22.4s, v2.4s, v8.s[2] + OP_ii v22.4s, v3.4s, v8.s[3] + OP_ri v23.4s, v2.4s, v8.s[3] + OP_ir v23.4s, v3.4s, v8.s[2] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] + + OP_rr v24.4s, v0.4s, v10.s[0] + OP_ii v24.4s, v1.4s, v10.s[1] + OP_ri v25.4s, v0.4s, v10.s[1] + OP_ir v25.4s, v1.4s, v10.s[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v26.4s, v2.4s, v10.s[0] + OP_ii v26.4s, v3.4s, v10.s[1] + OP_ri v27.4s, v2.4s, v10.s[1] + OP_ir v27.4s, v3.4s, v10.s[0] + + OP_rr v28.4s, v0.4s, v10.s[2] + OP_ii v28.4s, v1.4s, v10.s[3] + OP_ri v29.4s, v0.4s, v10.s[3] + OP_ir v29.4s, v1.4s, v10.s[2] + + OP_rr v30.4s, v2.4s, v10.s[2] + OP_ii v30.4s, v3.4s, v10.s[3] + OP_ri v31.4s, v2.4s, v10.s[3] + OP_ir v31.4s, v3.4s, v10.s[2] +.endm + +.macro SAVE8x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + prfm PLDL2KEEP, [pCRow0, #C_PRE_SIZE] + + ld2 {v0.4s, v1.4s}, [pCRow0] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow0] + + add pCRow0, pCRow0, #32 + + ld2 {v2.4s, v3.4s}, [pCRow0] + fmla v2.4s, v18.4s, alphaV0_R + fmls v2.4s, v19.4s, alphaV0_I + fmla v3.4s, v18.4s, alphaV0_I + fmla v3.4s, v19.4s, alphaV0_R + st2 {v2.4s, v3.4s}, [pCRow0] + + add pCRow0, pCRow0, #32 + prfm PLDL2KEEP, [pCRow1, #C_PRE_SIZE] + + ld2 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0_R + fmls v4.4s, v21.4s, alphaV0_I + fmla v5.4s, v20.4s, alphaV0_I + fmla v5.4s, v21.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow1] + + add pCRow1, pCRow1, #32 + + ld2 {v6.4s, v7.4s}, [pCRow1] + fmla v6.4s, v22.4s, alphaV0_R + fmls v6.4s, v23.4s, alphaV0_I + fmla v7.4s, v22.4s, alphaV0_I + fmla v7.4s, v23.4s, alphaV0_R + st2 {v6.4s, v7.4s}, [pCRow1] + + add pCRow1, pCRow1, #32 + prfm PLDL2KEEP, [pCRow2, #C_PRE_SIZE] + + ld2 {v0.4s, v1.4s}, [pCRow2] + fmla v0.4s, v24.4s, alphaV0_R + fmls v0.4s, v25.4s, alphaV0_I + fmla v1.4s, v24.4s, alphaV0_I + fmla v1.4s, v25.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow2] + + add pCRow2, pCRow2, #32 + + ld2 {v2.4s, v3.4s}, [pCRow2] + fmla v2.4s, v26.4s, alphaV0_R + fmls v2.4s, v27.4s, alphaV0_I + fmla v3.4s, v26.4s, alphaV0_I + fmla v3.4s, v27.4s, alphaV0_R + st2 {v2.4s, v3.4s}, [pCRow2] + + add pCRow2, pCRow2, #32 + prfm PLDL2KEEP, [pCRow3, #C_PRE_SIZE] + + ld2 {v4.4s, v5.4s}, [pCRow3] + fmla v4.4s, v28.4s, alphaV0_R + fmls v4.4s, v29.4s, alphaV0_I + fmla v5.4s, v28.4s, alphaV0_I + fmla v5.4s, v29.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow3] + + add pCRow3, pCRow3, #32 + + ld2 {v6.4s, v7.4s}, [pCRow3] + fmla v6.4s, v30.4s, alphaV0_R + fmls v6.4s, v31.4s, alphaV0_I + fmla v7.4s, v30.4s, alphaV0_I + fmla v7.4s, v31.4s, alphaV0_R + st2 {v6.4s, v7.4s}, [pCRow3] + + add pCRow3, pCRow3, #32 +.endm + +/******************************************************************************/ + +.macro INIT4x4 + fmov s16, wzr + fmov s17, s16 + fmov s20, s17 + fmov s21, s16 + fmov s24, s17 + fmov s25, s16 + fmov s28, s17 + fmov s29, s16 +.endm + +.macro KERNEL4x4_I + ld2 {v8.4s, v9.4s}, [pB] + add pB, pB, #32 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + fmul v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v17.16b, v17.16b, v17.16b + fmls v17.4s, v0.4s, v9.s[0] +#else + fmul v17.4s, v0.4s, v9.s[0] +#endif + OP_ir v17.4s, v1.4s, v8.s[0] + + fmul v20.4s, v0.4s, v8.s[1] + OP_ii v20.4s, v1.4s, v9.s[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v21.16b, v21.16b, v21.16b + fmls v21.4s, v0.4s, v9.s[1] +#else + fmul v21.4s, v0.4s, v9.s[1] +#endif + OP_ir v21.4s, v1.4s, v8.s[1] + + fmul v24.4s, v0.4s, v8.s[2] + OP_ii v24.4s, v1.4s, v9.s[2] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v25.16b, v25.16b, v25.16b + fmls v25.4s, v0.4s, v9.s[2] +#else + fmul v25.4s, v0.4s, v9.s[2] +#endif + OP_ir v25.4s, v1.4s, v8.s[2] + + fmul v28.4s, v0.4s, v8.s[3] + OP_ii v28.4s, v1.4s, v9.s[3] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v29.16b, v29.16b, v29.16b + fmls v29.4s, v0.4s, v9.s[3] +#else + fmul v29.4s, v0.4s, v9.s[3] +#endif + OP_ir v29.4s, v1.4s, v8.s[3] + + ld2 {v12.4s, v13.4s}, [pB] + add pB, pB, #32 + ld2 {v4.4s, v5.4s}, [pA] + add pA, pA, #32 +.endm + +.macro KERNEL4x4_M1 + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] + OP_ri v17.4s, v0.4s, v9.s[0] + OP_ir v17.4s, v1.4s, v8.s[0] + + ld2 {v12.4s, v13.4s}, [pB] // For next round + add pB, pB, #32 + + OP_rr v20.4s, v0.4s, v8.s[1] + OP_ii v20.4s, v1.4s, v9.s[1] + OP_ri v21.4s, v0.4s, v9.s[1] + OP_ir v21.4s, v1.4s, v8.s[1] + + ld2 {v4.4s, v5.4s}, [pA] // For next round + add pA, pA, #32 + + OP_rr v24.4s, v0.4s, v8.s[2] + OP_ii v24.4s, v1.4s, v9.s[2] + OP_ri v25.4s, v0.4s, v9.s[2] + OP_ir v25.4s, v1.4s, v8.s[2] + + prfm PLDL1KEEP, [pA, #512] + + OP_rr v28.4s, v0.4s, v8.s[3] + OP_ii v28.4s, v1.4s, v9.s[3] + OP_ri v29.4s, v0.4s, v9.s[3] + OP_ir v29.4s, v1.4s, v8.s[3] +.endm + +.macro KERNEL4x4_M2 + OP_rr v16.4s, v4.4s, v12.s[0] + OP_ii v16.4s, v5.4s, v13.s[0] + OP_ri v17.4s, v4.4s, v13.s[0] + OP_ir v17.4s, v5.4s, v12.s[0] + + ld2 {v8.4s, v9.4s}, [pB] // For next round + add pB, pB, #32 + + OP_rr v20.4s, v4.4s, v12.s[1] + OP_ii v20.4s, v5.4s, v13.s[1] + OP_ri v21.4s, v4.4s, v13.s[1] + OP_ir v21.4s, v5.4s, v12.s[1] + + ld2 {v0.4s, v1.4s}, [pA] // For next round + add pA, pA, #32 + + OP_rr v24.4s, v4.4s, v12.s[2] + OP_ii v24.4s, v5.4s, v13.s[2] + OP_ri v25.4s, v4.4s, v13.s[2] + OP_ir v25.4s, v5.4s, v12.s[2] + + prfm PLDL1KEEP, [pB, #512] + + OP_rr v28.4s, v4.4s, v12.s[3] + OP_ii v28.4s, v5.4s, v13.s[3] + OP_ri v29.4s, v4.4s, v13.s[3] + OP_ir v29.4s, v5.4s, v12.s[3] +.endm + +.macro KERNEL4x4_E + OP_rr v16.4s, v4.4s, v12.s[0] + OP_ii v16.4s, v5.4s, v13.s[0] + OP_ri v17.4s, v4.4s, v13.s[0] + OP_ir v17.4s, v5.4s, v12.s[0] + + OP_rr v20.4s, v4.4s, v12.s[1] + OP_ii v20.4s, v5.4s, v13.s[1] + OP_ri v21.4s, v4.4s, v13.s[1] + OP_ir v21.4s, v5.4s, v12.s[1] + + OP_rr v24.4s, v4.4s, v12.s[2] + OP_ii v24.4s, v5.4s, v13.s[2] + OP_ri v25.4s, v4.4s, v13.s[2] + OP_ir v25.4s, v5.4s, v12.s[2] + + OP_rr v28.4s, v4.4s, v12.s[3] + OP_ii v28.4s, v5.4s, v13.s[3] + OP_ri v29.4s, v4.4s, v13.s[3] + OP_ir v29.4s, v5.4s, v12.s[3] +.endm + +.macro KERNEL4x4_SUB + ld2 {v8.4s, v9.4s}, [pB] + add pB, pB, #32 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] + OP_ri v17.4s, v0.4s, v9.s[0] + OP_ir v17.4s, v1.4s, v8.s[0] + + OP_rr v20.4s, v0.4s, v8.s[1] + OP_ii v20.4s, v1.4s, v9.s[1] + OP_ri v21.4s, v0.4s, v9.s[1] + OP_ir v21.4s, v1.4s, v8.s[1] + + OP_rr v24.4s, v0.4s, v8.s[2] + OP_ii v24.4s, v1.4s, v9.s[2] + OP_ri v25.4s, v0.4s, v9.s[2] + OP_ir v25.4s, v1.4s, v8.s[2] + + OP_rr v28.4s, v0.4s, v8.s[3] + OP_ii v28.4s, v1.4s, v9.s[3] + OP_ri v29.4s, v0.4s, v9.s[3] + OP_ir v29.4s, v1.4s, v8.s[3] +.endm + +.macro SAVE4x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0_R + fmls v4.4s, v21.4s, alphaV0_I + fmla v5.4s, v20.4s, alphaV0_I + fmla v5.4s, v21.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v24.4s, alphaV0_R + fmls v0.4s, v25.4s, alphaV0_I + fmla v1.4s, v24.4s, alphaV0_I + fmla v1.4s, v25.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v28.4s, alphaV0_R + fmls v4.4s, v29.4s, alphaV0_I + fmla v5.4s, v28.4s, alphaV0_I + fmla v5.4s, v29.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT2x4 + fmov s16, wzr + fmov s17, wzr + fmov s20, s16 + fmov s21, s17 + fmov s24, s16 + fmov s25, s17 + fmov s28, s16 + fmov s29, s17 +.endm + +.macro KERNEL2x4_SUB + ld2 {v8.4s, v9.4s}, [pB] + add pB, pB, #32 + ld2 {v0.2s, v1.2s}, [pA] + add pA, pA, #16 + + OP_rr v16.2s, v0.2s, v8.s[0] + OP_ii v16.2s, v1.2s, v9.s[0] + OP_ri v17.2s, v0.2s, v9.s[0] + OP_ir v17.2s, v1.2s, v8.s[0] + + OP_rr v20.2s, v0.2s, v8.s[1] + OP_ii v20.2s, v1.2s, v9.s[1] + OP_ri v21.2s, v0.2s, v9.s[1] + OP_ir v21.2s, v1.2s, v8.s[1] + + OP_rr v24.2s, v0.2s, v8.s[2] + OP_ii v24.2s, v1.2s, v9.s[2] + OP_ri v25.2s, v0.2s, v9.s[2] + OP_ir v25.2s, v1.2s, v8.s[2] + + OP_rr v28.2s, v0.2s, v8.s[3] + OP_ii v28.2s, v1.2s, v9.s[3] + OP_ri v29.2s, v0.2s, v9.s[3] + OP_ir v29.2s, v1.2s, v8.s[3] +.endm + +.macro SAVE2x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2s, v1.2s}, [pCRow1] + fmla v0.2s, v16.2s, alphaV0_R + fmls v0.2s, v17.2s, alphaV0_I + fmla v1.2s, v16.2s, alphaV0_I + fmla v1.2s, v17.2s, alphaV0_R + st2 {v0.2s, v1.2s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2s, v5.2s}, [pCRow1] + fmla v4.2s, v20.2s, alphaV0_R + fmls v4.2s, v21.2s, alphaV0_I + fmla v5.2s, v20.2s, alphaV0_I + fmla v5.2s, v21.2s, alphaV0_R + st2 {v4.2s, v5.2s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v0.2s, v1.2s}, [pCRow1] + fmla v0.2s, v24.2s, alphaV0_R + fmls v0.2s, v25.2s, alphaV0_I + fmla v1.2s, v24.2s, alphaV0_I + fmla v1.2s, v25.2s, alphaV0_R + st2 {v0.2s, v1.2s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2s, v5.2s}, [pCRow1] + fmla v4.2s, v28.2s, alphaV0_R + fmls v4.2s, v29.2s, alphaV0_I + fmla v5.2s, v28.2s, alphaV0_I + fmla v5.2s, v29.2s, alphaV0_R + st2 {v4.2s, v5.2s}, [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT1x4 + fmov s16, wzr + fmov s17, wzr + fmov s20, s16 + fmov s21, s17 + fmov s24, s16 + fmov s25, s17 + fmov s28, s16 + fmov s29, s17 +.endm + +.macro KERNEL1x4_SUB + ld2 {v8.4s, v9.4s}, [pB] + add pB, pB, #32 + ld2 {v0.s, v1.s}[0], [pA] + add pA, pA, #8 + + OP_rr s16, s0, v8.s[0] + OP_ii s16, s1, v9.s[0] + OP_ri s17, s0, v9.s[0] + OP_ir s17, s1, v8.s[0] + + OP_rr s20, s0, v8.s[1] + OP_ii s20, s1, v9.s[1] + OP_ri s21, s0, v9.s[1] + OP_ir s21, s1, v8.s[1] + + OP_rr s24, s0, v8.s[2] + OP_ii s24, s1, v9.s[2] + OP_ri s25, s0, v9.s[2] + OP_ir s25, s1, v8.s[2] + + OP_rr s28, s0, v8.s[3] + OP_ii s28, s1, v9.s[3] + OP_ri s29, s0, v9.s[3] + OP_ir s29, s1, v8.s[3] +.endm + +.macro SAVE1x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.s, v1.s}[0], [pCRow1] + fmla s0, s16, alphaV0_R + fmls s0, s17, alphaV0_I + fmla s1, s16, alphaV0_I + fmla s1, s17, alphaV0_R + st2 {v0.s, v1.s}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.s, v5.s}[0], [pCRow1] + fmla s4, s20, alphaV0_R + fmls s4, s21, alphaV0_I + fmla s5, s20, alphaV0_I + fmla s5, s21, alphaV0_R + st2 {v4.s, v5.s}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v0.s, v1.s}[0], [pCRow1] + fmla s0, s24, alphaV0_R + fmls s0, s25, alphaV0_I + fmla s1, s24, alphaV0_I + fmla s1, s25, alphaV0_R + st2 {v0.s, v1.s}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.s, v5.s}[0], [pCRow1] + fmla s4, s28, alphaV0_R + fmls s4, s29, alphaV0_I + fmla s5, s28, alphaV0_I + fmla s5, s29, alphaV0_R + st2 {v4.s, v5.s}[0], [pCRow1] + + add pCRow0, pCRow0, #8 +.endm + +/******************************************************************************/ + +.macro INIT8x2 + fmov s16, wzr + fmov s17, wzr + fmov s18, wzr + fmov s19, s16 + fmov s20, wzr + fmov s21, s16 + fmov s22, s17 + fmov s23, s18 +.endm + +.macro KERNEL8x2_SUB + ld2 {v8.2s, v9.2s}, [pB] + add pB, pB, #16 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + ld2 {v2.4s, v3.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] + OP_ri v17.4s, v0.4s, v9.s[0] + OP_ir v17.4s, v1.4s, v8.s[0] + + OP_rr v18.4s, v2.4s, v8.s[0] + OP_ii v18.4s, v3.4s, v9.s[0] + OP_ri v19.4s, v2.4s, v9.s[0] + OP_ir v19.4s, v3.4s, v8.s[0] + + OP_rr v20.4s, v0.4s, v8.s[1] + OP_ii v20.4s, v1.4s, v9.s[1] + OP_ri v21.4s, v0.4s, v9.s[1] + OP_ir v21.4s, v1.4s, v8.s[1] + + OP_rr v22.4s, v2.4s, v8.s[1] + OP_ii v22.4s, v3.4s, v9.s[1] + OP_ri v23.4s, v2.4s, v9.s[1] + OP_ir v23.4s, v3.4s, v8.s[1] +.endm + +.macro SAVE8x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow2, pCRow1, #32 + + ld2 {v2.4s, v3.4s}, [pCRow2] + fmla v2.4s, v18.4s, alphaV0_R + fmls v2.4s, v19.4s, alphaV0_I + fmla v3.4s, v18.4s, alphaV0_I + fmla v3.4s, v19.4s, alphaV0_R + st2 {v2.4s, v3.4s}, [pCRow2] + + add pCRow1, pCRow1, LDC + + ld2 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0_R + fmls v4.4s, v21.4s, alphaV0_I + fmla v5.4s, v20.4s, alphaV0_I + fmla v5.4s, v21.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow1] + + add pCRow2, pCRow1, #32 + + ld2 {v6.4s, v7.4s}, [pCRow2] + fmla v6.4s, v22.4s, alphaV0_R + fmls v6.4s, v23.4s, alphaV0_I + fmla v7.4s, v22.4s, alphaV0_I + fmla v7.4s, v23.4s, alphaV0_R + st2 {v6.4s, v7.4s}, [pCRow2] + + add pCRow0, pCRow0, #64 +.endm + +/******************************************************************************/ + +.macro INIT4x2 + fmov s16, wzr + fmov s17, wzr + fmov s20, s16 + fmov s21, s17 +.endm + +.macro KERNEL4x2_SUB + ld2 {v8.2s, v9.2s}, [pB] + add pB, pB, #16 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] + OP_ri v17.4s, v0.4s, v9.s[0] + OP_ir v17.4s, v1.4s, v8.s[0] + + OP_rr v20.4s, v0.4s, v8.s[1] + OP_ii v20.4s, v1.4s, v9.s[1] + OP_ri v21.4s, v0.4s, v9.s[1] + OP_ir v21.4s, v1.4s, v8.s[1] +.endm + +.macro SAVE4x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0_R + fmls v4.4s, v21.4s, alphaV0_I + fmla v5.4s, v20.4s, alphaV0_I + fmla v5.4s, v21.4s, alphaV0_R + st2 {v4.4s, v5.4s}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT2x2 + fmov s16, wzr + fmov s17, wzr + fmov s20, s16 + fmov s21, s17 +.endm + +.macro KERNEL2x2_SUB + ld2 {v8.2s, v9.2s}, [pB] + add pB, pB, #16 + ld2 {v0.2s, v1.2s}, [pA] + add pA, pA, #16 + + OP_rr v16.2s, v0.2s, v8.s[0] + OP_ii v16.2s, v1.2s, v9.s[0] + OP_ri v17.2s, v0.2s, v9.s[0] + OP_ir v17.2s, v1.2s, v8.s[0] + + OP_rr v20.2s, v0.2s, v8.s[1] + OP_ii v20.2s, v1.2s, v9.s[1] + OP_ri v21.2s, v0.2s, v9.s[1] + OP_ir v21.2s, v1.2s, v8.s[1] +.endm + +.macro SAVE2x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2s, v1.2s}, [pCRow1] + fmla v0.2s, v16.2s, alphaV0_R + fmls v0.2s, v17.2s, alphaV0_I + fmla v1.2s, v16.2s, alphaV0_I + fmla v1.2s, v17.2s, alphaV0_R + st2 {v0.2s, v1.2s}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2s, v5.2s}, [pCRow1] + fmla v4.2s, v20.2s, alphaV0_R + fmls v4.2s, v21.2s, alphaV0_I + fmla v5.2s, v20.2s, alphaV0_I + fmla v5.2s, v21.2s, alphaV0_R + st2 {v4.2s, v5.2s}, [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT1x2 + fmov s16, wzr + fmov s17, wzr + fmov s20, wzr + fmov s21, wzr +.endm + +.macro KERNEL1x2_SUB + ld2 {v8.2s, v9.2s}, [pB] + add pB, pB, #16 + ld2 {v0.s, v1.s}[0], [pA] + add pA, pA, #8 + + OP_rr s16, s0, v8.s[0] + OP_ii s16, s1, v9.s[0] + OP_ri s17, s0, v9.s[0] + OP_ir s17, s1, v8.s[0] + + OP_rr s20, s0, v8.s[1] + OP_ii s20, s1, v9.s[1] + OP_ri s21, s0, v9.s[1] + OP_ir s21, s1, v8.s[1] +.endm + +.macro SAVE1x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.s, v1.s}[0], [pCRow1] + fmla s0, s16, alphaV0_R + fmls s0, s17, alphaV0_I + fmla s1, s16, alphaV0_I + fmla s1, s17, alphaV0_R + st2 {v0.s, v1.s}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.s, v5.s}[0], [pCRow1] + fmla s4, s20, alphaV0_R + fmls s4, s21, alphaV0_I + fmla s5, s20, alphaV0_I + fmla s5, s21, alphaV0_R + st2 {v4.s, v5.s}[0], [pCRow1] + + add pCRow0, pCRow0, #8 +.endm + +/******************************************************************************/ + +.macro INIT8x1 + fmov s16, wzr + fmov s17, wzr + fmov s18, wzr + fmov s19, s16 +.endm + +.macro KERNEL8x1_SUB + ld1 {v8.2s}, [pB] + add pB, pB, #8 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + ld2 {v2.4s, v3.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v8.s[1] + OP_ri v17.4s, v0.4s, v8.s[1] + OP_ir v17.4s, v1.4s, v8.s[0] + + OP_rr v18.4s, v2.4s, v8.s[0] + OP_ii v18.4s, v3.4s, v8.s[1] + OP_ri v19.4s, v2.4s, v8.s[1] + OP_ir v19.4s, v3.4s, v8.s[0] +.endm + +.macro SAVE8x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow1, pCRow1, #32 + + ld2 {v2.4s, v3.4s}, [pCRow1] + fmla v2.4s, v18.4s, alphaV0_R + fmls v2.4s, v19.4s, alphaV0_I + fmla v3.4s, v18.4s, alphaV0_I + fmla v3.4s, v19.4s, alphaV0_R + st2 {v2.4s, v3.4s}, [pCRow1] + + add pCRow0, pCRow0, #64 +.endm + + +/******************************************************************************/ + +.macro INIT4x1 + fmov s16, wzr + fmov s17, s16 +.endm + +.macro KERNEL4x1_SUB + ld2 {v8.s, v9.s}[0], [pB] + add pB, pB, #8 + ld2 {v0.4s, v1.4s}, [pA] + add pA, pA, #32 + + OP_rr v16.4s, v0.4s, v8.s[0] + OP_ii v16.4s, v1.4s, v9.s[0] + OP_ri v17.4s, v0.4s, v9.s[0] + OP_ir v17.4s, v1.4s, v8.s[0] +.endm + +.macro SAVE4x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.4s, v1.4s}, [pCRow1] + fmla v0.4s, v16.4s, alphaV0_R + fmls v0.4s, v17.4s, alphaV0_I + fmla v1.4s, v16.4s, alphaV0_I + fmla v1.4s, v17.4s, alphaV0_R + st2 {v0.4s, v1.4s}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT2x1 + fmov s16, wzr + fmov s17, wzr +.endm + +.macro KERNEL2x1_SUB + ld2 {v8.s, v9.s}[0], [pB] + add pB, pB, #8 + ld2 {v0.2s, v1.2s}, [pA] + add pA, pA, #16 + + OP_rr v16.2s, v0.2s, v8.s[0] + OP_ii v16.2s, v1.2s, v9.s[0] + OP_ri v17.2s, v0.2s, v9.s[0] + OP_ir v17.2s, v1.2s, v8.s[0] +.endm + +.macro SAVE2x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2s, v1.2s}, [pCRow1] + fmla v0.2s, v16.2s, alphaV0_R + fmls v0.2s, v17.2s, alphaV0_I + fmla v1.2s, v16.2s, alphaV0_I + fmla v1.2s, v17.2s, alphaV0_R + st2 {v0.2s, v1.2s}, [pCRow1] + + add pCRow0, pCRow0, #16 + +.endm + +/******************************************************************************/ + +.macro INIT1x1 + fmov s16, wzr + fmov s17, wzr +.endm + +.macro KERNEL1x1_SUB + ld2 {v8.s, v9.s}[0], [pB] + add pB, pB, #8 + ld2 {v0.s, v1.s}[0], [pA] + add pA, pA, #8 + + OP_rr s16, s0, v8.s[0] + OP_ii s16, s1, v9.s[0] + OP_ri s17, s0, v9.s[0] + OP_ir s17, s1, v8.s[0] +.endm + +.macro SAVE1x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.s, v1.s}[0], [pCRow1] + fmla s0, s16, alphaV0_R + fmls s0, s17, alphaV0_I + fmla s1, s16, alphaV0_I + fmla s1, s17, alphaV0_R + st2 {v0.s, v1.s}[0], [pCRow1] + + add pCRow0, pCRow0, #8 +.endm + +.macro KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1 + KERNEL8x4_M2 +.endm + +.macro KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1_M2_x1 +.endm + +.macro KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x2 +.endm + +.macro KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x4 +.endm + +.macro KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x8 +.endm + +/******************************************************************************* +* End of macro definitions +*******************************************************************************/ + + PROLOGUE + + .align 5 + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] + + prfm PLDL1KEEP, [origPB] + prfm PLDL1KEEP, [origPA] + + fmov alphaR, s0 + fmov alphaI, s1 + + lsl LDC, LDC, #3 // ldc = ldc * 8 + + mov pB, origPB + + mov counterJ, origN + asr counterJ, counterJ, #2 // J = J / 4 + cmp counterJ, #0 + ble cgemm_kernel_L2_BEGIN + +/******************************************************************************/ + +cgemm_kernel_L4_BEGIN: + mov pCRow0, pC + add pCRow1, pCRow0, LDC + add pCRow2, pCRow1, LDC + add pCRow3, pCRow2, LDC + + add pC, pCRow3, LDC + + mov pA, origPA // pA = start of A array + +cgemm_kernel_L4_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble cgemm_kernel_L4_M4_BEGIN + + .align 5 +cgemm_kernel_L4_M8_20: + + mov pB, origPB + + asr counterL , origK, #5 // origK / 32 + cmp counterL , #2 + blt cgemm_kernel_L4_M8_32 + + KERNEL8x4_I + KERNEL8x4_M2 + KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x8 + + subs counterL, counterL, #2 // subtract 2 + ble cgemm_kernel_L4_M8_22a + + .align 5 +cgemm_kernel_L4_M8_22: + + KERNEL8x4_M1_M2_x16 + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M8_22 + + .align 5 +cgemm_kernel_L4_M8_22a: + + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1 + KERNEL8x4_E + + b cgemm_kernel_L4_M8_44 + + .align 5 +cgemm_kernel_L4_M8_32: + + tst counterL, #1 + ble cgemm_kernel_L4_M8_40 + + KERNEL8x4_I + KERNEL8x4_M2 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1 + KERNEL8x4_E + + b cgemm_kernel_L4_M8_44 + +cgemm_kernel_L4_M8_40: + + INIT8x4 + +cgemm_kernel_L4_M8_44: + + ands counterL , origK, #31 + ble cgemm_kernel_L4_M8_100 + + .align 5 +cgemm_kernel_L4_M8_46: + + KERNEL8x4_SUB + + subs counterL, counterL, #1 + bne cgemm_kernel_L4_M8_46 + +cgemm_kernel_L4_M8_100: + prfm PLDL1KEEP, [pA] + prfm PLDL1KEEP, [pA, #64] + prfm PLDL1KEEP, [origPB] + + SAVE8x4 + +cgemm_kernel_L4_M8_END: + subs counterI, counterI, #1 + bne cgemm_kernel_L4_M8_20 + +cgemm_kernel_L4_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble cgemm_kernel_L4_END + + tst counterI, #4 + ble cgemm_kernel_L4_M2_BEGIN + + +cgemm_kernel_L4_M4_20: + + mov pB, origPB + + asr counterL , origK, #1 // L = K / 2 + cmp counterL , #2 // is there at least 4 to do? + blt cgemm_kernel_L4_M4_32 + + KERNEL4x4_I // do one in the K + KERNEL4x4_M2 // do another in the K + + subs counterL, counterL, #2 + ble cgemm_kernel_L4_M4_22a + .align 5 + + +cgemm_kernel_L4_M4_22: + + KERNEL4x4_M1 + KERNEL4x4_M2 + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M4_22 + +cgemm_kernel_L4_M4_22a: + KERNEL4x4_M1 + KERNEL4x4_E + b cgemm_kernel_L4_M4_44 +cgemm_kernel_L4_M4_32: + tst counterL, #1 + ble cgemm_kernel_L4_M4_40 + KERNEL4x4_I + KERNEL4x4_E + b cgemm_kernel_L4_M4_44 +cgemm_kernel_L4_M4_40: + + INIT4x4 + +cgemm_kernel_L4_M4_44: + ands counterL , origK, #1 + ble cgemm_kernel_L4_M4_100 + +cgemm_kernel_L4_M4_46: + KERNEL4x4_SUB + +cgemm_kernel_L4_M4_100: + + SAVE4x4 + +cgemm_kernel_L4_M4_END: + +cgemm_kernel_L4_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble cgemm_kernel_L4_END + + tst counterI, #2 // counterI = counterI / 2 + ble cgemm_kernel_L4_M1_BEGIN + +cgemm_kernel_L4_M2_20: + + INIT2x4 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L4_M2_40 + +cgemm_kernel_L4_M2_22: + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M2_22 + + +cgemm_kernel_L4_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L4_M2_100 + +cgemm_kernel_L4_M2_42: + + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M2_42 + +cgemm_kernel_L4_M2_100: + + SAVE2x4 + +cgemm_kernel_L4_M2_END: + + +cgemm_kernel_L4_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble cgemm_kernel_L4_END + +cgemm_kernel_L4_M1_20: + + INIT1x4 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L4_M1_40 + +cgemm_kernel_L4_M1_22: + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M1_22 + + +cgemm_kernel_L4_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L4_M1_100 + +cgemm_kernel_L4_M1_42: + + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L4_M1_42 + +cgemm_kernel_L4_M1_100: + + SAVE1x4 + + +cgemm_kernel_L4_END: + + lsl temp, origK, #5 + add origPB, origPB, temp // B = B + K * 4 * 8 + + subs counterJ, counterJ , #1 // j-- + bgt cgemm_kernel_L4_BEGIN + + +/******************************************************************************/ + +cgemm_kernel_L2_BEGIN: // less than 2 left in N direction + + mov counterJ , origN + tst counterJ , #3 + ble cgemm_kernel_L999 // error, N was less than 4? + + tst counterJ , #2 + ble cgemm_kernel_L1_BEGIN + + mov pCRow0, pC // pCRow0 = pC + + add pC,pC,LDC, lsl #1 + + mov pA, origPA // pA = A + + +cgemm_kernel_L2_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble cgemm_kernel_L2_M4_BEGIN + +cgemm_kernel_L2_M8_20: + + INIT8x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble cgemm_kernel_L2_M8_40 + .align 5 + +cgemm_kernel_L2_M8_22: + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M8_22 + + +cgemm_kernel_L2_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L2_M8_100 + +cgemm_kernel_L2_M8_42: + + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M8_42 + +cgemm_kernel_L2_M8_100: + + SAVE8x2 + +cgemm_kernel_L2_M8_END: + + subs counterI, counterI, #1 + bgt cgemm_kernel_L2_M8_20 + +cgemm_kernel_L2_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble cgemm_kernel_L2_END + + tst counterI, #4 // counterI = counterI / 2 + ble cgemm_kernel_L2_M2_BEGIN + +cgemm_kernel_L2_M4_20: + + INIT4x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble cgemm_kernel_L2_M4_40 + .align 5 + +cgemm_kernel_L2_M4_22: + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M4_22 + + +cgemm_kernel_L2_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L2_M4_100 + +cgemm_kernel_L2_M4_42: + + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M4_42 + +cgemm_kernel_L2_M4_100: + + SAVE4x2 + +cgemm_kernel_L2_M4_END: + +cgemm_kernel_L2_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble cgemm_kernel_L2_END + + tst counterI, #2 // counterI = counterI / 2 + ble cgemm_kernel_L2_M1_BEGIN + +cgemm_kernel_L2_M2_20: + + INIT2x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble cgemm_kernel_L2_M2_40 + +cgemm_kernel_L2_M2_22: + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M2_22 + + +cgemm_kernel_L2_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L2_M2_100 + +cgemm_kernel_L2_M2_42: + + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M2_42 + +cgemm_kernel_L2_M2_100: + + SAVE2x2 + +cgemm_kernel_L2_M2_END: + + +cgemm_kernel_L2_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble cgemm_kernel_L2_END + +cgemm_kernel_L2_M1_20: + + INIT1x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL, #0 + ble cgemm_kernel_L2_M1_40 + +cgemm_kernel_L2_M1_22: + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M1_22 + + +cgemm_kernel_L2_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L2_M1_100 + +cgemm_kernel_L2_M1_42: + + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L2_M1_42 + +cgemm_kernel_L2_M1_100: + + SAVE1x2 + + +cgemm_kernel_L2_END: + add origPB, origPB, origK, lsl #4 // B = B + K * 2 * 8 + +/******************************************************************************/ + +cgemm_kernel_L1_BEGIN: + + mov counterJ , origN + tst counterJ , #1 + ble cgemm_kernel_L999 // done + + + mov pCRow0, pC // pCRow0 = C + add pC , pC , LDC // Update pC to point to next + + mov pA, origPA // pA = A + + +cgemm_kernel_L1_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble cgemm_kernel_L1_M4_BEGIN + +cgemm_kernel_L1_M8_20: + + INIT8x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L1_M8_40 + .align 5 + +cgemm_kernel_L1_M8_22: + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M8_22 + + +cgemm_kernel_L1_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L1_M8_100 + +cgemm_kernel_L1_M8_42: + + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M8_42 + +cgemm_kernel_L1_M8_100: + + SAVE8x1 + +cgemm_kernel_L1_M8_END: + + subs counterI, counterI, #1 + bgt cgemm_kernel_L1_M8_20 + +cgemm_kernel_L1_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble cgemm_kernel_L1_END + + tst counterI, #4 // counterI = counterI / 2 + ble cgemm_kernel_L1_M2_BEGIN + + +cgemm_kernel_L1_M4_20: + + INIT4x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L1_M4_40 + .align 5 + +cgemm_kernel_L1_M4_22: + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M4_22 + + +cgemm_kernel_L1_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L1_M4_100 + +cgemm_kernel_L1_M4_42: + + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M4_42 + +cgemm_kernel_L1_M4_100: + + SAVE4x1 + +cgemm_kernel_L1_M4_END: + + +cgemm_kernel_L1_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble cgemm_kernel_L1_END + + tst counterI, #2 // counterI = counterI / 2 + ble cgemm_kernel_L1_M1_BEGIN + +cgemm_kernel_L1_M2_20: + + INIT2x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L1_M2_40 + +cgemm_kernel_L1_M2_22: + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M2_22 + + +cgemm_kernel_L1_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L1_M2_100 + +cgemm_kernel_L1_M2_42: + + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M2_42 + +cgemm_kernel_L1_M2_100: + + SAVE2x1 + +cgemm_kernel_L1_M2_END: + + +cgemm_kernel_L1_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble cgemm_kernel_L1_END + +cgemm_kernel_L1_M1_20: + + INIT1x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble cgemm_kernel_L1_M1_40 + +cgemm_kernel_L1_M1_22: + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M1_22 + + +cgemm_kernel_L1_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble cgemm_kernel_L1_M1_100 + +cgemm_kernel_L1_M1_42: + + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt cgemm_kernel_L1_M1_42 + +cgemm_kernel_L1_M1_100: + + SAVE1x1 + + +cgemm_kernel_L1_END: + + +cgemm_kernel_L999: + mov x0, #0 // set return value + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) + ret + + EPILOGUE + diff --git a/kernel/arm64/copy_thunderx2t99.c b/kernel/arm64/copy_thunderx2t99.c new file mode 100644 index 0000000000..49526a15e8 --- /dev/null +++ b/kernel/arm64/copy_thunderx2t99.c @@ -0,0 +1,219 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#include +#define N "x0" /* vector length */ +#define X "x1" /* X vector address */ +#define INC_X "x2" /* X stride */ +#define Y "x3" /* Y vector address */ +#define INC_Y "x4" /* Y stride */ +#define J "x5" /* loop variable */ + +/******************************************************************************* +* Macro definitions +*******************************************************************************/ +#if !defined(COMPLEX) +#if !defined(DOUBLE) +#define TMPF "s0" +#define INC_SHIFT "2" +#define N_DIV_SHIFT "2" +#define N_REM_MASK "3" +#else +#define TMPF "d0" +#define INC_SHIFT "3" +#define N_DIV_SHIFT "1" +#define N_REM_MASK "1" +#endif +#else +#if !defined(DOUBLE) +#define TMPF "d0" +#define INC_SHIFT "3" +#define N_DIV_SHIFT "1" +#define N_REM_MASK "1" +#else +#define TMPF "q0" +#define INC_SHIFT "4" +#define N_DIV_SHIFT "0" +#define N_REM_MASK "0" +#endif +#endif + +#define KERNEL_F1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "str "TMPF", ["Y"] \n" \ + "add "Y", "Y", "INC_Y" \n" + +#define KERNEL_F \ + "ldr q0, ["X"], #16 \n" \ + "str q0, ["Y"], #16 \n" + +#define INIT \ + "lsl "INC_X", "INC_X", #"INC_SHIFT" \n" \ + "lsl "INC_Y", "INC_Y", #"INC_SHIFT" \n" + + +static int do_copy(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + if ( n < 0 ) return 0; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " mov "Y", %[Y_] \n" + " mov "INC_Y", %[INCY_] \n" + " cmp "N", xzr \n" + " ble .Lcopy_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lcopy_kernel_S_BEGIN \n" + " cmp "INC_Y", #1 \n" + " bne .Lcopy_kernel_S_BEGIN \n" + + ".Lcopy_kernel_F_BEGIN: \n" + " "INIT" \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Lcopy_kernel_F1 \n" + " .align 5 \n" + + ".Lcopy_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Lcopy_kernel_F \n" + + ".Lcopy_kernel_F1: \n" +#if defined(COMPLEX) && defined(DOUBLE) + " b .Lcopy_kernel_L999 \n" +#else + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Lcopy_kernel_L999 \n" +#endif + + ".Lcopy_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lcopy_kernel_F10 \n" + " b .Lcopy_kernel_L999 \n" + + ".Lcopy_kernel_S_BEGIN: \n" + " "INIT" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lcopy_kernel_S1 \n" + + ".Lcopy_kernel_S4: \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lcopy_kernel_S4 \n" + + ".Lcopy_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lcopy_kernel_L999 \n" + + ".Lcopy_kernel_S10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lcopy_kernel_S10 \n" + + ".Lcopy_kernel_L999: \n" + + : + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x), //%3 + [Y_] "r" (y), //%4 + [INCY_] "r" (inc_y) //%5 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0" + ); + + return 0; +} + +#if defined(SMP) +static int copy_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *dummy3, BLASLONG dummy4) +{ + do_copy(n, x, inc_x, y, inc_y); + + return 0; +} +#endif + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + + if (n <= 0) return 0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + do_copy(n, x, inc_x, y, inc_y); + } else { + int mode = 0; + +#if !defined(COMPLEX) + mode = BLAS_REAL; +#else + mode = BLAS_COMPLEX; +#endif +#if !defined(DOUBLE) + mode |= BLAS_SINGLE; +#else + mode |= BLAS_DOUBLE; +#endif + + blas_level1_thread(mode, n, 0, 0, &dummy_alpha, + x, inc_x, y, inc_y, NULL, 0, + ( void *)copy_thread_function, nthreads); + } +#else + do_copy(n, x, inc_x, y, inc_y); +#endif + + return 0; +} diff --git a/kernel/arm64/dasum_thunderx2t99.c b/kernel/arm64/dasum_thunderx2t99.c new file mode 100644 index 0000000000..bd6bb055de --- /dev/null +++ b/kernel/arm64/dasum_thunderx2t99.c @@ -0,0 +1,263 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#include + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define J "x5" /* loop variable */ + +#define REG0 "xzr" +#define SUMF "d0" +#define TMPF "d1" + +/******************************************************************************/ + +#define KERNEL_F1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", #8 \n" \ + "fabs "TMPF", "TMPF" \n" \ + "fadd "SUMF", "SUMF", "TMPF" \n" + +#define KERNEL_F32 \ + "ldr q16, ["X"] \n" \ + "ldr q17, ["X", #16] \n" \ + "ldr q18, ["X", #32] \n" \ + "ldr q19, ["X", #48] \n" \ + "ldp q20, q21, ["X", #64] \n" \ + "ldp q22, q23, ["X", #96] \n" \ + "fabs v16.2d, v16.2d \n" \ + "fabs v17.2d, v17.2d \n" \ + "fabs v18.2d, v18.2d \n" \ + "fabs v19.2d, v19.2d \n" \ + "ldp q24, q25, ["X", #128] \n" \ + "ldp q26, q27, ["X", #160] \n" \ + "fabs v20.2d, v20.2d \n" \ + "fabs v21.2d, v21.2d \n" \ + "fabs v22.2d, v22.2d \n" \ + "fabs v23.2d, v23.2d \n" \ + "fadd v16.2d, v16.2d, v17.2d \n" \ + "fadd v18.2d, v18.2d, v19.2d \n" \ + "ldp q28, q29, ["X", #192] \n" \ + "ldp q30, q31, ["X", #224] \n" \ + "fabs v24.2d, v24.2d \n" \ + "fabs v25.2d, v25.2d \n" \ + "fabs v26.2d, v26.2d \n" \ + "fabs v27.2d, v27.2d \n" \ + "add "X", "X", #256 \n" \ + "fadd v20.2d, v20.2d, v21.2d \n" \ + "fadd v22.2d, v22.2d, v23.2d \n" \ + "fabs v28.2d, v28.2d \n" \ + "fabs v29.2d, v29.2d \n" \ + "fabs v30.2d, v30.2d \n" \ + "fabs v31.2d, v31.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "fadd v24.2d, v24.2d, v25.2d \n" \ + "fadd v26.2d, v26.2d, v27.2d \n" \ + "fadd v28.2d, v28.2d, v29.2d \n" \ + "fadd v30.2d, v30.2d, v31.2d \n" \ + "fadd v0.2d, v0.2d, v16.2d \n" \ + "fadd v1.2d, v1.2d, v18.2d \n" \ + "fadd v2.2d, v2.2d, v20.2d \n" \ + "fadd v3.2d, v3.2d, v22.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fadd v4.2d, v4.2d, v24.2d \n" \ + "fadd v5.2d, v5.2d, v26.2d \n" \ + "fadd v6.2d, v6.2d, v28.2d \n" \ + "fadd v7.2d, v7.2d, v30.2d \n" + +#define KERNEL_F32_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" \ + "faddp "SUMF", v0.2d \n" + +#define INIT_S \ + "lsl "INC_X", "INC_X", #3 \n" + +#define KERNEL_S1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fabs "TMPF", "TMPF" \n" \ + "fadd "SUMF", "SUMF", "TMPF" \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static FLOAT dasum_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + FLOAT asum = 0.0 ; + + if ( n < 0 ) return(asum); + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SUMF", "REG0" \n" + " fmov d1, "REG0" \n" + " fmov d2, "REG0" \n" + " fmov d3, "REG0" \n" + " fmov d4, "REG0" \n" + " fmov d5, "REG0" \n" + " fmov d6, "REG0" \n" + " fmov d7, "REG0" \n" + " cmp "N", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lasum_kernel_S_BEGIN \n" + + ".Lasum_kernel_F_BEGIN: \n" + " asr "J", "N", #5 \n" + " cmp "J", xzr \n" + " beq .Lasum_kernel_F1 \n" + + ".align 5 \n" + ".Lasum_kernel_F32: \n" + " "KERNEL_F32" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F32 \n" + " "KERNEL_F32_FINALIZE" \n" + + ".Lasum_kernel_F1: \n" + " ands "J", "N", #31 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F10 \n" + " b .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S_BEGIN: \n" + " "INIT_S" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lasum_kernel_S1 \n" + + ".Lasum_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S4 \n" + + ".Lasum_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S10 \n" + + ".Lasum_kernel_L999: \n" + " fmov %[ASUM_], "SUMF" \n" + + : [ASUM_] "=r" (asum) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return asum; +} + +#if defined(SMP) +static int dasum_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *result = dasum_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + FLOAT asum = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + asum = dasum_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT *ptr; + + mode = BLAS_DOUBLE; + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)dasum_thread_function, nthreads); + + ptr = (FLOAT *)result; + for (i = 0; i < nthreads; i++) { + asum = asum + (*ptr); + ptr = (FLOAT *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + asum = dasum_compute(n, x, inc_x); +#endif + + return asum; +} diff --git a/kernel/arm64/daxpy_thunderx.c b/kernel/arm64/daxpy_thunderx.c new file mode 100644 index 0000000000..37aae93914 --- /dev/null +++ b/kernel/arm64/daxpy_thunderx.c @@ -0,0 +1,151 @@ +/*************************************************************************** +Copyright (c) 2014, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" +#include + +#define prefetch(a) __asm__("prfm PLDL1STRM, [%0]"::"r"(a):"memory"); +//#define prefetch(a) + +static void daxpy_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *alpha) +{ + BLASLONG register i = 0; + double a = *alpha; + +#if 0 + prefetch(x + 128/sizeof(*x)); + prefetch(y + 128/sizeof(*y)); +#endif + prefetch(x + 2*128/sizeof(*x)); + prefetch(y + 2*128/sizeof(*y)); + prefetch(x + 3*128/sizeof(*x)); + prefetch(y + 3*128/sizeof(*y)); + prefetch(x + 4*128/sizeof(*x)); + prefetch(y + 4*128/sizeof(*y)); + + while(i < n) + { + double y0, y1, y2, y3; + double y4, y5, y6, y7; + double *xx; + double *yy; + y0 = a * x[0] + y[0]; + y1 = a * x[1] + y[1]; + y2 = a * x[2] + y[2]; + y3 = a * x[3] + y[3]; + y4 = a * x[4] + y[4]; + y5 = a * x[5] + y[5]; + y6 = a * x[6] + y[6]; + y7 = a * x[7] + y[7]; + asm("":"+w"(y0),"+w"(y1),"+w"(y2),"+w"(y3),"+w"(y4),"+w"(y5),"+w"(y6),"+w"(y7)); + y[0] = y0; + y[1] = y1; + y[2] = y2; + y[3] = y3; + y[4] = y4; + y[5] = y5; + y[6] = y6; + y[7] = y7; + + xx = (x + 4*128/sizeof(*x)); + yy = (y + 4*128/sizeof(*y)); + asm("":"+r"(yy)::"memory"); + prefetch(xx); + prefetch(yy); + + y += 8; + x += 8; + i += 8 ; + } + +} + + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i=0; + BLASLONG ix=0,iy=0; + + if ( n <= 0 ) return(0); + + if ( (inc_x == 1) && (inc_y == 1) ) + { + + BLASLONG n1 = n & -32; + + if ( n1 ) + daxpy_kernel_8(n1, x, y , &da ); + + i = n1; + while(i < n) + { + + y[i] += da * x[i] ; + i++ ; + + } + return(0); + + + } + + BLASLONG n1 = n & -4; + + while(i < n1) + { + + FLOAT m1 = da * x[ix] ; + FLOAT m2 = da * x[ix+inc_x] ; + FLOAT m3 = da * x[ix+2*inc_x] ; + FLOAT m4 = da * x[ix+3*inc_x] ; + + y[iy] += m1 ; + y[iy+inc_y] += m2 ; + y[iy+2*inc_y] += m3 ; + y[iy+3*inc_y] += m4 ; + + ix += inc_x*4 ; + iy += inc_y*4 ; + i+=4 ; + + } + + while(i < n) + { + + y[iy] += da * x[ix] ; + ix += inc_x ; + iy += inc_y ; + i++ ; + + } + return(0); + +} + + diff --git a/kernel/arm64/dnrm2.S b/kernel/arm64/daxpy_thunderx2t99.S similarity index 58% rename from kernel/arm64/dnrm2.S rename to kernel/arm64/daxpy_thunderx2t99.S index 3dec99efd1..5eb2ec0c3b 100644 --- a/kernel/arm64/dnrm2.S +++ b/kernel/arm64/daxpy_thunderx2t99.S @@ -1,5 +1,5 @@ /******************************************************************************* -Copyright (c) 2015, The OpenBLAS Project +Copyright (c) 2017, The OpenBLAS Project All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are @@ -29,52 +29,90 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #define N x0 /* vector length */ -#define X x1 /* X vector address */ -#define INC_X x2 /* X stride */ -#define I x5 /* loop variable */ +#define X x3 /* X vector address */ +#define INC_X x4 /* X stride */ +#define Y x5 /* Y vector address */ +#define INC_Y x6 /* Y stride */ +#define I x1 /* loop variable */ /******************************************************************************* * Macro definitions *******************************************************************************/ -#define TMPF d6 -#define SSQ d0 -#define TMPVF {v6.d}[0] +#define DA d0 /* scale input value */ +#define TMPX d1 +#define TMPVX {v1.d}[0] +#define TMPY d2 +#define TMPVY {v2.d}[0] #define SZ 8 /******************************************************************************/ .macro KERNEL_F1 - ldr TMPF, [X], #SZ - fmul TMPF, TMPF, TMPF - fadd SSQ, SSQ, TMPF + ldr TMPX, [X], #SZ + ldr TMPY, [Y] + fmadd TMPY, TMPX, DA, TMPY + str TMPY, [Y], #SZ .endm -.macro KERNEL_F8 - ld1 {v1.2d, v2.2d}, [X], #32 - fmla v0.2d, v1.2d, v1.2d - fmla v5.2d, v2.2d, v2.2d - ld1 {v3.2d, v4.2d}, [X], #32 - fmla v0.2d, v3.2d, v3.2d - fmla v5.2d, v4.2d, v4.2d - PRFM PLDL1KEEP, [X, #1024] +.macro KERNEL_F16 + ldp q4, q5, [X] + ldp q16, q17, [Y] + + ldp q6, q7, [X, #32] + ldp q18, q19, [Y, #32] + + fmla v16.2d, v4.2d, v0.d[0] + fmla v17.2d, v5.2d, v0.d[0] + + PRFM PLDL1KEEP, [X, #896] + PRFM PLDL1KEEP, [Y, #896] + + stp q16, q17, [Y] + + ldp q20, q21, [X, #64] + ldp q24, q25, [Y, #64] + + fmla v18.2d, v6.2d, v0.d[0] + fmla v19.2d, v7.2d, v0.d[0] + + PRFM PLDL1KEEP, [X, #896+64] + PRFM PLDL1KEEP, [Y, #896+64] + + stp q18, q19, [Y, #32] + + ldp q22, q23, [X, #96] + ldp q26, q27, [Y, #96] + + fmla v24.2d, v20.2d, v0.d[0] + fmla v25.2d, v21.2d, v0.d[0] + + stp q24, q25, [Y, #64] + + fmla v26.2d, v22.2d, v0.d[0] + fmla v27.2d, v23.2d, v0.d[0] + + stp q26, q27, [Y, #96] + + add Y, Y, #128 + add X, X, #128 .endm -.macro nrm2_kernel_F8_FINALIZE - fadd v0.2d, v0.2d, v5.2d - faddp SSQ, v0.2d +.macro KERNEL_F32 + KERNEL_F16 + KERNEL_F16 .endm .macro INIT_S lsl INC_X, INC_X, #3 - ld1 TMPVF, [X], INC_X - fmul SSQ, TMPF, TMPF + lsl INC_Y, INC_Y, #3 .endm .macro KERNEL_S1 - ld1 TMPVF, [X], INC_X - fmul TMPF, TMPF, TMPF - fadd SSQ, SSQ, TMPF + ld1 TMPVX, [X], INC_X + ldr TMPY, [Y] + fmadd TMPY, TMPX, DA, TMPY + st1 TMPVY, [Y], INC_Y .endm /******************************************************************************* @@ -83,61 +121,54 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PROLOGUE - fmov SSQ, xzr - fmov d5, SSQ - cmp N, xzr - ble nrm2_kernel_zero - cmp INC_X, xzr - ble nrm2_kernel_zero + ble axpy_kernel_L999 + + fcmp DA, #0.0 + beq axpy_kernel_L999 + cmp INC_X, #1 - bne nrm2_kernel_S_BEGIN + bne axpy_kernel_S_BEGIN + cmp INC_Y, #1 + bne axpy_kernel_S_BEGIN -nrm2_kernel_F_BEGIN: +axpy_kernel_F_BEGIN: - asr I, N, #3 + asr I, N, #5 cmp I, xzr - beq nrm2_kernel_F1_INIT + beq axpy_kernel_F1 -nrm2_kernel_F8: + .align 5 +axpy_kernel_F32: - KERNEL_F8 + KERNEL_F32 subs I, I, #1 - bne nrm2_kernel_F8 - - nrm2_kernel_F8_FINALIZE + bne axpy_kernel_F32 -nrm2_kernel_F1: +axpy_kernel_F1: - ands I, N, #7 - ble nrm2_kernel_L999 + ands I, N, #31 + ble axpy_kernel_L999 -nrm2_kernel_F10: +axpy_kernel_F10: KERNEL_F1 subs I, I, #1 - bne nrm2_kernel_F10 + bne axpy_kernel_F10 - b nrm2_kernel_L999 + b axpy_kernel_L999 -nrm2_kernel_F1_INIT: - - b nrm2_kernel_F1 - -nrm2_kernel_S_BEGIN: +axpy_kernel_S_BEGIN: INIT_S - subs N, N, #1 - ble nrm2_kernel_L999 - asr I, N, #2 cmp I, xzr - ble nrm2_kernel_S1 + ble axpy_kernel_S1 -nrm2_kernel_S4: +axpy_kernel_S4: KERNEL_S1 KERNEL_S1 @@ -145,25 +176,21 @@ nrm2_kernel_S4: KERNEL_S1 subs I, I, #1 - bne nrm2_kernel_S4 + bne axpy_kernel_S4 -nrm2_kernel_S1: +axpy_kernel_S1: ands I, N, #3 - ble nrm2_kernel_L999 + ble axpy_kernel_L999 -nrm2_kernel_S10: +axpy_kernel_S10: KERNEL_S1 subs I, I, #1 - bne nrm2_kernel_S10 + bne axpy_kernel_S10 -nrm2_kernel_L999: - fsqrt SSQ, SSQ - ret +axpy_kernel_L999: -nrm2_kernel_zero: + mov w0, wzr ret - - EPILOGUE diff --git a/kernel/arm64/ddot_thunderx.c b/kernel/arm64/ddot_thunderx.c new file mode 100644 index 0000000000..2f11e364fa --- /dev/null +++ b/kernel/arm64/ddot_thunderx.c @@ -0,0 +1,119 @@ +/*************************************************************************** +Copyright (c) 2014, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#define prefetch(a) __asm__("prfm PLDL1STRM, [%0]"::"r"(a):"memory"); + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + BLASLONG i=0; + BLASLONG ix=0,iy=0; + + FLOAT dot = 0.0 ; + + if ( n < 0 ) return(dot); + + if ( (inc_x == 1) && (inc_y == 1) ) + { + + float64x2_t vdot0 = {0.0, 0.0}; + float64x2_t vdot1 = {0.0, 0.0}; + float64x2_t vdot2 = {0.0, 0.0}; + float64x2_t vdot3 = {0.0, 0.0}; + float64x2_t *vx = (float64x2_t*)x; + float64x2_t *vy = (float64x2_t*)y; +#if 0 + prefetch(x + 128/sizeof(*x)); + prefetch(y + 128/sizeof(*y)); +#endif + prefetch(x + 2*128/sizeof(*x)); + prefetch(y + 2*128/sizeof(*y)); + prefetch(x + 3*128/sizeof(*x)); + prefetch(y + 3*128/sizeof(*y)); + + int n1 = n&-8; + + while(i < n1) + { +#if 0 + vdot0 = vfmaq_f64 (vdot0, + vy[0], + vx[0]); + vdot1 = vfmaq_f64 (vdot1, + vy[1], + vx[1]); + vdot2 = vfmaq_f64 (vdot2, + vy[2], + vx[2]); + vdot3 = vfmaq_f64 (vdot3, + vy[3], + vx[3]); +#else + vdot0 = vy[0] * vx[0] + vdot0; + vdot1 = vy[1] * vx[1] + vdot1; + vdot2 = vy[2] * vx[2] + vdot2; + vdot3 = vy[3] * vx[3] + vdot3; +#endif + vy += 4; + vx += 4; + i += 8; + prefetch(vx + 3*128/sizeof(*x)); + prefetch(vy + 3*128/sizeof(*y)); + + } + dot = vaddvq_f64 (vdot0 + vdot1); + dot += vaddvq_f64 (vdot2 + vdot3); + i = n1; + + while(i < n) + { + dot += y[i] * x[i] ; + i++ ; + + } + return(dot); + + + } + + while(i < n) + { + dot += y[iy] * x[ix] ; + ix += inc_x ; + iy += inc_y ; + i++ ; + + } + return(dot); + +} + + diff --git a/kernel/arm64/dgemm_kernel_8x4_thunderx2t99.S b/kernel/arm64/dgemm_kernel_8x4_thunderx2t99.S new file mode 100644 index 0000000000..86865d825c --- /dev/null +++ b/kernel/arm64/dgemm_kernel_8x4_thunderx2t99.S @@ -0,0 +1,1788 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* X0 X1 X2 s0 X3 x4 x5 x6 */ +/*int CNAME(BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha0,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc )*/ + +#define origM x0 +#define origN x1 +#define origK x2 +#define origPA x3 +#define origPB x4 +#define pC x5 +#define LDC x6 +#define temp x7 +#define counterL x8 +#define counterI x9 +#define counterJ x10 +#define pB x11 +#define pCRow0 x12 +#define pCRow1 x13 +#define pCRow2 x14 +#define pCRow3 x15 +#define pA x16 +#define alpha x17 + +#define alpha0 d10 +#define alphaV0 v10.d[0] + +#define A_PRE_SIZE x20 +#define B_PRE_SIZE x21 +#define C_PRE_SIZE x22 + +#define A_PRE_SIZE_64 x23 +#define B_PRE_SIZE_64 x24 + + +// 00 origM +// 01 origN +// 02 origK +// 03 origPA +// 04 origPB +// 05 pC +// 06 origLDC -> LDC +// 07 temp +// 08 counterL +// 09 counterI +// 10 counterJ +// 11 pB +// 12 pCRow0 +// 13 pCRow1 +// 14 pCRow2 +// 15 pCRow3 +// 16 pA +// 17 +// 18 must save +// 19 must save +// 20 must save +// 21 must save +// 22 must save +// 23 must save +// 24 must save +// 25 must save +// 26 must save +// 27 must save +// 28 must save +// 29 frame +// 30 link +// 31 sp + +//v00 ALPHA -> pA0_0, pA0_1 +//v01 pA0_2, pA0_3 +//v02 pA0_4, pA0_5 +//v03 pA0_6, pA0_7 +//v04 pA1_0, pA1_1 +//v05 pA1_2, pA1_3 +//v06 pA1_4, pA1_5 +//v07 pA1_6, pA1_7 +//v08 must save pB0_0 +//v09 must save pB0_1 +//v10 must save pB0_2 --> ALPHA0 +//v11 must save pB0_3 +//v12 must save pB1_0 +//v13 must save pB1_1 +//v14 must save pB1_2 +//v15 must save pB1_3 +//v16 must save C00, C01 +//v17 must save C02, C03 +//v18 C04, C05 +//v19 C06, C07 +//v20 C10, C11 +//v21 C12, C13 +//v22 C14, C15 +//v23 C16, C17 +//v24 C20, C21 +//v25 C22, C23 +//v26 C24, C25 +//v27 C26, C27 +//v28 C30, C31 +//v29 C32, C33 +//v30 C34, C35 +//v31 C36, C37 + +/******************************************************************************* +* Macro definitions +*******************************************************************************/ + +.macro INIT8x4 + fmov d16, xzr + fmov d17, xzr + fmov d18, d16 + fmov d19, xzr + fmov d20, xzr + fmov d21, d16 + fmov d22, d17 + fmov d23, d18 + fmov d24, xzr + fmov d25, d16 + fmov d26, d17 + fmov d27, d18 + fmov d28, xzr + fmov d29, d16 + fmov d30, d17 + fmov d31, d18 +.endm + +.macro KERNEL8x4_I + ldp q0, q1, [pA] + ldp q8, q9, [pB] + ldp q2, q3, [pA, #32] + ldp q4, q5, [pA, #64] + ldp q12, q13, [pB, #32] + ldp q6, q7, [pA, #96] + + fmul v16.2d, v0.2d, v8.d[0] + fmul v20.2d, v0.2d, v8.d[1] + fmul v17.2d, v1.2d, v8.d[0] + fmul v21.2d, v1.2d, v8.d[1] + + add pA, pA, #128 + add pB, pB, #64 + + fmul v24.2d, v0.2d, v9.d[0] + fmul v28.2d, v0.2d, v9.d[1] + fmul v25.2d, v1.2d, v9.d[0] + fmul v29.2d, v1.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + + fmul v18.2d, v2.2d, v8.d[0] + fmul v22.2d, v2.2d, v8.d[1] + fmul v26.2d, v2.2d, v9.d[0] + fmul v30.2d, v2.2d, v9.d[1] + + fmul v19.2d, v3.2d, v8.d[0] + fmul v27.2d, v3.2d, v9.d[0] + fmul v31.2d, v3.2d, v9.d[1] + fmul v23.2d, v3.2d, v8.d[1] +.endm + +.macro KERNEL8x4_M1_M2 + + ldp q12, q13, [pB] + ldp q4, q5, [pA] + ldp q6, q7, [pA, #32] + + fmla v16.2d, v0.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] + fmla v24.2d, v0.2d, v9.d[0] + fmla v28.2d, v0.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + fmla v17.2d, v1.2d, v8.d[0] + fmla v25.2d, v1.2d, v9.d[0] + fmla v21.2d, v1.2d, v8.d[1] + fmla v29.2d, v1.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + + fmla v18.2d, v2.2d, v8.d[0] + fmla v22.2d, v2.2d, v8.d[1] + fmla v26.2d, v2.2d, v9.d[0] + fmla v30.2d, v2.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, #3840] + + fmla v19.2d, v3.2d, v8.d[0] + fmla v23.2d, v3.2d, v8.d[1] + fmla v27.2d, v3.2d, v9.d[0] + fmla v31.2d, v3.2d, v9.d[1] + + + ldp q8, q9, [pB, #32] + ldp q0, q1, [pA, #64] + ldp q2, q3, [pA, #96] + + fmla v16.2d, v4.2d, v12.d[0] + fmla v20.2d, v4.2d, v12.d[1] + fmla v24.2d, v4.2d, v13.d[0] + fmla v28.2d, v4.2d, v13.d[1] + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + fmla v17.2d, v5.2d, v12.d[0] + fmla v25.2d, v5.2d, v13.d[0] + fmla v21.2d, v5.2d, v12.d[1] + fmla v29.2d, v5.2d, v13.d[1] + + fmla v18.2d, v6.2d, v12.d[0] + fmla v22.2d, v6.2d, v12.d[1] + fmla v26.2d, v6.2d, v13.d[0] + fmla v30.2d, v6.2d, v13.d[1] + + add pB, pB, #64 + add pA, pA, #128 + + fmla v19.2d, v7.2d, v12.d[0] + fmla v23.2d, v7.2d, v12.d[1] + fmla v27.2d, v7.2d, v13.d[0] + fmla v31.2d, v7.2d, v13.d[1] +.endm + + +.macro KERNEL8x4_M1 + ldp q12, q13, [pB] + ldp q4, q5, [pA] + ldp q6, q7, [pA, #32] + + fmla v16.2d, v0.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] + fmla v24.2d, v0.2d, v9.d[0] + fmla v28.2d, v0.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + fmla v17.2d, v1.2d, v8.d[0] + fmla v25.2d, v1.2d, v9.d[0] + fmla v21.2d, v1.2d, v8.d[1] + fmla v29.2d, v1.2d, v9.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + + fmla v18.2d, v2.2d, v8.d[0] + fmla v22.2d, v2.2d, v8.d[1] + fmla v26.2d, v2.2d, v9.d[0] + fmla v30.2d, v2.2d, v9.d[1] + + add pB, pB, #32 + add pA, pA, #64 + + fmla v19.2d, v3.2d, v8.d[0] + fmla v23.2d, v3.2d, v8.d[1] + fmla v27.2d, v3.2d, v9.d[0] + fmla v31.2d, v3.2d, v9.d[1] +.endm + +.macro KERNEL8x4_M2 + ldp q8, q9, [pB] + ldp q0, q1, [pA] + ldp q2, q3, [pA, #32] + + fmla v16.2d, v4.2d, v12.d[0] + fmla v20.2d, v4.2d, v12.d[1] + fmla v24.2d, v4.2d, v13.d[0] + fmla v28.2d, v4.2d, v13.d[1] + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + fmla v17.2d, v5.2d, v12.d[0] + fmla v25.2d, v5.2d, v13.d[0] + fmla v21.2d, v5.2d, v12.d[1] + fmla v29.2d, v5.2d, v13.d[1] + + fmla v18.2d, v6.2d, v12.d[0] + fmla v22.2d, v6.2d, v12.d[1] + fmla v26.2d, v6.2d, v13.d[0] + fmla v30.2d, v6.2d, v13.d[1] + + add pB, pB, #32 + add pA, pA, #64 + + fmla v19.2d, v7.2d, v12.d[0] + fmla v23.2d, v7.2d, v12.d[1] + fmla v27.2d, v7.2d, v13.d[0] + fmla v31.2d, v7.2d, v13.d[1] +.endm + +.macro KERNEL8x4_E + fmla v16.2d, v4.2d, v12.d[0] + fmla v20.2d, v4.2d, v12.d[1] + fmla v24.2d, v4.2d, v13.d[0] + fmla v28.2d, v4.2d, v13.d[1] + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + fmla v17.2d, v5.2d, v12.d[0] + fmla v25.2d, v5.2d, v13.d[0] + fmla v21.2d, v5.2d, v12.d[1] + fmla v29.2d, v5.2d, v13.d[1] + + fmla v18.2d, v6.2d, v12.d[0] + fmla v22.2d, v6.2d, v12.d[1] + fmla v26.2d, v6.2d, v13.d[0] + fmla v30.2d, v6.2d, v13.d[1] + + fmla v19.2d, v7.2d, v12.d[0] + fmla v23.2d, v7.2d, v12.d[1] + fmla v27.2d, v7.2d, v13.d[0] + fmla v31.2d, v7.2d, v13.d[1] +.endm + +.macro KERNEL8x4_SUB + ldp q0, q1, [pA] + ldp q8, q9, [pB] + ldp q2, q3, [pA, #32] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + fmla v16.2d, v0.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] + fmla v17.2d, v1.2d, v8.d[0] + fmla v21.2d, v1.2d, v8.d[1] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + + fmla v24.2d, v0.2d, v9.d[0] + fmla v28.2d, v0.2d, v9.d[1] + fmla v25.2d, v1.2d, v9.d[0] + fmla v29.2d, v1.2d, v9.d[1] + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + fmla v18.2d, v2.2d, v8.d[0] + fmla v22.2d, v2.2d, v8.d[1] + fmla v26.2d, v2.2d, v9.d[0] + fmla v30.2d, v2.2d, v9.d[1] + + add pB, pB, #32 + add pA, pA, #64 + + fmla v19.2d, v3.2d, v8.d[0] + fmla v27.2d, v3.2d, v9.d[0] + fmla v31.2d, v3.2d, v9.d[1] + fmla v23.2d, v3.2d, v8.d[1] +.endm + +.macro SAVE8x4 + fmov alpha0, alpha + ldr q0, [pCRow0] + ldr q1, [pCRow0, #16] + ldr q2, [pCRow0, #32] + ldr q3, [pCRow0, #48] + ldr q4, [pCRow1] + ldr q5, [pCRow1, #16] + ldr q6, [pCRow1, #32] + ldr q7, [pCRow1, #48] + + fmla v0.2d, v16.2d, alphaV0 + fmla v1.2d, v17.2d, alphaV0 + stp q0, q1, [pCRow0] + + fmla v2.2d, v18.2d, alphaV0 + fmla v3.2d, v19.2d, alphaV0 + stp q2, q3, [pCRow0, #32] + ldr q0, [pCRow2] + ldr q1, [pCRow2, #16] + + fmla v4.2d, v20.2d, alphaV0 + fmla v5.2d, v21.2d, alphaV0 + stp q4, q5, [pCRow1] + ldr q2, [pCRow2, #32] + ldr q3, [pCRow2, #48] + + fmla v6.2d, v22.2d, alphaV0 + fmla v7.2d, v23.2d, alphaV0 + stp q6, q7, [pCRow1, #32] + ldr q4, [pCRow3] + ldr q5, [pCRow3, #16] + + fmla v0.2d, v24.2d, alphaV0 + fmla v1.2d, v25.2d, alphaV0 + stp q0, q1, [pCRow2] + ldr q6, [pCRow3, #32] + ldr q7, [pCRow3, #48] + + fmla v2.2d, v26.2d, alphaV0 + fmla v3.2d, v27.2d, alphaV0 + stp q2, q3, [pCRow2, #32] + + fmla v4.2d, v28.2d, alphaV0 + fmla v5.2d, v29.2d, alphaV0 + stp q4, q5, [pCRow3] + + fmla v6.2d, v30.2d, alphaV0 + fmla v7.2d, v31.2d, alphaV0 + stp q6, q7, [pCRow3, #32] + + add pCRow0, pCRow0, #64 + add pCRow1, pCRow1, #64 + add pCRow2, pCRow2, #64 + add pCRow3, pCRow3, #64 +.endm + +/******************************************************************************/ + +.macro INIT4x4 + fmov d16, xzr + fmov d17, d16 + fmov d20, d17 + fmov d21, d16 + fmov d24, d17 + fmov d25, d16 + fmov d28, d17 + fmov d29, d16 +.endm + +.macro KERNEL4x4_SUB + ld1 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld1 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v29.2d, v1.2d, v9.d[1] + + fmla v20.2d, v0.2d, v8.d[1] + fmla v25.2d, v1.2d, v9.d[0] + + fmla v24.2d, v0.2d, v9.d[0] + fmla v21.2d, v1.2d, v8.d[1] + + fmla v28.2d, v0.2d, v9.d[1] + fmla v17.2d, v1.2d, v8.d[0] +.endm + +.macro SAVE4x4 + fmov alpha0, alpha + + ld1 {v8.2d, v9.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + fmla v9.2d, v17.2d, alphaV0 + st1 {v8.2d, v9.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #32 + + ld1 {v12.2d, v13.2d}, [pCRow1] + fmla v12.2d, v20.2d, alphaV0 + fmla v13.2d, v21.2d, alphaV0 + st1 {v12.2d, v13.2d}, [pCRow1] + + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #32 + + ld1 {v8.2d, v9.2d}, [pCRow2] + fmla v8.2d, v24.2d, alphaV0 + fmla v9.2d, v25.2d, alphaV0 + st1 {v8.2d, v9.2d}, [pCRow2] + + prfm PLDL2KEEP, [pCRow2, C_PRE_SIZE] + add pCRow2, pCRow2, #32 + + ld1 {v12.2d, v13.2d}, [pCRow3] + fmla v12.2d, v28.2d, alphaV0 + fmla v13.2d, v29.2d, alphaV0 + st1 {v12.2d, v13.2d}, [pCRow3] + + prfm PLDL2KEEP, [pCRow3, C_PRE_SIZE] + add pCRow3, pCRow3, #32 +.endm + +/******************************************************************************/ + + +.macro INIT2x4 + fmov d16, xzr + fmov d20, d16 + fmov d24, d20 + fmov d28, d16 +.endm + +.macro KERNEL2x4_SUB + ld1 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld1 {v0.2d}, [pA] + add pA, pA, #16 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] + fmla v24.2d, v0.2d, v9.d[0] + fmla v28.2d, v0.2d, v9.d[1] +.endm + +.macro SAVE2x4 + fmov alpha0, alpha + + ld1 {v8.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + st1 {v8.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #16 + + ld1 {v12.2d}, [pCRow1] + fmla v12.2d, v20.2d, alphaV0 + st1 {v12.2d}, [pCRow1] + + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #16 + + ld1 {v8.2d}, [pCRow2] + fmla v8.2d, v24.2d, alphaV0 + st1 {v8.2d}, [pCRow2] + + prfm PLDL2KEEP, [pCRow2, C_PRE_SIZE] + add pCRow2, pCRow2, #16 + + ld1 {v12.2d}, [pCRow3] + fmla v12.2d, v28.2d, alphaV0 + st1 {v12.2d}, [pCRow3] + + prfm PLDL2KEEP, [pCRow3, C_PRE_SIZE] + add pCRow3, pCRow3, #16 +.endm + +/******************************************************************************/ + +.macro INIT1x4 + fmov d16, xzr + fmov d20, d16 +.endm + +.macro KERNEL1x4_SUB + ldr d0, [pA] + add pA, pA, #8 + + ld1 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + + fmla v16.2d, v8.2d, v0.d[0] + fmla v20.2d, v9.2d, v0.d[0] +.endm + +.macro SAVE1x4 + fmov alpha0, alpha + + ld1 {v8.d}[0], [pCRow0] + ld1 {v8.d}[1], [pCRow1] + fmla v8.2d, v16.2d, alphaV0 + st1 {v8.d}[0], [pCRow0] + st1 {v8.d}[1], [pCRow1] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #8 + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #8 + + ld1 {v12.d}[0], [pCRow2] + ld1 {v12.d}[1], [pCRow3] + fmla v12.2d, v20.2d, alphaV0 + st1 {v12.d}[0], [pCRow2] + st1 {v12.d}[1], [pCRow3] + + prfm PLDL2KEEP, [pCRow2, C_PRE_SIZE] + add pCRow2, pCRow2, #8 + prfm PLDL2KEEP, [pCRow3, C_PRE_SIZE] + add pCRow3, pCRow3, #8 +.endm + +/******************************************************************************/ + +.macro INIT8x2 + fmov d16, xzr + fmov d17, xzr + fmov d18, d16 + fmov d19, d17 + fmov d20, xzr + fmov d21, d16 + fmov d22, d17 + fmov d23, d18 +.endm + +.macro KERNEL8x2_SUB + ld1 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + ld1 {v8.2d}, [pB] + add pB, pB, #16 + ld1 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v17.2d, v1.2d, v8.d[0] + fmla v18.2d, v2.2d, v8.d[0] + fmla v19.2d, v3.2d, v8.d[0] + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + fmla v20.2d, v0.2d, v8.d[1] + fmla v21.2d, v1.2d, v8.d[1] + fmla v22.2d, v2.2d, v8.d[1] + fmla v23.2d, v3.2d, v8.d[1] +.endm + +.macro SAVE8x2 + fmov alpha0, alpha + + ld1 {v0.2d, v1.2d, v2.2d, v3.2d}, [pCRow0] + fmla v0.2d, v16.2d, alphaV0 + fmla v1.2d, v17.2d, alphaV0 + fmla v2.2d, v18.2d, alphaV0 + fmla v3.2d, v19.2d, alphaV0 + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #64 + + ld1 {v4.2d, v5.2d, v6.2d, v7.2d}, [pCRow1] + fmla v4.2d, v20.2d, alphaV0 + fmla v5.2d, v21.2d, alphaV0 + fmla v6.2d, v22.2d, alphaV0 + fmla v7.2d, v23.2d, alphaV0 + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [pCRow1] + + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #64 +.endm + +/******************************************************************************/ + +.macro INIT4x2 + fmov d16, xzr + fmov d17, d16 + fmov d20, d17 + fmov d21, d16 +.endm + +.macro KERNEL4x2_SUB + ld1 {v8.2d}, [pB] + add pB, pB, #16 + ld1 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v17.2d, v1.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] + fmla v21.2d, v1.2d, v8.d[1] +.endm + +.macro SAVE4x2 + fmov alpha0, alpha + + ld1 {v8.2d, v9.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + fmla v9.2d, v17.2d, alphaV0 + st1 {v8.2d, v9.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #32 + + ld1 {v12.2d, v13.2d}, [pCRow1] + fmla v12.2d, v20.2d, alphaV0 + fmla v13.2d, v21.2d, alphaV0 + st1 {v12.2d, v13.2d}, [pCRow1] + + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #32 +.endm + +/******************************************************************************/ + +.macro INIT2x2 + fmov d16, xzr + fmov d20, d16 +.endm + +.macro KERNEL2x2_SUB + ld1 {v8.2d}, [pB] + add pB, pB, #16 + + ld1 {v0.2d}, [pA] + add pA, pA, #16 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v20.2d, v0.2d, v8.d[1] +.endm + +.macro SAVE2x2 + fmov alpha0, alpha + + ld1 {v8.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + st1 {v8.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #16 + + ld1 {v12.2d}, [pCRow1] + fmla v12.2d, v20.2d, alphaV0 + st1 {v12.2d}, [pCRow1] + + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #16 +.endm + +/******************************************************************************/ + +.macro INIT1x2 + fmov d16, xzr +.endm + +.macro KERNEL1x2_SUB + ld1 {v8.2d} , [pB] + add pB , pB, #16 + + ldr d0 , [pA] + add pA, pA, #8 + + fmla v16.2d, v8.2d, v0.d[0] +.endm + +.macro SAVE1x2 + fmov alpha0, alpha + + ld1 {v8.d}[0], [pCRow0] + ld1 {v8.d}[1], [pCRow1] + fmla v8.2d, v16.2d, alphaV0 + st1 {v8.d}[0], [pCRow0] + st1 {v8.d}[1], [pCRow1] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #8 + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + add pCRow1, pCRow1, #8 +.endm + +/******************************************************************************/ + +.macro INIT8x1 + fmov d16, xzr + fmov d17, xzr + fmov d18, d16 + fmov d19, d17 +.endm + +.macro KERNEL8x1_SUB + ld1 {v0.2d, v1.2d}, [pA] + add pA , pA, #32 + + ldr d8, [pB] + add pB , pB, #8 + + ld1 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v17.2d, v1.2d, v8.d[0] + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + fmla v18.2d, v2.2d, v8.d[0] + fmla v19.2d, v3.2d, v8.d[0] +.endm + +.macro SAVE8x1 + fmov alpha0, alpha + + ld1 {v0.2d, v1.2d, v2.2d, v3.2d}, [pCRow0] + fmla v0.2d, v16.2d, alphaV0 + fmla v1.2d, v17.2d, alphaV0 + fmla v2.2d, v18.2d, alphaV0 + fmla v3.2d, v19.2d, alphaV0 + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #64 +.endm + + +/******************************************************************************/ + +.macro INIT4x1 + fmov d16, xzr + fmov d17, d16 +.endm + +.macro KERNEL4x1_SUB + ldr d8, [pB] + add pB , pB, #8 + + ld1 {v0.2d, v1.2d}, [pA] + add pA , pA, #32 + + fmla v16.2d, v0.2d, v8.d[0] + fmla v17.2d, v1.2d, v8.d[0] +.endm + +.macro SAVE4x1 + fmov alpha0, alpha + + ld1 {v8.2d, v9.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + fmla v9.2d, v17.2d, alphaV0 + st1 {v8.2d, v9.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #32 +.endm + + +/******************************************************************************/ + +.macro INIT2x1 + fmov d16, xzr +.endm + +.macro KERNEL2x1_SUB + ldr d8, [pB] + add pB , pB, #8 + + ld1 {v0.2d}, [pA] + add pA , pA, #16 + + fmla v16.2d, v0.2d, v8.d[0] +.endm + +.macro SAVE2x1 + fmov alpha0, alpha + + ld1 {v8.2d}, [pCRow0] + fmla v8.2d, v16.2d, alphaV0 + st1 {v8.2d}, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT1x1 + fmov d16, xzr +.endm + +.macro KERNEL1x1_SUB + ldr d8, [pB] + add pB , pB, #8 + + ldr d0, [pA] + add pA , pA, #8 + + fmadd d16, d0, d8, d16 +.endm + +.macro SAVE1x1 + fmov alpha0, alpha + ldr d8, [pCRow0] + fmadd d8, d16, alpha0, d8 + str d8, [pCRow0] + + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + add pCRow0, pCRow0, #8 +.endm + +.macro KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1_M2 +.endm + +.macro KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1_M2_x1 +.endm + +.macro KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x2 +.endm + +.macro KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x4 +.endm + +.macro KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x8 +.endm + +.macro KERNEL8x4_M1_M2_x32 + KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x16 +.endm + +.macro KERNEL8x4_M1_M2_x64 + KERNEL8x4_M1_M2_x32 + KERNEL8x4_M1_M2_x32 +.endm + +/******************************************************************************* +* End of macro definitions +*******************************************************************************/ + + PROLOGUE + + .align 5 + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] + + prfm PLDL1KEEP, [origPB] + prfm PLDL1KEEP, [origPA] + + + ldr A_PRE_SIZE, =dgemm_prefetch_size_a + ldr A_PRE_SIZE, [A_PRE_SIZE] + ldr B_PRE_SIZE, =dgemm_prefetch_size_b + ldr B_PRE_SIZE, [B_PRE_SIZE] + ldr C_PRE_SIZE, =dgemm_prefetch_size_c + ldr C_PRE_SIZE, [C_PRE_SIZE] + add A_PRE_SIZE_64, A_PRE_SIZE, #64 + add B_PRE_SIZE_64, B_PRE_SIZE, #64 + + fmov alpha, d0 + + lsl LDC, LDC, #3 // ldc = ldc * 8 + + mov pB, origPB + + mov counterJ, origN + asr counterJ, counterJ, #2 // J = J / 4 + cmp counterJ, #0 + ble dgemm_kernel_L2_BEGIN + +/******************************************************************************/ + + .align 5 +dgemm_kernel_L4_BEGIN: + mov pCRow0, pC + add pCRow1, pCRow0, LDC + add pCRow2, pCRow1, LDC + add pCRow3, pCRow2, LDC + + add pC, pCRow3, LDC + + mov pA, origPA // pA = start of A array + +dgemm_kernel_L4_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble dgemm_kernel_L4_M4_BEGIN + + .align 5 +dgemm_kernel_L4_M8_20: + + mov pB, origPB + + asr counterL , origK, #7 // L = K / 128 + cmp counterL , #2 // is there at least 4 to do? + blt dgemm_kernel_L4_M8_32 + + KERNEL8x4_I + KERNEL8x4_M2 + KERNEL8x4_M1_M2_x32 + KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x1 + + subs counterL, counterL, #2 // subtract 2 + ble dgemm_kernel_L4_M8_22a + + .align 5 +dgemm_kernel_L4_M8_22: + + KERNEL8x4_M1_M2_x64 + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M8_22 + + .align 5 +dgemm_kernel_L4_M8_22a: + + KERNEL8x4_M1_M2_x32 + KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1_M2_x1 + KERNEL8x4_M1 + KERNEL8x4_E + + b dgemm_kernel_L4_M8_44 + + .align 5 +dgemm_kernel_L4_M8_32: + + tst counterL, #1 + ble dgemm_kernel_L4_M8_40 + + KERNEL8x4_I + KERNEL8x4_M2 + KERNEL8x4_M1_M2_x32 + KERNEL8x4_M1_M2_x16 + KERNEL8x4_M1_M2_x8 + KERNEL8x4_M1_M2_x4 + KERNEL8x4_M1_M2_x2 + KERNEL8x4_M1 + KERNEL8x4_E + + b dgemm_kernel_L4_M8_44 + +dgemm_kernel_L4_M8_40: + + INIT8x4 + +dgemm_kernel_L4_M8_44: + + ands counterL , origK, #127 + ble dgemm_kernel_L4_M8_100 + + .align 5 +dgemm_kernel_L4_M8_46: + + KERNEL8x4_SUB + + subs counterL, counterL, #1 + bne dgemm_kernel_L4_M8_46 + +dgemm_kernel_L4_M8_100: + prfm PLDL2KEEP, [pCRow0, C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow1, C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow2, C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow3, C_PRE_SIZE] + prfm PLDL1KEEP, [pA] + prfm PLDL1KEEP, [pA, #64] + prfm PLDL1KEEP, [origPB] + + SAVE8x4 + +dgemm_kernel_L4_M8_END: + subs counterI, counterI, #1 + bne dgemm_kernel_L4_M8_20 + +dgemm_kernel_L4_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble dgemm_kernel_L4_END + + tst counterI, #4 + ble dgemm_kernel_L4_M2_BEGIN + +dgemm_kernel_L4_M4_20: + + INIT4x4 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L4_M4_40 + + .align 5 +dgemm_kernel_L4_M4_22: + + KERNEL4x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + KERNEL4x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M4_22 + +dgemm_kernel_L4_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L4_M4_100 + +dgemm_kernel_L4_M4_42: + + KERNEL4x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M4_42 + +dgemm_kernel_L4_M4_100: + + SAVE4x4 + +dgemm_kernel_L4_M4_END: + +dgemm_kernel_L4_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble dgemm_kernel_L4_END + + tst counterI, #2 // counterI = counterI / 2 + ble dgemm_kernel_L4_M1_BEGIN + +dgemm_kernel_L4_M2_20: + + INIT2x4 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L4_M2_40 + + .align 5 +dgemm_kernel_L4_M2_22: + + KERNEL2x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x4_SUB + + KERNEL2x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x4_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M2_22 + + +dgemm_kernel_L4_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L4_M2_100 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] +dgemm_kernel_L4_M2_42: + + KERNEL2x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M2_42 + +dgemm_kernel_L4_M2_100: + + SAVE2x4 + +dgemm_kernel_L4_M2_END: + + +dgemm_kernel_L4_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble dgemm_kernel_L4_END + +dgemm_kernel_L4_M1_20: + + INIT1x4 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L4_M1_40 + + .align 5 +dgemm_kernel_L4_M1_22: + KERNEL1x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x4_SUB + KERNEL1x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x4_SUB + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + KERNEL1x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x4_SUB + KERNEL1x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M1_22 + + +dgemm_kernel_L4_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L4_M1_100 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] +dgemm_kernel_L4_M1_42: + + KERNEL1x4_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L4_M1_42 + +dgemm_kernel_L4_M1_100: + + SAVE1x4 + +dgemm_kernel_L4_END: + + lsl temp, origK, #5 + add origPB, origPB, temp // B = B + K * 4 * 8 + + subs counterJ, counterJ , #1 // j-- + bgt dgemm_kernel_L4_BEGIN + + +/******************************************************************************/ + +dgemm_kernel_L2_BEGIN: // less than 2 left in N direction + + mov counterJ , origN + tst counterJ , #3 + ble dgemm_kernel_L999 // error, N was less than 4? + + tst counterJ , #2 + ble dgemm_kernel_L1_BEGIN + + mov pCRow0, pC + add pCRow1, pCRow0, LDC + + add pC, pCRow1, LDC + + mov pA, origPA // pA = A + +dgemm_kernel_L2_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble dgemm_kernel_L2_M4_BEGIN + + .align 5 +dgemm_kernel_L2_M8_20: + + INIT8x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble dgemm_kernel_L2_M8_40 + + .align 5 +dgemm_kernel_L2_M8_22: + KERNEL8x2_SUB + KERNEL8x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL8x2_SUB + KERNEL8x2_SUB + + KERNEL8x2_SUB + KERNEL8x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL8x2_SUB + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M8_22 + +dgemm_kernel_L2_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L2_M8_100 + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE_64] +dgemm_kernel_L2_M8_42: + + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M8_42 + +dgemm_kernel_L2_M8_100: + + SAVE8x2 + +dgemm_kernel_L2_M8_END: + + subs counterI, counterI, #1 + bgt dgemm_kernel_L2_M8_20 + +dgemm_kernel_L2_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble dgemm_kernel_L2_END + + tst counterI, #4 // counterI = counterI / 2 + ble dgemm_kernel_L2_M2_BEGIN + +dgemm_kernel_L2_M4_20: + + INIT4x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble dgemm_kernel_L2_M4_40 + + .align 5 +dgemm_kernel_L2_M4_22: + KERNEL4x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x2_SUB + + KERNEL4x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL4x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M4_22 + + +dgemm_kernel_L2_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L2_M4_100 + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE_64] +dgemm_kernel_L2_M4_42: + + KERNEL4x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M4_42 + +dgemm_kernel_L2_M4_100: + + SAVE4x2 + +dgemm_kernel_L2_M4_END: + + +dgemm_kernel_L2_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble dgemm_kernel_L2_END + + tst counterI, #2 // counterI = counterI / 2 + ble dgemm_kernel_L2_M1_BEGIN + +dgemm_kernel_L2_M2_20: + + INIT2x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble dgemm_kernel_L2_M2_40 + +dgemm_kernel_L2_M2_22: + + KERNEL2x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x2_SUB + KERNEL2x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x2_SUB + + KERNEL2x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL2x2_SUB + KERNEL2x2_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M2_22 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE_64] +dgemm_kernel_L2_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L2_M2_100 + +dgemm_kernel_L2_M2_42: + + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M2_42 + +dgemm_kernel_L2_M2_100: + + SAVE2x2 + +dgemm_kernel_L2_M2_END: + + +dgemm_kernel_L2_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble dgemm_kernel_L2_END + +dgemm_kernel_L2_M1_20: + + INIT1x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL, #0 + ble dgemm_kernel_L2_M1_40 + +dgemm_kernel_L2_M1_22: + KERNEL1x2_SUB + KERNEL1x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x2_SUB + KERNEL1x2_SUB + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + KERNEL1x2_SUB + KERNEL1x2_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x2_SUB + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M1_22 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE_64] +dgemm_kernel_L2_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L2_M1_100 + +dgemm_kernel_L2_M1_42: + + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L2_M1_42 + +dgemm_kernel_L2_M1_100: + + SAVE1x2 + +dgemm_kernel_L2_END: + add origPB, origPB, origK, lsl #4 // B = B + K * 2 * 8 + +/******************************************************************************/ + +dgemm_kernel_L1_BEGIN: + + mov counterJ , origN + tst counterJ , #1 + ble dgemm_kernel_L999 // done + + mov pCRow0, pC // pCRow0 = C + add pC , pC , LDC // Update pC to point to next + + mov pA, origPA // pA = A + +dgemm_kernel_L1_M8_BEGIN: + + mov counterI, origM + asr counterI, counterI, #3 // counterI = counterI / 8 + cmp counterI, #0 + ble dgemm_kernel_L1_M4_BEGIN + + .align 5 +dgemm_kernel_L1_M8_20: + + INIT8x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L1_M8_40 + + .align 5 +dgemm_kernel_L1_M8_22: + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M8_22 + + +dgemm_kernel_L1_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L1_M8_100 + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] +dgemm_kernel_L1_M8_42: + + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M8_42 + +dgemm_kernel_L1_M8_100: + + SAVE8x1 + +dgemm_kernel_L1_M8_END: + + subs counterI, counterI, #1 + bgt dgemm_kernel_L1_M8_20 + +dgemm_kernel_L1_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble dgemm_kernel_L1_END + + tst counterI, #4 // counterI = counterI / 2 + ble dgemm_kernel_L1_M2_BEGIN + +dgemm_kernel_L1_M4_20: + + INIT4x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L1_M4_40 + + .align 5 +dgemm_kernel_L1_M4_22: + KERNEL4x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x1_SUB + KERNEL4x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x1_SUB + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + KERNEL4x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x1_SUB + KERNEL4x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M4_22 + + +dgemm_kernel_L1_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L1_M4_100 + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] +dgemm_kernel_L1_M4_42: + + KERNEL4x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M4_42 + +dgemm_kernel_L1_M4_100: + + SAVE4x1 + +dgemm_kernel_L1_M4_END: + +dgemm_kernel_L1_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble dgemm_kernel_L1_END + + tst counterI, #2 // counterI = counterI / 2 + ble dgemm_kernel_L1_M1_BEGIN + +dgemm_kernel_L1_M2_20: + + INIT2x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L1_M2_40 + +dgemm_kernel_L1_M2_22: + + KERNEL2x1_SUB + KERNEL2x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x1_SUB + KERNEL2x1_SUB + + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + + KERNEL2x1_SUB + KERNEL2x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL2x1_SUB + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M2_22 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pA, A_PRE_SIZE_64] + prfm PLDL1KEEP, [pB, B_PRE_SIZE] +dgemm_kernel_L1_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L1_M2_100 + +dgemm_kernel_L1_M2_42: + + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M2_42 + +dgemm_kernel_L1_M2_100: + + SAVE2x1 + +dgemm_kernel_L1_M2_END: + + +dgemm_kernel_L1_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble dgemm_kernel_L1_END + +dgemm_kernel_L1_M1_20: + + INIT1x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble dgemm_kernel_L1_M1_40 + + +dgemm_kernel_L1_M1_22: + KERNEL1x1_SUB + KERNEL1x1_SUB + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + KERNEL1x1_SUB + KERNEL1x1_SUB + + KERNEL1x1_SUB + KERNEL1x1_SUB + prfm PLDL1KEEP, [pB, B_PRE_SIZE] + KERNEL1x1_SUB + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M1_22 + + +dgemm_kernel_L1_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble dgemm_kernel_L1_M1_100 + + prfm PLDL1KEEP, [pA, A_PRE_SIZE] + prfm PLDL1KEEP, [pB, B_PRE_SIZE] +dgemm_kernel_L1_M1_42: + + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt dgemm_kernel_L1_M1_42 + +dgemm_kernel_L1_M1_100: + + SAVE1x1 + + +dgemm_kernel_L1_END: + + +dgemm_kernel_L999: + mov x0, #0 // set return value + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) + ret + + EPILOGUE + diff --git a/kernel/arm64/dgemm_ncopy_4.S b/kernel/arm64/dgemm_ncopy_4.S new file mode 100644 index 0000000000..c98a732770 --- /dev/null +++ b/kernel/arm64/dgemm_ncopy_4.S @@ -0,0 +1,340 @@ +/*************************************************************************** +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A00 PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +#define M x0 +#define N x1 +#define A00 x2 +#define LDA x3 +#define B00 x4 + +#define A01 x5 +#define A02 x6 +#define A03 x7 +#define A04 x8 + +#define I x9 +#define J x10 + +#define TEMP1 x11 +#define TEMP2 x12 + +#define A_PREFETCH 2560 + +/************************************************************************************** +* Macro definitions +**************************************************************************************/ + +.macro SAVE_REGS + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] +.endm + +.macro RESTORE_REGS + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) +.endm + +.macro COPY4x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ins v8.d[0], v0.d[0] + ins v10.d[0], v0.d[1] + ins v12.d[0], v1.d[0] + ins v14.d[0], v1.d[1] + + ldp q2, q3, [A02], #32 + ins v8.d[1], v2.d[0] + ins v10.d[1], v2.d[1] + ins v12.d[1], v3.d[0] + ins v14.d[1], v3.d[1] + + ldp q4, q5, [A03], #32 + ins v9.d[0], v4.d[0] + ins v11.d[0], v4.d[1] + ins v13.d[0], v5.d[0] + ins v15.d[0], v5.d[1] + + ldp q6, q7, [A04], #32 + ins v9.d[1], v6.d[0] + ins v11.d[1], v6.d[1] + ins v13.d[1], v7.d[0] + ins v15.d[1], v7.d[1] + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [B00] + add B00, B00, #64 + + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [B00] + add B00, B00, #64 +.endm + +.macro COPY1x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B00] + add B00, B00, #32 +.endm + +.macro COPY4x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ins v8.d[0], v0.d[0] + ins v9.d[0], v0.d[1] + ins v10.d[0], v1.d[0] + ins v11.d[0], v1.d[1] + + ldp q2, q3, [A02], #32 + ins v8.d[1], v2.d[0] + ins v9.d[1], v2.d[1] + ins v10.d[1], v3.d[0] + ins v11.d[1], v3.d[1] + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [B00] + add B00, B00, #64 +.endm + + +.macro COPY1x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + + stp d0, d1, [B00] + add B00, B00, #16 +.endm + +.macro COPY4x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + stp q0, q1, [B00], #32 +.endm + + +.macro COPY1x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr d0, [A01], #8 + str d0, [B00], #8 +.endm + +/************************************************************************************** +* End of macro definitions +**************************************************************************************/ + + PROLOGUE + + .align 5 + + SAVE_REGS + + lsl LDA, LDA, #3 // LDA = LDA * SIZE + +dgemm_ncopy_L4_BEGIN: + + asr J, N, #2 // J = N / 4 + cmp J, #0 + ble dgemm_ncopy_L2_BEGIN + + .align 5 +dgemm_ncopy_L4_M4_BEGIN: + + mov A01, A00 + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A00, A04, LDA + + asr I, M, #2 // I = M / 4 + cmp I, #0 + ble dgemm_ncopy_L4_M4_40 + + .align 5 +dgemm_ncopy_L4_M4_20: + + COPY4x4 + + subs I , I , #1 + bne dgemm_ncopy_L4_M4_20 + + +dgemm_ncopy_L4_M4_40: + + and I, M , #3 + cmp I, #0 + ble dgemm_ncopy_L4_M4_END + + .align 5 +dgemm_ncopy_L4_M4_60: + + COPY1x4 + + subs I , I , #1 + bne dgemm_ncopy_L4_M4_60 + + +dgemm_ncopy_L4_M4_END: + + subs J , J, #1 // j-- + bne dgemm_ncopy_L4_M4_BEGIN + + + +/*********************************************************************************************/ + +dgemm_ncopy_L2_BEGIN: + + tst N, #3 + ble dgemm_ncopy_L999 + + tst N, #2 + ble dgemm_ncopy_L1_BEGIN + +dgemm_ncopy_L2_M4_BEGIN: + mov A01, A00 + add A02, A01, LDA + add A00, A02, LDA + + asr I, M, #2 // I = M / 4 + cmp I, #0 + ble dgemm_ncopy_L2_M4_40 + + .align 5 +dgemm_ncopy_L2_M4_20: + + COPY4x2 + + subs I , I , #1 + bne dgemm_ncopy_L2_M4_20 + + +dgemm_ncopy_L2_M4_40: + + and I, M , #3 + cmp I, #0 + ble dgemm_ncopy_L2_M4_END + + .align 5 +dgemm_ncopy_L2_M4_60: + + COPY1x2 + + subs I , I , #1 + bne dgemm_ncopy_L2_M4_60 + + +dgemm_ncopy_L2_M4_END: + + +/*********************************************************************************************/ + +dgemm_ncopy_L1_BEGIN: + + tst N, #1 + ble dgemm_ncopy_L999 + + +dgemm_ncopy_L1_M4_BEGIN: + + mov A01, A00 + + asr I, M, #2 // I = M / 4 + cmp I, #0 + ble dgemm_ncopy_L1_M4_40 + + .align 5 +dgemm_ncopy_L1_M4_20: + + COPY4x1 + + subs I , I , #1 + bne dgemm_ncopy_L1_M4_20 + + +dgemm_ncopy_L1_M4_40: + + and I, M , #3 + cmp I, #0 + ble dgemm_ncopy_L1_M4_END + + .align 5 +dgemm_ncopy_L1_M4_60: + + COPY1x1 + + subs I , I , #1 + bne dgemm_ncopy_L1_M4_60 + + +dgemm_ncopy_L1_M4_END: + +dgemm_ncopy_L999: + + mov x0, #0 + RESTORE_REGS + ret + + EPILOGUE + diff --git a/kernel/arm64/dgemm_ncopy_8.S b/kernel/arm64/dgemm_ncopy_8.S new file mode 100644 index 0000000000..1f237b42c2 --- /dev/null +++ b/kernel/arm64/dgemm_ncopy_8.S @@ -0,0 +1,544 @@ +/*************************************************************************** +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A00 PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +#define M x0 +#define N x1 +#define A00 x2 +#define LDA x3 +#define B00 x4 + +#define A01 x5 +#define A02 x6 +#define A03 x7 +#define A04 x8 +#define A05 x9 +#define A06 x10 +#define A07 x11 +#define A08 x12 + +#define I x13 +#define J x14 + +#define TEMP1 x15 +#define TEMP2 x16 + +#define A_PREFETCH 2560 + +/************************************************************************************** +* Macro definitions +**************************************************************************************/ + +.macro SAVE_REGS + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] +.endm + +.macro RESTORE_REGS + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) +.endm + +/*************************************************************************************/ + +.macro COPY8x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + COPY4x8 + COPY4x8 +.endm + +.macro COPY4x8 + ldp q0, q1, [A01], #32 + ins v16.d[0], v0.d[0] + ins v20.d[0], v0.d[1] + ins v24.d[0], v1.d[0] + ins v28.d[0], v1.d[1] + + ldp q2, q3, [A02], #32 + ins v16.d[1], v2.d[0] + ins v20.d[1], v2.d[1] + ins v24.d[1], v3.d[0] + ins v28.d[1], v3.d[1] + + ldp q4, q5, [A03], #32 + ins v17.d[0], v4.d[0] + ins v21.d[0], v4.d[1] + ins v25.d[0], v5.d[0] + ins v29.d[0], v5.d[1] + + ldp q6, q7, [A04], #32 + ins v17.d[1], v6.d[0] + ins v21.d[1], v6.d[1] + ins v25.d[1], v7.d[0] + ins v29.d[1], v7.d[1] + + ldp q8, q9, [A05], #32 + ins v18.d[0], v8.d[0] + ins v22.d[0], v8.d[1] + ins v26.d[0], v9.d[0] + ins v30.d[0], v9.d[1] + + ldp q10, q11, [A06], #32 + ins v18.d[1], v10.d[0] + ins v22.d[1], v10.d[1] + ins v26.d[1], v11.d[0] + ins v30.d[1], v11.d[1] + + ldp q12, q13, [A07], #32 + ins v19.d[0], v12.d[0] + ins v23.d[0], v12.d[1] + ins v27.d[0], v13.d[0] + ins v31.d[0], v13.d[1] + + ldp q14, q15, [A08], #32 + ins v19.d[1], v14.d[0] + ins v23.d[1], v14.d[1] + ins v27.d[1], v15.d[0] + ins v31.d[1], v15.d[1] + + st1 {v16.2d, v17.2d, v18.2d, v19.2d}, [B00] + add B00, B00, #64 + + st1 {v20.2d, v21.2d, v22.2d, v23.2d}, [B00] + add B00, B00, #64 + + st1 {v24.2d, v25.2d, v26.2d, v27.2d}, [B00] + add B00, B00, #64 + + st1 {v28.2d, v29.2d, v30.2d, v31.2d}, [B00] + add B00, B00, #64 +.endm + +.macro COPY1x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + ldr d4, [A05], #8 + ldr d5, [A06], #8 + ldr d6, [A07], #8 + ldr d7, [A08], #8 + + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B00] + add B00, B00, #32 + st1 {v4.1d, v5.1d, v6.1d, v7.1d}, [B00] + add B00, B00, #32 + +.endm + + +/*************************************************************************************/ + +.macro COPY8x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ins v8.d[0], v0.d[0] + ins v10.d[0], v0.d[1] + ins v12.d[0], v1.d[0] + ins v14.d[0], v1.d[1] + + ldp q2, q3, [A02], #32 + ins v8.d[1], v2.d[0] + ins v10.d[1], v2.d[1] + ins v12.d[1], v3.d[0] + ins v14.d[1], v3.d[1] + + ldp q4, q5, [A03], #32 + ins v9.d[0], v4.d[0] + ins v11.d[0], v4.d[1] + ins v13.d[0], v5.d[0] + ins v15.d[0], v5.d[1] + + ldp q6, q7, [A04], #32 + ins v9.d[1], v6.d[0] + ins v11.d[1], v6.d[1] + ins v13.d[1], v7.d[0] + ins v15.d[1], v7.d[1] + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [B00] + add B00, B00, #64 + + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [B00] + add B00, B00, #64 + + ldp q16, q17, [A01], #32 + ins v24.d[0], v16.d[0] + ins v26.d[0], v16.d[1] + ins v28.d[0], v17.d[0] + ins v30.d[0], v17.d[1] + + ldp q18, q19, [A02], #32 + ins v24.d[1], v18.d[0] + ins v26.d[1], v18.d[1] + ins v28.d[1], v19.d[0] + ins v30.d[1], v19.d[1] + + ldp q20, q21, [A03], #32 + ins v25.d[0], v20.d[0] + ins v27.d[0], v20.d[1] + ins v29.d[0], v21.d[0] + ins v31.d[0], v21.d[1] + + ldp q22, q23, [A04], #32 + ins v25.d[1], v22.d[0] + ins v27.d[1], v22.d[1] + ins v29.d[1], v23.d[0] + ins v31.d[1], v23.d[1] + + st1 {v24.2d, v25.2d, v26.2d, v27.2d}, [B00] + add B00, B00, #64 + + st1 {v28.2d, v29.2d, v30.2d, v31.2d}, [B00] + add B00, B00, #64 +.endm + +.macro COPY1x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B00] + add B00, B00, #32 +.endm + +/*************************************************************************************/ + +.macro COPY8x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + + ins v8.d[0], v0.d[0] + ins v9.d[0], v0.d[1] + ins v10.d[0], v1.d[0] + ins v11.d[0], v1.d[1] + ins v12.d[0], v2.d[0] + ins v13.d[0], v2.d[1] + ins v14.d[0], v3.d[0] + ins v15.d[0], v3.d[1] + + ldp q4, q5, [A02], #32 + ldp q6, q7, [A02], #32 + + ins v8.d[1], v4.d[0] + ins v9.d[1], v4.d[1] + ins v10.d[1], v5.d[0] + ins v11.d[1], v5.d[1] + ins v12.d[1], v6.d[0] + ins v13.d[1], v6.d[1] + ins v14.d[1], v7.d[0] + ins v15.d[1], v7.d[1] + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [B00] + add B00, B00, #64 + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [B00] + add B00, B00, #64 +.endm + + +.macro COPY1x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + + stp d0, d1, [B00] + add B00, B00, #16 +.endm + +/*************************************************************************************/ + +.macro COPY8x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + stp q0, q1, [B00], #32 + stp q2, q3, [B00], #32 +.endm + + +.macro COPY1x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr d0, [A01], #8 + str d0, [B00], #8 +.endm + +/************************************************************************************** +* End of macro definitions +**************************************************************************************/ + + PROLOGUE + + .align 5 + + SAVE_REGS + + lsl LDA, LDA, #3 // LDA = LDA * SIZE + +dgemm_ncopy_L8_BEGIN: + + asr J, N, #3 // J = N / 8 + cmp J, #0 + ble dgemm_ncopy_L4_BEGIN + +dgemm_ncopy_L8_M8_BEGIN: + + mov A01, A00 + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A05, A04, LDA + add A06, A05, LDA + add A07, A06, LDA + add A08, A07, LDA + add A00, A08, LDA + + + asr I, M, #3 // I = M / 8 + cmp I, #0 + ble dgemm_ncopy_L8_M8_40 + +dgemm_ncopy_L8_M8_20: + + COPY8x8 + + subs I , I , #1 + bne dgemm_ncopy_L8_M8_20 + + +dgemm_ncopy_L8_M8_40: + + and I, M , #7 + cmp I, #0 + ble dgemm_ncopy_L8_M8_END + +dgemm_ncopy_L8_M8_60: + + COPY1x8 + + subs I , I , #1 + bne dgemm_ncopy_L8_M8_60 + + +dgemm_ncopy_L8_M8_END: + + subs J , J, #1 // j-- + bne dgemm_ncopy_L8_M8_BEGIN + +/*********************************************************************************************/ + +dgemm_ncopy_L4_BEGIN: + + tst N, #7 + ble dgemm_ncopy_L999 + + tst N, #4 + ble dgemm_ncopy_L2_BEGIN + +dgemm_ncopy_L4_M8_BEGIN: + + mov A01, A00 + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A00, A04, LDA + + asr I, M, #3 // I = M / 8 + cmp I, #0 + ble dgemm_ncopy_L4_M8_40 + +dgemm_ncopy_L4_M8_20: + + COPY8x4 + + subs I , I , #1 + bne dgemm_ncopy_L4_M8_20 + + +dgemm_ncopy_L4_M8_40: + + and I, M , #7 + cmp I, #0 + ble dgemm_ncopy_L4_M8_END + +dgemm_ncopy_L4_M8_60: + + COPY1x4 + + subs I , I , #1 + bne dgemm_ncopy_L4_M8_60 + + +dgemm_ncopy_L4_M8_END: + + +/*********************************************************************************************/ + +dgemm_ncopy_L2_BEGIN: + + tst N, #3 + ble dgemm_ncopy_L999 + + tst N, #2 + ble dgemm_ncopy_L1_BEGIN + +dgemm_ncopy_L2_M8_BEGIN: + mov A01, A00 + add A02, A01, LDA + add A00, A02, LDA + + asr I, M, #3 // I = M / 8 + cmp I, #0 + ble dgemm_ncopy_L2_M8_40 + +dgemm_ncopy_L2_M8_20: + + COPY8x2 + + subs I , I , #1 + bne dgemm_ncopy_L2_M8_20 + + +dgemm_ncopy_L2_M8_40: + + and I, M , #7 + cmp I, #0 + ble dgemm_ncopy_L2_M8_END + +dgemm_ncopy_L2_M8_60: + + COPY1x2 + + subs I , I , #1 + bne dgemm_ncopy_L2_M8_60 + + +dgemm_ncopy_L2_M8_END: + + +/*********************************************************************************************/ + +dgemm_ncopy_L1_BEGIN: + + tst N, #1 + ble dgemm_ncopy_L999 + + +dgemm_ncopy_L1_M8_BEGIN: + + mov A01, A00 + + asr I, M, #3 // I = M / 8 + cmp I, #0 + ble dgemm_ncopy_L1_M8_40 + +dgemm_ncopy_L1_M8_20: + + COPY8x1 + + subs I , I , #1 + bne dgemm_ncopy_L1_M8_20 + + +dgemm_ncopy_L1_M8_40: + + and I, M , #7 + cmp I, #0 + ble dgemm_ncopy_L1_M8_END + +dgemm_ncopy_L1_M8_60: + + COPY1x1 + + subs I , I , #1 + bne dgemm_ncopy_L1_M8_60 + + +dgemm_ncopy_L1_M8_END: + +dgemm_ncopy_L999: + + mov x0, #0 + RESTORE_REGS + ret + + EPILOGUE + diff --git a/kernel/arm64/dgemm_tcopy_4.S b/kernel/arm64/dgemm_tcopy_4.S new file mode 100644 index 0000000000..5b2ed43f1a --- /dev/null +++ b/kernel/arm64/dgemm_tcopy_4.S @@ -0,0 +1,402 @@ +/*************************************************************************** +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +#define M x0 +#define N x1 +#define A x2 +#define LDA x3 +#define B x4 + +#define M4 x5 + +#define A01 x6 +#define A02 x7 +#define A03 x8 +#define A04 x9 + +#define B01 x10 +#define B02 x11 +#define B03 x12 +#define B04 x13 + +#define I x14 +#define J x15 + +#define TEMP1 x16 +#define TEMP2 x17 + +#define A_PREFETCH 2560 +#define B_PREFETCH 256 + +/************************************************************************************** +* Macro definitions +**************************************************************************************/ +.macro SAVE_REGS + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] +.endm + +.macro RESTORE_REGS + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) +.endm + +.macro COPY4x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A02], #32 + + ////prfm PLDL1KEEP, [B01, #B_PREFETCH] + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B01] + add TEMP1, B01, #64 + + ldp q4, q5, [A03], #32 + ldp q6, q7, [A04], #32 + + ////prfm PLDL1KEEP, [B01, #B_PREFETCH] + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [TEMP1] + + add B01, B01, M4 +.endm + +.macro COPY2x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr q0, [A01], #16 + ldr q1, [A02], #16 + ldr q2, [A03], #16 + ldr q3, [A04], #16 + + ////prfm PLDL1KEEP, [B02, #B_PREFETCH] + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B02] + + add B02, B02, #64 +.endm + +.macro COPY1x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + + ////prfm PLDL1KEEP, [B03, #B_PREFETCH] + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B03] + + add B03, B03, #32 +.endm + +/*************************************************************************************************************************/ + +.macro COPY4x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A02], #32 + + ////prfm PLDL1KEEP, [B01, #B_PREFETCH] + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B01] + add B01, B01, M4 +.endm + +.macro COPY2x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr q0, [A01], #16 + ldr q1, [A02], #16 + + ////prfm PLDL1KEEP, [B02, #B_PREFETCH] + stp q0, q1, [B02] + + add B02, B02, #32 +.endm + +.macro COPY1x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + + ////prfm PLDL1KEEP, [B03, #B_PREFETCH] + stp d0, d1, [B03] + + add B03, B03, #16 +.endm + +/*************************************************************************************************************************/ + +.macro COPY4x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + + ////prfm PLDL1KEEP, [B01, #B_PREFETCH] + stp q0, q1, [B01] + + add B01, B01, M4 +.endm + +.macro COPY2x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr q0, [A01], #16 + + ////prfm PLDL1KEEP, [B02, #B_PREFETCH] + str q0, [B02] + + add B02, B02, #16 +.endm + +.macro COPY1x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr d0, [A01], #8 + + ////prfm PLDL1KEEP, [B03, #B_PREFETCH] + str d0, [B03] + + add B03, B03, #8 +.endm + + + +/************************************************************************************** +* End of macro definitions +**************************************************************************************/ + + PROLOGUE + + .align 5 + + SAVE_REGS + + lsl LDA, LDA, #3 // LDA = LDA * SIZE + + lsl TEMP1, M, #3 // x12 = M * SIZE + + and B02 , N , #-4 + and B03 , N , #-2 + + mul B02, B02, TEMP1 + mul B03, B03, TEMP1 + + add B02 , B02, B + add B03 , B03, B + + lsl M4, M, #5 // M4 = M * 4 * SIZE + +dgemm_tcopy_L4_BEGIN: + asr J, M, #2 // J = M / 4 + cmp J, #0 + ble dgemm_tcopy_L2_BEGIN + + .align 5 +dgemm_tcopy_L4_M4_BEGIN: + + mov A01, A + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A, A04, LDA + + mov B01, B + add B, B01, #128 // B = B + 16 * SIZE + + asr I, N, #2 // I = N / 4 + cmp I, #0 + ble dgemm_tcopy_L4_M4_40 + + .align 5 +dgemm_tcopy_L4_M4_20: + + COPY4x4 + + subs I , I , #1 + bne dgemm_tcopy_L4_M4_20 + + +dgemm_tcopy_L4_M4_40: + + tst N , #2 + ble dgemm_tcopy_L4_M4_60 + + COPY2x4 + + +dgemm_tcopy_L4_M4_60: + + tst N, #1 + ble dgemm_tcopy_L4_M4_END + + COPY1x4 + + +dgemm_tcopy_L4_M4_END: + + subs J , J, #1 // j-- + bne dgemm_tcopy_L4_M4_BEGIN + + + +/*********************************************************************************************/ + +dgemm_tcopy_L2_BEGIN: + + tst M, #3 + ble dgemm_tcopy_L999 + + tst M, #2 + ble dgemm_tcopy_L1_BEGIN + +dgemm_tcopy_L2_M4_BEGIN: + mov A01, A + add A02, A01, LDA + add A, A02, LDA + + mov B01, B + add B, B01, #64 // B = B + 8 * SIZE + + asr I, N, #2 // I = N / 4 + cmp I, #0 + ble dgemm_tcopy_L2_M4_40 + + .align 5 +dgemm_tcopy_L2_M4_20: + + COPY4x2 + + subs I , I , #1 + bne dgemm_tcopy_L2_M4_20 + + +dgemm_tcopy_L2_M4_40: + + tst N , #2 + ble dgemm_tcopy_L2_M4_60 + + COPY2x2 + +dgemm_tcopy_L2_M4_60: + + tst N , #1 + ble dgemm_tcopy_L2_M4_END + + COPY1x2 + + +dgemm_tcopy_L2_M4_END: + + +/*********************************************************************************************/ + +dgemm_tcopy_L1_BEGIN: + + tst M, #1 + ble dgemm_tcopy_L999 + + +dgemm_tcopy_L1_M4_BEGIN: + + mov A01, A // A01 = A + mov B01, B + + asr I, N, #2 // I = M / 4 + cmp I, #0 + ble dgemm_tcopy_L1_M4_40 + + .align 5 +dgemm_tcopy_L1_M4_20: + + COPY4x1 + + subs I , I , #1 + bne dgemm_tcopy_L1_M4_20 + + +dgemm_tcopy_L1_M4_40: + + tst N , #2 + ble dgemm_tcopy_L1_M4_60 + + COPY2x1 + +dgemm_tcopy_L1_M4_60: + + tst N , #1 + ble dgemm_tcopy_L1_M4_END + + COPY1x1 + + +dgemm_tcopy_L1_M4_END: + + +dgemm_tcopy_L999: + mov x0, #0 // set return value + RESTORE_REGS + ret + + EPILOGUE + diff --git a/kernel/arm64/dgemm_tcopy_8.S b/kernel/arm64/dgemm_tcopy_8.S new file mode 100644 index 0000000000..1c57e30e03 --- /dev/null +++ b/kernel/arm64/dgemm_tcopy_8.S @@ -0,0 +1,682 @@ +/*************************************************************************** +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +#define M x0 +#define N x1 +#define A x2 +#define LDA x3 +#define B x4 + +#define M8 x5 + +#define A01 x6 +#define A02 x7 +#define A03 x8 +#define A04 x9 +#define A05 x10 +#define A06 x11 +#define A07 x12 +#define A08 x13 + +#define B01 x14 +#define B02 x15 +#define B03 x16 +#define B04 x17 + +#define I x18 +#define J x19 + +#define TEMP1 x20 +#define TEMP2 x21 + +#define A_PREFETCH 2560 +#define B_PREFETCH 256 + +/************************************************************************************** +* Macro definitions +**************************************************************************************/ +.macro SAVE_REGS + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] +.endm + +.macro RESTORE_REGS + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) +.endm + +/*************************************************************************************************************************/ + +.macro COPY8x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B01] + add TEMP1, B01, #64 + + ldp q4, q5, [A02], #32 + ldp q6, q7, [A02], #32 + + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q8, q9, [A03], #32 + ldp q10, q11, [A03], #32 + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q12, q13, [A04], #32 + ldp q14, q15, [A04], #32 + + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q16, q17, [A05], #32 + ldp q18, q19, [A05], #32 + + st1 {v16.2d, v17.2d, v18.2d, v19.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q20, q21, [A06], #32 + ldp q22, q23, [A06], #32 + + st1 {v20.2d, v21.2d, v22.2d, v23.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q24, q25, [A07], #32 + ldp q26, q27, [A07], #32 + + st1 {v24.2d, v25.2d, v26.2d, v27.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q28, q29, [A08], #32 + ldp q30, q31, [A08], #32 + + st1 {v28.2d, v29.2d, v30.2d, v31.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + add B01, B01, M8 +.endm + +.macro COPY4x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A02], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B02] + add B02, B02, #64 + + ldp q4, q5, [A03], #32 + ldp q6, q7, [A04], #32 + + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [B02] + add B02, B02, #64 + + ldp q8, q9, [A05], #32 + ldp q10, q11, [A06], #32 + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [B02] + add B02, B02, #64 + + ldp q12, q13, [A07], #32 + ldp q14, q15, [A08], #32 + + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [B02] + add B02, B02, #64 +.endm + +.macro COPY2x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + ldr q0, [A01], #16 + ldr q1, [A02], #16 + ldr q2, [A03], #16 + ldr q3, [A04], #16 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B03] + add B03, B03, #64 + + ldr q4, [A05], #16 + ldr q5, [A06], #16 + ldr q6, [A07], #16 + ldr q7, [A08], #16 + + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [B03] + add B03, B03, #64 +.endm + +.macro COPY1x8 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + //prfm PLDL1KEEP, [A05, #A_PREFETCH] + //prfm PLDL1KEEP, [A06, #A_PREFETCH] + //prfm PLDL1KEEP, [A07, #A_PREFETCH] + //prfm PLDL1KEEP, [A08, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B04] + add B04, B04, #32 + + ldr d4, [A05], #8 + ldr d5, [A06], #8 + ldr d6, [A07], #8 + ldr d7, [A08], #8 + + st1 {v4.1d, v5.1d, v6.1d, v7.1d}, [B04] + + add B04, B04, #32 +.endm + +/*************************************************************************************************************************/ + +.macro COPY8x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B01] + add TEMP1, B01, #64 + + ldp q4, q5, [A02], #32 + ldp q6, q7, [A02], #32 + + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q8, q9, [A03], #32 + ldp q10, q11, [A03], #32 + + st1 {v8.2d, v9.2d, v10.2d, v11.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + ldp q12, q13, [A04], #32 + ldp q14, q15, [A04], #32 + + st1 {v12.2d, v13.2d, v14.2d, v15.2d}, [TEMP1] + add TEMP1, TEMP1, #64 + + add B01, B01, M8 +.endm + +.macro COPY4x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A02], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B02] + add B02, B02, #64 + + ldp q4, q5, [A03], #32 + ldp q6, q7, [A04], #32 + + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [B02] + add B02, B02, #64 +.endm + +.macro COPY2x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr q0, [A01], #16 + ldr q1, [A02], #16 + ldr q2, [A03], #16 + ldr q3, [A04], #16 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B03] + + add B03, B03, #64 +.endm + +.macro COPY1x4 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + //prfm PLDL1KEEP, [A03, #A_PREFETCH] + //prfm PLDL1KEEP, [A04, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + ldr d2, [A03], #8 + ldr d3, [A04], #8 + + st1 {v0.1d, v1.1d, v2.1d, v3.1d}, [B04] + + add B04, B04, #32 +.endm + +/*************************************************************************************************************************/ + +.macro COPY8x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + ldp q4, q5, [A02], #32 + ldp q6, q7, [A02], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B01] + add TEMP1, B01, #64 + st1 {v4.2d, v5.2d, v6.2d, v7.2d}, [TEMP1] + add B01, B01, M8 +.endm + +.macro COPY4x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A02], #32 + + st1 {v0.2d, v1.2d, v2.2d, v3.2d}, [B02] + add B02, B02, #64 +.endm + +.macro COPY2x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr q0, [A01], #16 + ldr q1, [A02], #16 + + stp q0, q1, [B03] + + add B03, B03, #32 +.endm + +.macro COPY1x2 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + //prfm PLDL1KEEP, [A02, #A_PREFETCH] + + ldr d0, [A01], #8 + ldr d1, [A02], #8 + + stp d0, d1, [B04] + + add B04, B04, #16 +.endm + +/*************************************************************************************************************************/ + +.macro COPY8x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + ldp q2, q3, [A01], #32 + + stp q0, q1, [B01] + add TEMP1, B01, #32 + stp q2, q3, [TEMP1] + add B01, B01, M8 +.endm + +.macro COPY4x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldp q0, q1, [A01], #32 + stp q0, q1, [B02] + + add B02, B02, #32 +.endm + +.macro COPY2x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr q0, [A01], #16 + str q0, [B03] + + add B03, B03, #16 +.endm + +.macro COPY1x1 + //prfm PLDL1KEEP, [A01, #A_PREFETCH] + + ldr d0, [A01], #8 + str d0, [B04] + + add B04, B04, #8 +.endm + + + +/************************************************************************************** +* End of macro definitions +**************************************************************************************/ + + PROLOGUE + + .align 5 + + SAVE_REGS + + lsl LDA, LDA, #3 // LDA = LDA * SIZE + + lsl TEMP1, M, #3 // TEMP1 = M * SIZE + + and B02 , N , #-8 + and B03 , N , #-4 + and B04 , N , #-2 + + mul B02, B02, TEMP1 + mul B03, B03, TEMP1 + mul B04, B04, TEMP1 + + add B02 , B02, B + add B03 , B03, B + add B04 , B04, B + + lsl M8, M, #6 // M8 = M * 8 * SIZE + +dgemm_tcopy_L8_BEGIN: + asr J, M, #3 // J = M / 4 + cmp J, #0 + ble dgemm_tcopy_L4_BEGIN + + .align 5 +dgemm_tcopy_L8_M8_BEGIN: + + mov A01, A + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A05, A04, LDA + add A06, A05, LDA + add A07, A06, LDA + add A08, A07, LDA + add A, A08, LDA + + mov B01, B + add B, B01, #512 // B = B + 64 * SIZE + + asr I, N, #3 // I = N / 8 + cmp I, #0 + ble dgemm_tcopy_L8_M8_40 + + .align 5 +dgemm_tcopy_L8_M8_20: + + COPY8x8 + + subs I , I , #1 + bne dgemm_tcopy_L8_M8_20 + +dgemm_tcopy_L8_M8_40: + tst N , #4 + ble dgemm_tcopy_L8_M8_60 + + COPY4x8 + +dgemm_tcopy_L8_M8_60: + + tst N , #2 + ble dgemm_tcopy_L8_M8_80 + + COPY2x8 + + +dgemm_tcopy_L8_M8_80: + + tst N, #1 + ble dgemm_tcopy_L8_M8_END + + COPY1x8 + + +dgemm_tcopy_L8_M8_END: + + subs J , J, #1 // j-- + bne dgemm_tcopy_L8_M8_BEGIN + +/*********************************************************************************************/ + +dgemm_tcopy_L4_BEGIN: + tst M, #7 + ble dgemm_tcopy_L999 + + tst M, #4 + ble dgemm_tcopy_L2_BEGIN + +dgemm_tcopy_L4_M8_BEGIN: + + mov A01, A + add A02, A01, LDA + add A03, A02, LDA + add A04, A03, LDA + add A, A04, LDA + + mov B01, B + add B, B01, #256 // B = B + 32 * SIZE + + asr I, N, #3 // I = N / 8 + cmp I, #0 + ble dgemm_tcopy_L4_M8_40 + + .align 5 +dgemm_tcopy_L4_M8_20: + + COPY8x4 + + subs I , I , #1 + bne dgemm_tcopy_L4_M8_20 + +dgemm_tcopy_L4_M8_40: + tst N , #4 + ble dgemm_tcopy_L4_M8_60 + + COPY4x4 + +dgemm_tcopy_L4_M8_60: + + tst N , #2 + ble dgemm_tcopy_L4_M8_80 + + COPY2x4 + + +dgemm_tcopy_L4_M8_80: + + tst N, #1 + ble dgemm_tcopy_L4_M8_END + + COPY1x4 + + +dgemm_tcopy_L4_M8_END: + +/*********************************************************************************************/ + +dgemm_tcopy_L2_BEGIN: + + tst M, #3 + ble dgemm_tcopy_L999 + + tst M, #2 + ble dgemm_tcopy_L1_BEGIN + +dgemm_tcopy_L2_M8_BEGIN: + mov A01, A + add A02, A01, LDA + add A, A02, LDA + + mov B01, B + add B, B01, #128 // B = B + 16 * SIZE + + asr I, N, #3 // I = N / 8 + cmp I, #0 + ble dgemm_tcopy_L2_M8_40 + + .align 5 +dgemm_tcopy_L2_M8_20: + + COPY8x2 + + subs I , I , #1 + bne dgemm_tcopy_L2_M8_20 + +dgemm_tcopy_L2_M8_40: + tst N , #4 + ble dgemm_tcopy_L2_M8_60 + + COPY4x2 + +dgemm_tcopy_L2_M8_60: + + tst N , #2 + ble dgemm_tcopy_L2_M8_80 + + COPY2x2 + +dgemm_tcopy_L2_M8_80: + + tst N , #1 + ble dgemm_tcopy_L2_M8_END + + COPY1x2 + + +dgemm_tcopy_L2_M8_END: + + +/*********************************************************************************************/ + +dgemm_tcopy_L1_BEGIN: + + tst M, #1 + ble dgemm_tcopy_L999 + + +dgemm_tcopy_L1_M8_BEGIN: + + mov A01, A // A01 = A + mov B01, B + + asr I, N, #3 // I = M / 8 + cmp I, #0 + ble dgemm_tcopy_L1_M8_40 + + .align 5 +dgemm_tcopy_L1_M8_20: + + COPY8x1 + + subs I , I , #1 + bne dgemm_tcopy_L1_M8_20 + +dgemm_tcopy_L1_M8_40: + tst N , #4 + ble dgemm_tcopy_L1_M8_60 + + COPY4x1 + +dgemm_tcopy_L1_M8_60: + + tst N , #2 + ble dgemm_tcopy_L1_M8_80 + + COPY2x1 + +dgemm_tcopy_L1_M8_80: + + tst N , #1 + ble dgemm_tcopy_L1_M8_END + + COPY1x1 + + +dgemm_tcopy_L1_M8_END: + + +dgemm_tcopy_L999: + mov x0, #0 // set return value + RESTORE_REGS + ret + + EPILOGUE + diff --git a/kernel/arm64/dot_thunderx.c b/kernel/arm64/dot_thunderx.c new file mode 100644 index 0000000000..bc07bc78f4 --- /dev/null +++ b/kernel/arm64/dot_thunderx.c @@ -0,0 +1,104 @@ +/*************************************************************************** +Copyright (c) 2014, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#if defined(DSDOT) +double CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +#else +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +#endif +{ + BLASLONG i=0; + BLASLONG ix=0,iy=0; + +#if defined(DSDOT) + double dot = 0.0 ; +#else + FLOAT dot = 0.0 ; +#endif + + if ( n < 0 ) return(dot); + + if ( (inc_x == 1) && (inc_y == 1) ) + { + + int n1 = n & -4; + + while(i < n1) + { + +#if defined(DSDOT) + dot += (double) y[i] * (double) x[i] + + (double) y[i+1] * (double) x[i+1] + + (double) y[i+2] * (double) x[i+2] + + (double) y[i+3] * (double) x[i+3] ; +#else + dot += y[i] * x[i] + + y[i+1] * x[i+1] + + y[i+2] * x[i+2] + + y[i+3] * x[i+3] ; +#endif + i+=4 ; + + } + + while(i < n) + { + +#if defined(DSDOT) + dot += (double) y[i] * (double) x[i] ; +#else + dot += y[i] * x[i] ; +#endif + i++ ; + + } + return(dot); + + + } + + while(i < n) + { + +#if defined(DSDOT) + dot += (double) y[iy] * (double) x[ix] ; +#else + dot += y[iy] * x[ix] ; +#endif + ix += inc_x ; + iy += inc_y ; + i++ ; + + } + return(dot); + +} + + diff --git a/kernel/arm64/dot_thunderx2t99.c b/kernel/arm64/dot_thunderx2t99.c new file mode 100644 index 0000000000..6d54fd805e --- /dev/null +++ b/kernel/arm64/dot_thunderx2t99.c @@ -0,0 +1,423 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#if !defined(DSDOT) +#define RETURN_TYPE FLOAT +#else +#define RETURN_TYPE double +#endif + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define Y "x3" /* "Y" vector address */ +#define INC_Y "x4" /* "Y" stride */ +#define J "x5" /* loop variable */ + +#if !defined(DOUBLE) +#if !defined(DSDOT) +#define REG0 "wzr" +#define DOTF "s0" +#define TMPX "s16" +#define TMPY "s24" +#define INC_SHIFT "2" +#define N_DIV_SHIFT "6" +#define N_REM_MASK "63" +#else +#define REG0 "xzr" +#define DOTF "d0" +#define TMPX "s16" +#define TMPX1 "d2" +#define TMPY "s24" +#define TMPY1 "d3" +#define INC_SHIFT "2" +#define N_DIV_SHIFT "4" +#define N_REM_MASK "15" +#endif +#else +#define REG0 "xzr" +#define DOTF "d0" +#define TMPX "d16" +#define TMPY "d24" +#define INC_SHIFT "3" +#define N_DIV_SHIFT "5" +#define N_REM_MASK "31" +#endif + +#if !defined(DOUBLE) + +#if !defined(DSDOT) +#define KERNEL_F1 \ + " ldr "TMPX", ["X"] \n" \ + " ldr "TMPY", ["Y"] \n" \ + " add "X", "X", "INC_X" \n" \ + " add "Y", "Y", "INC_Y" \n" \ + " fmadd "DOTF", "TMPX", "TMPY", "DOTF" \n" + +#define KERNEL_F \ + " ldp q16, q17, ["X"] \n" \ + " ldp q24, q25, ["Y"] \n" \ + " ldp q18, q19, ["X", #32] \n" \ + " ldp q26, q27, ["Y", #32] \n" \ + " fmla v0.4s, v16.4s, v24.4s \n" \ + " fmla v1.4s, v17.4s, v25.4s \n" \ + " ldp q20, q21, ["X", #64] \n" \ + " ldp q28, q29, ["Y", #64] \n" \ + " fmla v2.4s, v18.4s, v26.4s \n" \ + " fmla v3.4s, v19.4s, v27.4s \n" \ + " ldp q22, q23, ["X", #96] \n" \ + " ldp q30, q31, ["Y", #96] \n" \ + " add "Y", "Y", #128 \n" \ + " add "X", "X", #128 \n" \ + " fmla v4.4s, v20.4s, v28.4s \n" \ + " fmla v5.4s, v21.4s, v29.4s \n" \ + " PRFM PLDL1KEEP, ["X", #896] \n" \ + " PRFM PLDL1KEEP, ["Y", #896] \n" \ + " PRFM PLDL1KEEP, ["X", #896+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #896+64] \n" \ + " fmla v6.4s, v22.4s, v30.4s \n" \ + " fmla v7.4s, v23.4s, v31.4s \n" \ + " ldp q16, q17, ["X"] \n" \ + " ldp q24, q25, ["Y"] \n" \ + " ldp q18, q19, ["X", #32] \n" \ + " ldp q26, q27, ["Y", #32] \n" \ + " fmla v0.4s, v16.4s, v24.4s \n" \ + " fmla v1.4s, v17.4s, v25.4s \n" \ + " ldp q20, q21, ["X", #64] \n" \ + " ldp q28, q29, ["Y", #64] \n" \ + " fmla v2.4s, v18.4s, v26.4s \n" \ + " fmla v3.4s, v19.4s, v27.4s \n" \ + " ldp q22, q23, ["X", #96] \n" \ + " ldp q30, q31, ["Y", #96] \n" \ + " add "Y", "Y", #128 \n" \ + " add "X", "X", #128 \n" \ + " fmla v4.4s, v20.4s, v28.4s \n" \ + " fmla v5.4s, v21.4s, v29.4s \n" \ + " PRFM PLDL1KEEP, ["X", #896] \n" \ + " PRFM PLDL1KEEP, ["Y", #896] \n" \ + " PRFM PLDL1KEEP, ["X", #896+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #896+64] \n" \ + " fmla v6.4s, v22.4s, v30.4s \n" \ + " fmla v7.4s, v23.4s, v31.4s \n" + +#define KERNEL_F_FINALIZE \ + " fadd v0.4s, v0.4s, v1.4s \n" \ + " fadd v2.4s, v2.4s, v3.4s \n" \ + " fadd v4.4s, v4.4s, v5.4s \n" \ + " fadd v6.4s, v6.4s, v7.4s \n" \ + " fadd v0.4s, v0.4s, v2.4s \n" \ + " fadd v4.4s, v4.4s, v6.4s \n" \ + " fadd v0.4s, v0.4s, v4.4s \n" \ + " faddp v0.4s, v0.4s, v0.4s \n" \ + " faddp v0.4s, v0.4s, v0.4s \n" + +#else /* !defined(DSDOT) */ +#define KERNEL_F1 \ + " ldr "TMPX", ["X"] \n" \ + " ldr "TMPY", ["Y"] \n" \ + " add "X", "X", "INC_X" \n" \ + " add "Y", "Y", "INC_Y" \n" \ + " fcvt "TMPX1", "TMPX" \n" \ + " fcvt "TMPY1", "TMPY" \n" \ + " fmul "TMPX1", "TMPX1", "TMPY1" \n" \ + " fadd "DOTF", "DOTF", "TMPX1" \n" + + +#define KERNEL_F \ + " ldp q18, q19, ["X"] \n" \ + " ldp q26, q27, ["Y"] \n" \ + " fcvtl v16.2d, v18.2s \n" \ + " fcvtl2 v17.2d, v18.4s \n" \ + " fcvtl v18.2d, v19.2s \n" \ + " fcvtl2 v19.2d, v19.4s \n" \ + " fcvtl v24.2d, v26.2s \n" \ + " fcvtl2 v25.2d, v26.4s \n" \ + " fcvtl v26.2d, v27.2s \n" \ + " fcvtl2 v27.2d, v27.4s \n" \ + " ldp q22, q23, ["X", #32] \n" \ + " ldp q30, q31, ["Y", #32] \n" \ + " fcvtl v20.2d, v22.2s \n" \ + " fcvtl2 v21.2d, v22.4s \n" \ + " fcvtl v22.2d, v23.2s \n" \ + " fcvtl2 v23.2d, v23.4s \n" \ + " fcvtl v28.2d, v30.2s \n" \ + " fcvtl2 v29.2d, v30.4s \n" \ + " fcvtl v30.2d, v31.2s \n" \ + " fcvtl2 v31.2d, v31.4s \n" \ + " PRFM PLDL1KEEP, ["X", #896] \n" \ + " PRFM PLDL1KEEP, ["Y", #896] \n" \ + " PRFM PLDL1KEEP, ["X", #896+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #896+64] \n" \ + " fmla v0.2d, v16.2d, v24.2d \n" \ + " fmla v1.2d, v17.2d, v25.2d \n" \ + " fmla v2.2d, v18.2d, v26.2d \n" \ + " fmla v3.2d, v19.2d, v27.2d \n" \ + " add "Y", "Y", #64 \n" \ + " add "X", "X", #64 \n" \ + " fmla v4.2d, v20.2d, v28.2d \n" \ + " fmla v5.2d, v21.2d, v29.2d \n" \ + " fmla v6.2d, v22.2d, v30.2d \n" \ + " fmla v7.2d, v23.2d, v31.2d \n" + +#define KERNEL_F_FINALIZE \ + " fadd v0.2d, v0.2d, v1.2d \n" \ + " fadd v2.2d, v2.2d, v3.2d \n" \ + " fadd v4.2d, v4.2d, v5.2d \n" \ + " fadd v6.2d, v6.2d, v7.2d \n" \ + " fadd v0.2d, v0.2d, v2.2d \n" \ + " fadd v4.2d, v4.2d, v6.2d \n" \ + " fadd v0.2d, v0.2d, v4.2d \n" \ + " faddp "DOTF", v0.2d \n" +#endif /* !defined(DSDOT) */ + +#else /* !defined(DOUBLE) */ +#define KERNEL_F1 \ + " ldr "TMPX", ["X"] \n" \ + " ldr "TMPY", ["Y"] \n" \ + " add "X", "X", "INC_X" \n" \ + " add "Y", "Y", "INC_Y" \n" \ + " fmadd "DOTF", "TMPX", "TMPY", "DOTF" \n" + +#define KERNEL_F \ + " ldp q16, q17, ["X"] \n" \ + " ldp q24, q25, ["Y"] \n" \ + " ldp q18, q19, ["X", #32] \n" \ + " ldp q26, q27, ["Y", #32] \n" \ + " fmla v0.2d, v16.2d, v24.2d \n" \ + " fmla v1.2d, v17.2d, v25.2d \n" \ + " ldp q20, q21, ["X", #64] \n" \ + " ldp q28, q29, ["Y", #64] \n" \ + " fmla v2.2d, v18.2d, v26.2d \n" \ + " fmla v3.2d, v19.2d, v27.2d \n" \ + " ldp q22, q23, ["X", #96] \n" \ + " ldp q30, q31, ["Y", #96] \n" \ + " add "Y", "Y", #128 \n" \ + " add "X", "X", #128 \n" \ + " fmla v4.2d, v20.2d, v28.2d \n" \ + " fmla v5.2d, v21.2d, v29.2d \n" \ + " PRFM PLDL1KEEP, ["X", #896] \n" \ + " PRFM PLDL1KEEP, ["Y", #896] \n" \ + " PRFM PLDL1KEEP, ["X", #896+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #896+64] \n" \ + " fmla v6.2d, v22.2d, v30.2d \n" \ + " fmla v7.2d, v23.2d, v31.2d \n" \ + " ldp q16, q17, ["X"] \n" \ + " ldp q24, q25, ["Y"] \n" \ + " ldp q18, q19, ["X", #32] \n" \ + " ldp q26, q27, ["Y", #32] \n" \ + " fmla v0.2d, v16.2d, v24.2d \n" \ + " fmla v1.2d, v17.2d, v25.2d \n" \ + " ldp q20, q21, ["X", #64] \n" \ + " ldp q28, q29, ["Y", #64] \n" \ + " fmla v2.2d, v18.2d, v26.2d \n" \ + " fmla v3.2d, v19.2d, v27.2d \n" \ + " ldp q22, q23, ["X", #96] \n" \ + " ldp q30, q31, ["Y", #96] \n" \ + " add "Y", "Y", #128 \n" \ + " add "X", "X", #128 \n" \ + " fmla v4.2d, v20.2d, v28.2d \n" \ + " fmla v5.2d, v21.2d, v29.2d \n" \ + " PRFM PLDL1KEEP, ["X", #896] \n" \ + " PRFM PLDL1KEEP, ["Y", #896] \n" \ + " PRFM PLDL1KEEP, ["X", #896+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #896+64] \n" \ + " fmla v6.2d, v22.2d, v30.2d \n" \ + " fmla v7.2d, v23.2d, v31.2d \n" + +#define KERNEL_F_FINALIZE \ + " fadd v0.2d, v0.2d, v1.2d \n" \ + " fadd v2.2d, v2.2d, v3.2d \n" \ + " fadd v4.2d, v4.2d, v5.2d \n" \ + " fadd v6.2d, v6.2d, v7.2d \n" \ + " fadd v0.2d, v0.2d, v2.2d \n" \ + " fadd v4.2d, v4.2d, v6.2d \n" \ + " fadd v0.2d, v0.2d, v4.2d \n" \ + " faddp "DOTF", v0.2d \n" +#endif /* !defined(DOUBLE) */ + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + +static RETURN_TYPE dot_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + RETURN_TYPE dot = 0.0 ; + + if ( n < 0 ) return dot; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " mov "Y", %[Y_] \n" + " mov "INC_Y", %[INCY_] \n" + " fmov "DOTF", "REG0" \n" + " fmov d1, xzr \n" + " fmov d2, xzr \n" + " fmov d3, xzr \n" + " fmov d4, xzr \n" + " fmov d5, xzr \n" + " fmov d6, xzr \n" + " fmov d7, xzr \n" + " cmp "N", xzr \n" + " ble .Ldot_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Ldot_kernel_S_BEGIN \n" + " cmp "INC_Y", #1 \n" + " bne .Ldot_kernel_S_BEGIN \n" + + ".Ldot_kernel_F_BEGIN: \n" + " lsl "INC_X", "INC_X", "INC_SHIFT" \n" + " lsl "INC_Y", "INC_Y", "INC_SHIFT" \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Ldot_kernel_F1 \n" + + " .align 5 \n" + ".Ldot_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + + ".Ldot_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Ldot_kernel_L999 \n" + + ".Ldot_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_F10 \n" + " b .Ldot_kernel_L999 \n" + + ".Ldot_kernel_S_BEGIN: \n" + " lsl "INC_X", "INC_X", "INC_SHIFT" \n" + " lsl "INC_Y", "INC_Y", "INC_SHIFT" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Ldot_kernel_S1 \n" + + ".Ldot_kernel_S4: \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_S4 \n" + + ".Ldot_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Ldot_kernel_L999 \n" + + ".Ldot_kernel_S10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_S10 \n" + + ".Ldot_kernel_L999: \n" + " str "DOTF", [%[DOT_]] \n" + + : + : [DOT_] "r" (&dot), //%0 + [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x), //%3 + [Y_] "r" (y), //%4 + [INCY_] "r" (inc_y) //%5 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return dot; +} + +#if defined(SMP) +static int dot_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *(RETURN_TYPE *)result = dot_compute(n, x, inc_x, y, inc_y); + + return 0; +} +#endif + +RETURN_TYPE CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + RETURN_TYPE dot = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0 || inc_y == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + dot = dot_compute(n, x, inc_x, y, inc_y); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + RETURN_TYPE *ptr; + +#if !defined(DOUBLE) + mode = BLAS_SINGLE | BLAS_REAL; +#else + mode = BLAS_DOUBLE | BLAS_REAL; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, y, inc_y, result, 0, + ( void *)dot_thread_function, nthreads); + + ptr = (RETURN_TYPE *)result; + for (i = 0; i < nthreads; i++) { + dot = dot + (*ptr); + ptr = (RETURN_TYPE *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + dot = dot_compute(n, x, inc_x, y, inc_y); +#endif + + return dot; +} diff --git a/kernel/arm64/dznrm2_thunderx2t99.c b/kernel/arm64/dznrm2_thunderx2t99.c new file mode 100644 index 0000000000..a6613d7a55 --- /dev/null +++ b/kernel/arm64/dznrm2_thunderx2t99.c @@ -0,0 +1,384 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + +#define N "x0" /* vector length */ +#define X "x1" /* X vector address */ +#define INC_X "x2" /* X stride */ +#define J "x3" /* loop variable */ +#define K "x4" /* loop variable */ + +#if !defined(COMPLEX) +#define INC_SHIFT "3" +#define SZ "8" +#else +#define INC_SHIFT "4" +#define SZ "16" +#endif + +#define SSQ "d0" +#define SCALE "d1" +#define REGZERO "d5" +#define REGONE "d6" +#define CUR_MAX "d7" +#define CUR_MAXINV "d8" +#define CUR_MAXINV_V "v8.2d" +#define CUR_MAX_V "v8.2d" + +static void nrm2_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x, + double *ssq, double *scale) +{ + *ssq = 0.0; + *scale = 0.0; + + if (n <= 0) return; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SCALE", xzr \n" + " fmov "SSQ", #1.0 \n" + " cmp "N", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F_BEGIN: \n" + " fmov "REGZERO", xzr \n" + " fmov "REGONE", #1.0 \n" + " lsl "INC_X", "INC_X", #"INC_SHIFT" \n" + " mov "J", "N" \n" + " cmp "J", xzr \n" + " beq .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F_ZERO_SKIP: \n" + " ldr d4, ["X"] \n" + " fcmp d4, "REGZERO" \n" + " bne .Lnrm2_kernel_F_INIT \n" +#if defined(COMPLEX) + " ldr d4, ["X", #8] \n" + " fcmp d4, "REGZERO" \n" + " bne .Lnrm2_kernel_F_INIT_I \n" +#endif + " add "X", "X", "INC_X" \n" + " subs "J", "J", #1 \n" + " beq .Lnrm2_kernel_L999 \n" + " b .Lnrm2_kernel_F_ZERO_SKIP \n" + + ".Lnrm2_kernel_F_INIT: \n" + " ldr d4, ["X"] \n" + " fabs d4, d4 \n" + " fmax "CUR_MAX", "SCALE", d4 \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " fdiv d4, d4, "CUR_MAX" \n" + " fmul d4, d4, d4 \n" + " fadd "SSQ", "SSQ", d4 \n" + " fmov "SCALE", "CUR_MAX" \n" +#if defined(COMPLEX) + ".Lnrm2_kernel_F_INIT_I: \n" + " ldr d3, ["X", #8] \n" + " fabs d3, d3 \n" + " fmax "CUR_MAX", "SCALE", d3 \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " fdiv d3, d3, "CUR_MAX" \n" + " fmul d3, d3, d3 \n" + " fadd "SSQ", "SSQ", d3 \n" + " fmov "SCALE", "CUR_MAX" \n" +#endif + " add "X", "X", "INC_X" \n" + " subs "J", "J", #1 \n" + " beq .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F_START: \n" + " cmp "INC_X", #"SZ" \n" + " bne .Lnrm2_kernel_F1 \n" + " asr "K", "J", #4 \n" + " cmp "K", xzr \n" + " beq .Lnrm2_kernel_F1 \n" + + ".Lnrm2_kernel_F: \n" + " ldp q16, q17, ["X"] \n" + " ldp q18, q19, ["X", #32] \n" + " ldp q20, q21, ["X", #64] \n" + " ldp q22, q23, ["X", #96] \n" + " add "X", "X", #128 \n" + " fabs v16.2d, v16.2d \n" + " fabs v17.2d, v17.2d \n" + " fabs v18.2d, v18.2d \n" + " fabs v19.2d, v19.2d \n" + " fabs v20.2d, v20.2d \n" + " fabs v21.2d, v21.2d \n" + " fabs v22.2d, v22.2d \n" + " fabs v23.2d, v23.2d \n" + " fmaxp v24.2d, v16.2d, v17.2d \n" + " fmaxp v25.2d, v18.2d, v19.2d \n" + " fmaxp v26.2d, v20.2d, v21.2d \n" + " fmaxp v27.2d, v22.2d, v23.2d \n" + " fmaxp v24.2d, v24.2d, v25.2d \n" + " fmaxp v26.2d, v26.2d, v27.2d \n" + " fmaxp v24.2d, v24.2d, v26.2d \n" + " fmaxp v24.2d, v24.2d, v24.2d \n" + " fmax "CUR_MAX", "SCALE", d24 \n" + " fdiv "CUR_MAXINV", "REGONE", "CUR_MAX" \n" + " //dup "CUR_MAX_V", v7.d[0] \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " dup "CUR_MAXINV_V", v8.d[0] \n" + " fmul v16.2d, v16.2d, "CUR_MAXINV_V" \n" + " fmul v17.2d, v17.2d, "CUR_MAXINV_V" \n" + " fmul v18.2d, v18.2d, "CUR_MAXINV_V" \n" + " fmul v19.2d, v19.2d, "CUR_MAXINV_V" \n" + " fmul v20.2d, v20.2d, "CUR_MAXINV_V" \n" + " fmul v21.2d, v21.2d, "CUR_MAXINV_V" \n" + " fmul v22.2d, v22.2d, "CUR_MAXINV_V" \n" + " fmul v23.2d, v23.2d, "CUR_MAXINV_V" \n" + " //fdiv v16.2d, v16.2d, "CUR_MAX_V" \n" + " //fdiv v17.2d, v17.2d, "CUR_MAX_V" \n" + " //fdiv v18.2d, v18.2d, "CUR_MAX_V" \n" + " //fdiv v19.2d, v19.2d, "CUR_MAX_V" \n" + " //fdiv v20.2d, v20.2d, "CUR_MAX_V" \n" + " //fdiv v21.2d, v21.2d, "CUR_MAX_V" \n" + " //fdiv v22.2d, v22.2d, "CUR_MAX_V" \n" + " //fdiv v23.2d, v23.2d, "CUR_MAX_V" \n" + " fmul v24.2d, v16.2d, v16.2d \n" + " fmul v25.2d, v17.2d, v17.2d \n" + " fmul v26.2d, v18.2d, v18.2d \n" + " fmul v27.2d, v19.2d, v19.2d \n" + " fmla v24.2d, v20.2d, v20.2d \n" + " fmla v25.2d, v21.2d, v21.2d \n" + " fmla v26.2d, v22.2d, v22.2d \n" + " fmla v27.2d, v23.2d, v23.2d \n" + " fadd v24.2d, v24.2d, v25.2d \n" + " fadd v26.2d, v26.2d, v27.2d \n" + " fadd v24.2d, v24.2d, v26.2d \n" + " faddp d24, v24.2d \n" + " fadd "SSQ", "SSQ", d24 \n" + " fmov "SCALE", "CUR_MAX" \n" +#if defined(COMPLEX) + " ldp q16, q17, ["X"] \n" + " ldp q18, q19, ["X", #32] \n" + " ldp q20, q21, ["X", #64] \n" + " ldp q22, q23, ["X", #96] \n" + " add "X", "X", #128 \n" + " fabs v16.2d, v16.2d \n" + " fabs v17.2d, v17.2d \n" + " fabs v18.2d, v18.2d \n" + " fabs v19.2d, v19.2d \n" + " fabs v20.2d, v20.2d \n" + " fabs v21.2d, v21.2d \n" + " fabs v22.2d, v22.2d \n" + " fabs v23.2d, v23.2d \n" + " fmaxp v24.2d, v16.2d, v17.2d \n" + " fmaxp v25.2d, v18.2d, v19.2d \n" + " fmaxp v26.2d, v20.2d, v21.2d \n" + " fmaxp v27.2d, v22.2d, v23.2d \n" + " fmaxp v24.2d, v24.2d, v25.2d \n" + " fmaxp v26.2d, v26.2d, v27.2d \n" + " fmaxp v24.2d, v24.2d, v26.2d \n" + " fmaxp v24.2d, v24.2d, v24.2d \n" + " fmax "CUR_MAX", "SCALE", d24 \n" + " fdiv "CUR_MAXINV", "REGONE", "CUR_MAX" \n" + " //dup "CUR_MAX_V", v7.d[0] \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " dup "CUR_MAXINV_V", v8.d[0] \n" + " fmul v16.2d, v16.2d, "CUR_MAXINV_V" \n" + " fmul v17.2d, v17.2d, "CUR_MAXINV_V" \n" + " fmul v18.2d, v18.2d, "CUR_MAXINV_V" \n" + " fmul v19.2d, v19.2d, "CUR_MAXINV_V" \n" + " fmul v20.2d, v20.2d, "CUR_MAXINV_V" \n" + " fmul v21.2d, v21.2d, "CUR_MAXINV_V" \n" + " fmul v22.2d, v22.2d, "CUR_MAXINV_V" \n" + " fmul v23.2d, v23.2d, "CUR_MAXINV_V" \n" + " //fdiv v16.2d, v16.2d, "CUR_MAX_V" \n" + " //fdiv v17.2d, v17.2d, "CUR_MAX_V" \n" + " //fdiv v18.2d, v18.2d, "CUR_MAX_V" \n" + " //fdiv v19.2d, v19.2d, "CUR_MAX_V" \n" + " //fdiv v20.2d, v20.2d, "CUR_MAX_V" \n" + " //fdiv v21.2d, v21.2d, "CUR_MAX_V" \n" + " //fdiv v22.2d, v22.2d, "CUR_MAX_V" \n" + " //fdiv v23.2d, v23.2d, "CUR_MAX_V" \n" + " fmul v24.2d, v16.2d, v16.2d \n" + " fmul v25.2d, v17.2d, v17.2d \n" + " fmul v26.2d, v18.2d, v18.2d \n" + " fmul v27.2d, v19.2d, v19.2d \n" + " fmla v24.2d, v20.2d, v20.2d \n" + " fmla v25.2d, v21.2d, v21.2d \n" + " fmla v26.2d, v22.2d, v22.2d \n" + " fmla v27.2d, v23.2d, v23.2d \n" + " fadd v24.2d, v24.2d, v25.2d \n" + " fadd v26.2d, v26.2d, v27.2d \n" + " fadd v24.2d, v24.2d, v26.2d \n" + " faddp d24, v24.2d \n" + " fadd "SSQ", "SSQ", d24 \n" + " fmov "SCALE", "CUR_MAX" \n" +#endif + " subs "K", "K", #1 \n" + " bne .Lnrm2_kernel_F \n" + + ".Lnrm2_kernel_F_DONE: \n" + " ands "J", "J", #15 \n" + " beq .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F1: \n" + " ldr d4, ["X"] \n" + " fabs d4, d4 \n" + " fmax "CUR_MAX", "SCALE", d4 \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " fdiv d4, d4, "CUR_MAX" \n" + " fmul d4, d4, d4 \n" + " fadd "SSQ", "SSQ", d4 \n" + " fmov "SCALE", "CUR_MAX" \n" +#if defined(COMPLEX) + " ldr d3, ["X", #8] \n" + " fabs d3, d3 \n" + " fmax "CUR_MAX", "SCALE", d3 \n" + " fdiv "SCALE", "SCALE", "CUR_MAX" \n" + " fmul "SCALE", "SCALE", "SCALE" \n" + " fmul "SSQ", "SSQ", "SCALE" \n" + " fdiv d3, d3, "CUR_MAX" \n" + " fmul d3, d3, d3 \n" + " fadd "SSQ", "SSQ", d3 \n" + " fmov "SCALE", "CUR_MAX" \n" +#endif + " add "X", "X", "INC_X" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_F1 \n" + + ".Lnrm2_kernel_L999: \n" + " str "SSQ", [%[SSQ_]] \n" + " str "SCALE", [%[SCALE_]] \n" + + : + : [SSQ_] "r" (ssq), //%0 + [SCALE_] "r" (scale), //%1 + [N_] "r" (n), //%2 + [X_] "r" (x), //%3 + [INCX_] "r" (inc_x) //%4 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7", "d8" + ); + +} + +#if defined(SMP) +static int nrm2_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *dummy3, + BLASLONG dummy4, FLOAT *result, BLASLONG dummy5) +{ + nrm2_compute(n, x, inc_x, result, result + 1); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha[2]; +#endif + FLOAT ssq, scale; + + if (n <= 0 || inc_x <= 0) return 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + nrm2_compute(n, x, inc_x, &ssq, &scale); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + double *ptr; + +#if !defined(COMPLEX) + mode = BLAS_DOUBLE | BLAS_REAL; +#else + mode = BLAS_DOUBLE | BLAS_COMPLEX; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)nrm2_thread_function, nthreads); + + scale = 0.0; + ssq = 1.0; + ptr = (double *)result; + for (i = 0; i < nthreads; i++) { + FLOAT cur_scale, cur_ssq; + + cur_ssq = *ptr; + cur_scale = *(ptr + 1); + + if (cur_scale != 0) { + if (cur_scale > scale) { + scale = (scale / cur_scale); + ssq = ssq * scale * scale; + ssq += cur_ssq; + scale = cur_scale; + } else { + cur_scale = (cur_scale / scale); + cur_ssq = cur_ssq * cur_scale * cur_scale; + ssq += cur_ssq; + } + } + + ptr = (double *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + nrm2_compute(n, x, inc_x, &ssq, &scale); +#endif + ssq = sqrt(ssq) * scale; + + return ssq; +} diff --git a/kernel/arm64/dznrm2_thunderx2t99_fast.c b/kernel/arm64/dznrm2_thunderx2t99_fast.c new file mode 100644 index 0000000000..8b04a3eb6e --- /dev/null +++ b/kernel/arm64/dznrm2_thunderx2t99_fast.c @@ -0,0 +1,272 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + +#define N "x0" /* vector length */ +#define X "x1" /* X vector address */ +#define INC_X "x2" /* X stride */ +#define J "x5" /* loop variable */ + +#define TMPF "d16" +#define SSQ "d0" + +#if !defined(COMPLEX) +#define N_DIV_SHIFT "5" +#define N_REM_MASK "31" +#define INC_SHIFT "3" +#else +#define N_DIV_SHIFT "4" +#define N_REM_MASK "15" +#define INC_SHIFT "4" +#endif + + +#define KERNEL_F \ + "ldp q16, q17, ["X"] \n" \ + "ldp q18, q19, ["X", #32] \n" \ + "ldp q20, q21, ["X", #64] \n" \ + "ldp q22, q23, ["X", #96] \n" \ + "ldp q24, q25, ["X", #128] \n" \ + "ldp q26, q27, ["X", #160] \n" \ + "ldp q28, q29, ["X", #192] \n" \ + "ldp q30, q31, ["X", #224] \n" \ + "add "X", "X", #256 \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" \ + "fmla v1.2d, v17.2d, v17.2d \n" \ + "fmla v2.2d, v18.2d, v18.2d \n" \ + "fmla v3.2d, v19.2d, v19.2d \n" \ + "prfm PLDL1KEEP, ["X", #1024] \n" \ + "prfm PLDL1KEEP, ["X", #1024+64] \n" \ + "fmla v4.2d, v20.2d, v20.2d \n" \ + "fmla v5.2d, v21.2d, v21.2d \n" \ + "fmla v6.2d, v22.2d, v22.2d \n" \ + "fmla v7.2d, v23.2d, v23.2d \n" \ + "prfm PLDL1KEEP, ["X", #1024+128] \n" \ + "prfm PLDL1KEEP, ["X", #1024+192] \n" \ + "fmla v0.2d, v24.2d, v24.2d \n" \ + "fmla v1.2d, v25.2d, v25.2d \n" \ + "fmla v2.2d, v26.2d, v26.2d \n" \ + "fmla v3.2d, v27.2d, v27.2d \n" \ + "fmla v4.2d, v28.2d, v28.2d \n" \ + "fmla v5.2d, v29.2d, v29.2d \n" \ + "fmla v6.2d, v30.2d, v30.2d \n" \ + "fmla v7.2d, v31.2d, v31.2d \n" + + +#if !defined(COMPLEX) +#define KERNEL_F1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fmadd "SSQ", "TMPF", "TMPF", "SSQ" \n" + +#define KERNEL_F_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" \ + "faddp "SSQ", v0.2d \n" + +#define KERNEL_FINALIZE \ + "" +#else +#define KERNEL_F1 \ + "ldr q16, ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" + +#define KERNEL_F_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" + +#define KERNEL_FINALIZE \ + "faddp "SSQ", v0.2d \n" +#endif + +static double nrm2_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + double ret = 0.0 ; + + if (n <= 0) return ret; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SSQ", xzr \n" + " fmov d1, xzr \n" + " fmov d2, xzr \n" + " fmov d3, xzr \n" + " fmov d4, xzr \n" + " fmov d5, xzr \n" + " fmov d6, xzr \n" + " fmov d7, xzr \n" + " cmp "N", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lnrm2_kernel_S_BEGIN \n" + + ".Lnrm2_kernel_F_BEGIN: \n" + " lsl "INC_X", "INC_X", #"INC_SHIFT" \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Lnrm2_kernel_F1 \n" + + " .align 5 \n" + ".Lnrm2_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + + ".Lnrm2_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_F10 \n" + " b .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_S_BEGIN: \n" + " lsl "INC_X", "INC_X", #"INC_SHIFT" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lnrm2_kernel_S1 \n" + + ".Lnrm2_kernel_S4: \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_S4 \n" + + ".Lnrm2_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_S10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_S10 \n" + + ".Lnrm2_kernel_L999: \n" + " "KERNEL_FINALIZE" \n" + " str "SSQ", [%[RET_]] \n" + + : + : [RET_] "r" (&ret), //%0 + [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return ret; +} + +#if defined(SMP) +static int nrm2_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *dummy3, + BLASLONG dummy4, FLOAT *result, BLASLONG dummy5) +{ + *(double *)result = nrm2_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha[2]; +#endif + FLOAT nrm2 = 0.0; + + if (n <= 0 || inc_x <= 0) return 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + nrm2 = nrm2_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + double *ptr; + +#if !defined(COMPLEX) + mode = BLAS_DOUBLE | BLAS_REAL; +#else + mode = BLAS_DOUBLE | BLAS_COMPLEX; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)nrm2_thread_function, nthreads); + + ptr = (double *)result; + for (i = 0; i < nthreads; i++) { + nrm2 = nrm2 + (*ptr); + ptr = (double *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + nrm2 = nrm2_compute(n, x, inc_x); +#endif + nrm2 = sqrt(nrm2); + + return nrm2; +} diff --git a/kernel/arm64/iamax_thunderx2t99.c b/kernel/arm64/iamax_thunderx2t99.c new file mode 100644 index 0000000000..bc5f3c3ca2 --- /dev/null +++ b/kernel/arm64/iamax_thunderx2t99.c @@ -0,0 +1,380 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define INDEX "x3" /* index of max/min value */ +#define Z "x4" /* vector index */ +#define J "x5" /* loop variable */ + +#if !defined(DOUBLE) +#define MAXF "s0" +#define TMPF0 "s1" +#define TMPF1 "s4" +#define N_KERNEL_SIZE "64" +#define SZ "4" +#define N_DIV_SHIFT "6" +#define N_REM_MASK "63" +#define INC_SHIFT "2" +#else +#define MAXF "d0" +#define TMPF0 "d1" +#define TMPF1 "d4" +#define N_KERNEL_SIZE "32" +#define SZ "8" +#define N_DIV_SHIFT "5" +#define N_REM_MASK "31" +#define INC_SHIFT "3" +#endif + +/******************************************************************************/ + +#if !defined(DOUBLE) +#define KERNEL_F \ + "ldp q2, q3, ["X"] \n" \ + "ldp q4, q5, ["X", #32] \n" \ + "ldp q6, q7, ["X", #64] \n" \ + "ldp q16, q17, ["X", #96] \n" \ + "ldp q18, q19, ["X", #128] \n" \ + "ldp q20, q21, ["X", #160] \n" \ + "ldp q22, q23, ["X", #192] \n" \ + "ldp q24, q25, ["X", #224] \n" \ + "add "X", "X", #256 \n" \ + "fabs v2.4s, v2.4s \n" \ + "fabs v3.4s, v3.4s \n" \ + "fabs v4.4s, v4.4s \n" \ + "fabs v5.4s, v5.4s \n" \ + "fabs v6.4s, v6.4s \n" \ + "fabs v7.4s, v7.4s \n" \ + "fabs v16.4s, v16.4s \n" \ + "fabs v17.4s, v17.4s \n" \ + "fabs v18.4s, v18.4s \n" \ + "fabs v19.4s, v19.4s \n" \ + "fabs v20.4s, v20.4s \n" \ + "fabs v21.4s, v21.4s \n" \ + "fabs v22.4s, v22.4s \n" \ + "fabs v23.4s, v23.4s \n" \ + "fabs v24.4s, v24.4s \n" \ + "fabs v25.4s, v25.4s \n" \ + "fmax v2.4s, v2.4s, v3.4s \n" \ + "fmax v4.4s, v4.4s, v5.4s \n" \ + "fmax v6.4s, v6.4s, v7.4s \n" \ + "fmax v16.4s, v16.4s, v17.4s \n" \ + "fmax v18.4s, v18.4s, v19.4s \n" \ + "fmax v20.4s, v20.4s, v21.4s \n" \ + "fmax v22.4s, v22.4s, v23.4s \n" \ + "fmax v24.4s, v24.4s, v25.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fmax v2.4s, v2.4s, v4.4s \n" \ + "fmax v6.4s, v6.4s, v16.4s \n" \ + "fmax v18.4s, v18.4s, v20.4s \n" \ + "fmax v22.4s, v22.4s, v24.4s \n" \ + "fmax v2.4s, v2.4s, v6.4s \n" \ + "fmax v18.4s, v18.4s, v22.4s \n" \ + "fmax v2.4s, v2.4s, v18.4s \n" \ + "fmaxv "TMPF0", v2.4s \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" \ + "add "Z", "Z", #"N_KERNEL_SIZE" \n" + +#else + +#define KERNEL_F \ + "ldp q2, q3, ["X"] \n" \ + "ldp q4, q5, ["X", #32] \n" \ + "ldp q6, q7, ["X", #64] \n" \ + "ldp q16, q17, ["X", #96] \n" \ + "ldp q18, q19, ["X", #128] \n" \ + "ldp q20, q21, ["X", #160] \n" \ + "ldp q22, q23, ["X", #192] \n" \ + "ldp q24, q25, ["X", #224] \n" \ + "add "X", "X", #256 \n" \ + "fabs v2.2d, v2.2d \n" \ + "fabs v3.2d, v3.2d \n" \ + "fabs v4.2d, v4.2d \n" \ + "fabs v5.2d, v5.2d \n" \ + "fabs v6.2d, v6.2d \n" \ + "fabs v7.2d, v7.2d \n" \ + "fabs v16.2d, v16.2d \n" \ + "fabs v17.2d, v17.2d \n" \ + "fabs v18.2d, v18.2d \n" \ + "fabs v19.2d, v19.2d \n" \ + "fabs v20.2d, v20.2d \n" \ + "fabs v21.2d, v21.2d \n" \ + "fabs v22.2d, v22.2d \n" \ + "fabs v23.2d, v23.2d \n" \ + "fabs v24.2d, v24.2d \n" \ + "fabs v25.2d, v25.2d \n" \ + "fmax v2.2d, v2.2d, v3.2d \n" \ + "fmax v4.2d, v4.2d, v5.2d \n" \ + "fmax v6.2d, v6.2d, v7.2d \n" \ + "fmax v16.2d, v16.2d, v17.2d \n" \ + "fmax v18.2d, v18.2d, v19.2d \n" \ + "fmax v20.2d, v20.2d, v21.2d \n" \ + "fmax v22.2d, v22.2d, v23.2d \n" \ + "fmax v24.2d, v24.2d, v25.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fmax v2.2d, v2.2d, v4.2d \n" \ + "fmax v6.2d, v6.2d, v16.2d \n" \ + "fmax v18.2d, v18.2d, v20.2d \n" \ + "fmax v22.2d, v22.2d, v24.2d \n" \ + "fmax v2.2d, v2.2d, v6.2d \n" \ + "fmax v18.2d, v18.2d, v22.2d \n" \ + "fmax v2.2d, v2.2d, v18.2d \n" \ + "ins v3.d[0], v2.d[1] \n" \ + "fmax "TMPF0", d3, d2 \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" \ + "add "Z", "Z", #"N_KERNEL_SIZE" \n" +#endif + +#define KERNEL_F_FINALIZE \ + "sub x6, "INDEX", #1 \n" \ + "lsl x6, x6, #"INC_SHIFT" \n" \ + "add x7, x7, x6 \n" \ + "mov x6, #0 \n" \ + "1: \n" \ + "add x6, x6, #1 \n" \ + "cmp x6, #"N_KERNEL_SIZE" \n" \ + "bge 2f \n" \ + "ldr "TMPF1", [x7] \n" \ + "fabs "TMPF1", "TMPF1" \n" \ + "fcmp "MAXF", "TMPF1" \n" \ + "add x7, x7, #"SZ" \n" \ + "bne 1b \n" \ + "2: \n" \ + "sub x6, x6, #1 \n" \ + "add "INDEX", "INDEX", x6 \n" + + +#define INIT \ + "lsl "INC_X", "INC_X", #"INC_SHIFT" \n" \ + "ldr "MAXF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "mov "Z", #1 \n" \ + "mov "INDEX", "Z" \n" \ + "fabs "MAXF", "MAXF" \n" + + +#define KERNEL_S1 \ + "ldr "TMPF0", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "add "Z", "Z", #1 \n" \ + "fabs "TMPF0", "TMPF0" \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static BLASLONG iamax_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + BLASLONG index = 0; + + if ( n < 0 ) return index; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + + " cmp "N", xzr \n" + " ble .Liamax_kernel_zero \n" + " cmp "INC_X", xzr \n" + " ble .Liamax_kernel_zero \n" + " cmp "INC_X", #1 \n" + " bne .Liamax_kernel_S_BEGIN \n" + " mov x7, "X" \n" + + ".Liamax_kernel_F_BEGIN: \n" + " "INIT" \n" + " subs "N", "N", #1 \n" + " ble .Liamax_kernel_L999 \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Liamax_kernel_F1 \n" + " add "Z", "Z", #1 \n" + + ".Liamax_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Liamax_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + " sub "Z", "Z", #1 \n" + + ".Liamax_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Liamax_kernel_L999 \n" + + ".Liamax_kernel_F10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Liamax_kernel_F10 \n" + " b .Liamax_kernel_L999 \n" + + ".Liamax_kernel_S_BEGIN: \n" + " "INIT" \n" + " subs "N", "N", #1 \n" + " ble .Liamax_kernel_L999 \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Liamax_kernel_S1 \n" + + ".Liamax_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Liamax_kernel_S4 \n" + + ".Liamax_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Liamax_kernel_L999 \n" + + ".Liamax_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Liamax_kernel_S10 \n" + + ".Liamax_kernel_L999: \n" + " mov x0, "INDEX" \n" + " b .Liamax_kernel_DONE \n" + + ".Liamax_kernel_zero: \n" + " mov x0, xzr \n" + + ".Liamax_kernel_DONE: \n" + " mov %[INDEX_], "INDEX" \n" + + : [INDEX_] "=r" (index) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return index; +} + +#if defined(SMP) +static int iamax_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *(BLASLONG *)result = iamax_compute(n, x, inc_x); + + return 0; +} +#endif + +BLASLONG CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + BLASLONG max_index = 0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + max_index = iamax_compute(n, x, inc_x); + } else { + BLASLONG i, width, cur_index; + int num_cpu; + int mode; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT max = -1.0; + +#if !defined(DOUBLE) + mode = BLAS_SINGLE; +#else + mode = BLAS_DOUBLE; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)iamax_thread_function, nthreads); + + num_cpu = 0; + i = n; + cur_index = 0; + + while (i > 0) { + FLOAT elem; + BLASLONG cur_max_index; + + cur_max_index = *(BLASLONG *)&result[num_cpu * sizeof(double) * 2]; + elem = x[((cur_index + cur_max_index - 1) * inc_x)]; + elem = fabs(elem); + + if (elem >= max) { + max = elem; + max_index = cur_index + cur_max_index; + } + + width = blas_quickdivide(i + nthreads - num_cpu - 1, + nthreads - num_cpu); + i -= width; + cur_index += width; + num_cpu ++; + } + } +#else + max_index = iamax_compute(n, x, inc_x); +#endif + + return max_index; +} diff --git a/kernel/arm64/izamax_thunderx2t99.c b/kernel/arm64/izamax_thunderx2t99.c new file mode 100644 index 0000000000..152f936b6b --- /dev/null +++ b/kernel/arm64/izamax_thunderx2t99.c @@ -0,0 +1,390 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define INDEX "x3" /* index of max/min value */ +#define Z "x4" /* vector index */ +#define J "x5" /* loop variable */ + +#if !defined(DOUBLE) +#define MAXF "s0" +#define TMPF0 "s1" +#define TMPF0V "v1.2s" +#define TMPF1 "d4" +#define TMPF1V "v4.2s" +#define N_KERNEL_SIZE "32" +#define SZ "8" +#define N_DIV_SHIFT "5" +#define N_REM_MASK "31" +#define INC_SHIFT "3" +#else +#define MAXF "d0" +#define TMPF0 "d1" +#define TMPF0V "v1.2d" +#define TMPF1 "q4" +#define TMPF1V "v4.2d" +#define N_KERNEL_SIZE "16" +#define SZ "16" +#define N_DIV_SHIFT "4" +#define N_REM_MASK "15" +#define INC_SHIFT "4" +#endif + +/******************************************************************************/ + +#if !defined(DOUBLE) +#define KERNEL_F \ + "ldp q2, q3, ["X"] \n" \ + "ldp q4, q5, ["X", #32] \n" \ + "ldp q6, q7, ["X", #64] \n" \ + "ldp q16, q17, ["X", #96] \n" \ + "ldp q18, q19, ["X", #128] \n" \ + "ldp q20, q21, ["X", #160] \n" \ + "ldp q22, q23, ["X", #192] \n" \ + "ldp q24, q25, ["X", #224] \n" \ + "add "X", "X", #256 \n" \ + "fabs v2.4s, v2.4s \n" \ + "fabs v3.4s, v3.4s \n" \ + "fabs v4.4s, v4.4s \n" \ + "fabs v5.4s, v5.4s \n" \ + "fabs v6.4s, v6.4s \n" \ + "fabs v7.4s, v7.4s \n" \ + "fabs v16.4s, v16.4s \n" \ + "fabs v17.4s, v17.4s \n" \ + "fabs v18.4s, v18.4s \n" \ + "fabs v19.4s, v19.4s \n" \ + "fabs v20.4s, v20.4s \n" \ + "fabs v21.4s, v21.4s \n" \ + "fabs v22.4s, v22.4s \n" \ + "fabs v23.4s, v23.4s \n" \ + "fabs v24.4s, v24.4s \n" \ + "fabs v25.4s, v25.4s \n" \ + "faddp v2.4s, v2.4s, v3.4s \n" \ + "faddp v4.4s, v4.4s, v5.4s \n" \ + "faddp v6.4s, v6.4s, v7.4s \n" \ + "faddp v16.4s, v16.4s, v17.4s \n" \ + "faddp v18.4s, v18.4s, v19.4s \n" \ + "faddp v20.4s, v20.4s, v21.4s \n" \ + "faddp v22.4s, v22.4s, v23.4s \n" \ + "faddp v24.4s, v24.4s, v25.4s \n" \ + "fmax v2.4s, v2.4s, v4.4s \n" \ + "fmax v6.4s, v6.4s, v16.4s \n" \ + "fmax v18.4s, v18.4s, v20.4s \n" \ + "fmax v22.4s, v22.4s, v24.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fmax v2.4s, v2.4s, v6.4s \n" \ + "fmax v18.4s, v18.4s, v22.4s \n" \ + "fmax v2.4s, v2.4s, v18.4s \n" \ + "fmaxv "TMPF0", v2.4s \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" \ + "add "Z", "Z", #"N_KERNEL_SIZE" \n" + +#else + +#define KERNEL_F \ + "ldp q2, q3, ["X"] \n" \ + "ldp q4, q5, ["X", #32] \n" \ + "ldp q6, q7, ["X", #64] \n" \ + "ldp q16, q17, ["X", #96] \n" \ + "ldp q18, q19, ["X", #128] \n" \ + "ldp q20, q21, ["X", #160] \n" \ + "ldp q22, q23, ["X", #192] \n" \ + "ldp q24, q25, ["X", #224] \n" \ + "add "X", "X", #256 \n" \ + "fabs v2.2d, v2.2d \n" \ + "fabs v3.2d, v3.2d \n" \ + "fabs v4.2d, v4.2d \n" \ + "fabs v5.2d, v5.2d \n" \ + "fabs v6.2d, v6.2d \n" \ + "fabs v7.2d, v7.2d \n" \ + "fabs v16.2d, v16.2d \n" \ + "fabs v17.2d, v17.2d \n" \ + "fabs v18.2d, v18.2d \n" \ + "fabs v19.2d, v19.2d \n" \ + "fabs v20.2d, v20.2d \n" \ + "fabs v21.2d, v21.2d \n" \ + "fabs v22.2d, v22.2d \n" \ + "fabs v23.2d, v23.2d \n" \ + "fabs v24.2d, v24.2d \n" \ + "fabs v25.2d, v25.2d \n" \ + "faddp v2.2d, v2.2d, v3.2d \n" \ + "faddp v4.2d, v4.2d, v5.2d \n" \ + "faddp v6.2d, v6.2d, v7.2d \n" \ + "faddp v16.2d, v16.2d, v17.2d \n" \ + "faddp v18.2d, v18.2d, v19.2d \n" \ + "faddp v20.2d, v20.2d, v21.2d \n" \ + "faddp v22.2d, v22.2d, v23.2d \n" \ + "faddp v24.2d, v24.2d, v25.2d \n" \ + "fmax v2.2d, v2.2d, v4.2d \n" \ + "fmax v6.2d, v6.2d, v16.2d \n" \ + "fmax v18.2d, v18.2d, v20.2d \n" \ + "fmax v22.2d, v22.2d, v24.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fmax v2.2d, v2.2d, v6.2d \n" \ + "fmax v18.2d, v18.2d, v22.2d \n" \ + "fmax v2.2d, v2.2d, v18.2d \n" \ + "ins v3.d[0], v2.d[1] \n" \ + "fmax "TMPF0", d3, d2 \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" \ + "add "Z", "Z", #"N_KERNEL_SIZE" \n" +#endif + +#define KERNEL_F_FINALIZE \ + "sub x6, "INDEX", #1 \n" \ + "lsl x6, x6, #"INC_SHIFT" \n" \ + "add x7, x7, x6 \n" \ + "mov x6, #0 \n" \ + "1: \n" \ + "add x6, x6, #1 \n" \ + "cmp x6, #"N_KERNEL_SIZE" \n" \ + "bge 2f \n" \ + "ldr "TMPF1", [x7] \n" \ + "fabs "TMPF1V", "TMPF1V" \n" \ + "faddp "TMPF0V", "TMPF1V", "TMPF1V" \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "add x7, x7, #"SZ" \n" \ + "bne 1b \n" \ + "2: \n" \ + "sub x6, x6, #1 \n" \ + "add "INDEX", "INDEX", x6 \n" + + +#define INIT \ + "lsl "INC_X", "INC_X", #"INC_SHIFT" \n" \ + "ldr "TMPF1", ["X"] \n" \ + "fabs "TMPF1V", "TMPF1V" \n" \ + "faddp "TMPF0V", "TMPF1V", "TMPF1V" \n" \ + "fmov "MAXF" , "TMPF0" \n" \ + "add "X", "X", "INC_X" \n" \ + "mov "Z", #1 \n" \ + "mov "INDEX", "Z" \n" \ + "fabs "MAXF", "MAXF" \n" + + +#define KERNEL_S1 \ + "ldr "TMPF1", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "add "Z", "Z", #1 \n" \ + "fabs "TMPF1V", "TMPF1V" \n" \ + "faddp "TMPF0V", "TMPF1V", "TMPF1V" \n" \ + "fcmp "MAXF", "TMPF0" \n" \ + "fcsel "MAXF", "MAXF", "TMPF0", ge \n" \ + "csel "INDEX", "INDEX", "Z", ge \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static BLASLONG izamax_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + BLASLONG index = 0; + + if ( n < 0 ) return index; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + + " cmp "N", xzr \n" + " ble .Lizamax_kernel_zero \n" + " cmp "INC_X", xzr \n" + " ble .Lizamax_kernel_zero \n" + " cmp "INC_X", #1 \n" + " bne .Lizamax_kernel_S_BEGIN \n" + " mov x7, "X" \n" + + ".Lizamax_kernel_F_BEGIN: \n" + " "INIT" \n" + " subs "N", "N", #1 \n" + " ble .Lizamax_kernel_L999 \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Lizamax_kernel_F1 \n" + " add "Z", "Z", #1 \n" + + ".Lizamax_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Lizamax_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + " sub "Z", "Z", #1 \n" + + ".Lizamax_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Lizamax_kernel_L999 \n" + + ".Lizamax_kernel_F10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lizamax_kernel_F10 \n" + " b .Lizamax_kernel_L999 \n" + + ".Lizamax_kernel_S_BEGIN: \n" + " "INIT" \n" + " subs "N", "N", #1 \n" + " ble .Lizamax_kernel_L999 \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lizamax_kernel_S1 \n" + + ".Lizamax_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lizamax_kernel_S4 \n" + + ".Lizamax_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lizamax_kernel_L999 \n" + + ".Lizamax_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lizamax_kernel_S10 \n" + + ".Lizamax_kernel_L999: \n" + " mov x0, "INDEX" \n" + " b .Lizamax_kernel_DONE \n" + + ".Lizamax_kernel_zero: \n" + " mov x0, xzr \n" + + ".Lizamax_kernel_DONE: \n" + " mov %[INDEX_], "INDEX" \n" + + : [INDEX_] "=r" (index) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return index; +} + +#if defined(SMP) +static int izamax_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *(BLASLONG *)result = izamax_compute(n, x, inc_x); + + return 0; +} +#endif + +BLASLONG CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha[2]; +#endif + BLASLONG max_index = 0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + max_index = izamax_compute(n, x, inc_x); + } else { + BLASLONG i, width, cur_index; + int num_cpu; + int mode; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT max = -1.0; + +#if !defined(DOUBLE) + mode = BLAS_SINGLE | BLAS_COMPLEX; +#else + mode = BLAS_DOUBLE | BLAS_COMPLEX; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)izamax_thread_function, nthreads); + + num_cpu = 0; + i = n; + cur_index = 0; + + while (i > 0) { + FLOAT elem_r, elem_i; + BLASLONG cur_max_index; + + cur_max_index = *(BLASLONG *)&result[num_cpu * sizeof(double) * 2]; + elem_r = x[((cur_index + cur_max_index - 1) * inc_x * 2) + 0]; + elem_i = x[((cur_index + cur_max_index - 1) * inc_x * 2) + 1]; + elem_r = fabs(elem_r) + fabs(elem_i); + + if (elem_r >= max) { + max = elem_r; + max_index = cur_index + cur_max_index; + } + + width = blas_quickdivide(i + nthreads - num_cpu - 1, + nthreads - num_cpu); + i -= width; + cur_index += width; + num_cpu ++; + } + } +#else + max_index = izamax_compute(n, x, inc_x); +#endif + + return max_index; +} diff --git a/kernel/arm64/sasum_thunderx2t99.c b/kernel/arm64/sasum_thunderx2t99.c new file mode 100644 index 0000000000..767535dae2 --- /dev/null +++ b/kernel/arm64/sasum_thunderx2t99.c @@ -0,0 +1,265 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#include + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define J "x5" /* loop variable */ + +#define REG0 "wzr" +#define SUMF "s0" +#define SUMFD "d0" + +/******************************************************************************/ + +#define KERNEL_F1 \ + "ldr s1, ["X"] \n" \ + "add "X", "X", #4 \n" \ + "fabs s1, s1 \n" \ + "fadd "SUMF", "SUMF", s1 \n" + +#define KERNEL_F64 \ + "ldr q16, ["X"] \n" \ + "ldr q17, ["X", #16] \n" \ + "ldr q18, ["X", #32] \n" \ + "ldr q19, ["X", #48] \n" \ + "ldp q20, q21, ["X", #64] \n" \ + "ldp q22, q23, ["X", #96] \n" \ + "fabs v16.4s, v16.4s \n" \ + "fabs v17.4s, v17.4s \n" \ + "fabs v18.4s, v18.4s \n" \ + "fabs v19.4s, v19.4s \n" \ + "ldp q24, q25, ["X", #128] \n" \ + "ldp q26, q27, ["X", #160] \n" \ + "fabs v20.4s, v20.4s \n" \ + "fabs v21.4s, v21.4s \n" \ + "fabs v22.4s, v22.4s \n" \ + "fabs v23.4s, v23.4s \n" \ + "fadd v16.4s, v16.4s, v17.4s \n" \ + "fadd v18.4s, v18.4s, v19.4s \n" \ + "ldp q28, q29, ["X", #192] \n" \ + "ldp q30, q31, ["X", #224] \n" \ + "fabs v24.4s, v24.4s \n" \ + "fabs v25.4s, v25.4s \n" \ + "fabs v26.4s, v26.4s \n" \ + "fabs v27.4s, v27.4s \n" \ + "add "X", "X", #256 \n" \ + "fadd v20.4s, v20.4s, v21.4s \n" \ + "fadd v22.4s, v22.4s, v23.4s \n" \ + "fabs v28.4s, v28.4s \n" \ + "fabs v29.4s, v29.4s \n" \ + "fabs v30.4s, v30.4s \n" \ + "fabs v31.4s, v31.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "fadd v24.4s, v24.4s, v25.4s \n" \ + "fadd v26.4s, v26.4s, v27.4s \n" \ + "fadd v0.4s, v0.4s, v16.4s \n" \ + "fadd v1.4s, v1.4s, v18.4s \n" \ + "fadd v2.4s, v2.4s, v20.4s \n" \ + "fadd v3.4s, v3.4s, v22.4s \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fadd v28.4s, v28.4s, v29.4s \n" \ + "fadd v30.4s, v30.4s, v31.4s \n" \ + "fadd v4.4s, v4.4s, v24.4s \n" \ + "fadd v5.4s, v5.4s, v26.4s \n" \ + "fadd v6.4s, v6.4s, v28.4s \n" \ + "fadd v7.4s, v7.4s, v30.4s \n" + +#define KERNEL_F64_FINALIZE \ + "fadd v0.4s, v0.4s, v1.4s \n" \ + "fadd v2.4s, v2.4s, v3.4s \n" \ + "fadd v4.4s, v4.4s, v5.4s \n" \ + "fadd v6.4s, v6.4s, v7.4s \n" \ + "fadd v0.4s, v0.4s, v2.4s \n" \ + "fadd v4.4s, v4.4s, v6.4s \n" \ + "fadd v0.4s, v0.4s, v4.4s \n" \ + "ext v1.16b, v0.16b, v0.16b, #8 \n" \ + "fadd v0.2s, v0.2s, v1.2s \n" \ + "faddp "SUMF", v0.2s \n" + +#define INIT_S \ + "lsl "INC_X", "INC_X", #2 \n" + +#define KERNEL_S1 \ + "ldr s1, ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fabs s1, s1 \n" \ + "fadd "SUMF", "SUMF", s1 \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static FLOAT sasum_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + FLOAT asum = 0.0 ; + + if ( n < 0 ) return(asum); + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SUMF", "REG0" \n" + " fmov s1, "REG0" \n" + " fmov s2, "REG0" \n" + " fmov s3, "REG0" \n" + " fmov s4, "REG0" \n" + " fmov s5, "REG0" \n" + " fmov s6, "REG0" \n" + " fmov s7, "REG0" \n" + " cmp "N", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lasum_kernel_S_BEGIN \n" + + ".Lasum_kernel_F_BEGIN: \n" + " asr "J", "N", #6 \n" + " cmp "J", xzr \n" + " beq .Lasum_kernel_F1 \n" + + ".align 5 \n" + ".Lasum_kernel_F64: \n" + " "KERNEL_F64" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F64 \n" + " "KERNEL_F64_FINALIZE" \n" + + ".Lasum_kernel_F1: \n" + " ands "J", "N", #63 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F10 \n" + " b .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S_BEGIN: \n" + " "INIT_S" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lasum_kernel_S1 \n" + + ".Lasum_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S4 \n" + + ".Lasum_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S10 \n" + + ".Lasum_kernel_L999: \n" + " fmov %[ASUM_], "SUMFD" \n" + + : [ASUM_] "=r" (asum) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return asum; +} + +#if defined(SMP) +static int sasum_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *result = sasum_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + FLOAT asum = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + asum = sasum_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT *ptr; + + mode = BLAS_SINGLE; + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)sasum_thread_function, nthreads); + + ptr = (FLOAT *)result; + for (i = 0; i < nthreads; i++) { + asum = asum + (*ptr); + ptr = (FLOAT *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + asum = sasum_compute(n, x, inc_x); +#endif + + return asum; +} diff --git a/kernel/arm64/scnrm2_thunderx2t99.c b/kernel/arm64/scnrm2_thunderx2t99.c new file mode 100644 index 0000000000..c745dcc030 --- /dev/null +++ b/kernel/arm64/scnrm2_thunderx2t99.c @@ -0,0 +1,355 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + +#if !defined(COMPLEX) +#define N "x0" /* vector length */ +#define X "x1" /* X vector address */ +#define INC_X "x2" /* X stride */ +#define J "x5" /* loop variable */ + +#define TMPF "s16" +#define TMPFD "d17" +#define SSQD "d0" + +#define N_DIV_SHIFT "6" +#define N_REM_MASK "63" +#define INC_SHIFT "2" + +#define KERNEL_F1 \ + "ldr "TMPF", ["X"], #4 \n" \ + "fcvt "TMPFD", "TMPF" \n" \ + "fmadd "SSQD", "TMPFD", "TMPFD", "SSQD"\n" + +#define KERNEL_F \ + KERNEL_F32 \ + KERNEL_F32 + +#define KERNEL_F32 \ + "ldur q16, ["X"] \n" \ + "ldur q18, ["X", #16] \n" \ + "ldur q20, ["X", #32] \n" \ + "ldur q22, ["X", #48] \n" \ + "ldur q24, ["X", #64] \n" \ + "ldur q26, ["X", #80] \n" \ + "ldur q28, ["X", #96] \n" \ + "ldur q30, ["X", #112] \n" \ + "add "X", "X", #128 \n" \ + "fcvtl2 v17.2d, v16.4s \n" \ + "fcvtl v16.2d, v16.2s \n" \ + "fcvtl2 v19.2d, v18.4s \n" \ + "fcvtl v18.2d, v18.2s \n" \ + "fcvtl2 v21.2d, v20.4s \n" \ + "fcvtl v20.2d, v20.2s \n" \ + "fcvtl2 v23.2d, v22.4s \n" \ + "fcvtl v22.2d, v22.2s \n" \ + "fcvtl2 v25.2d, v24.4s \n" \ + "fcvtl v24.2d, v24.2s \n" \ + "fcvtl2 v27.2d, v26.4s \n" \ + "fcvtl v26.2d, v26.2s \n" \ + "fcvtl2 v29.2d, v28.4s \n" \ + "fcvtl v28.2d, v28.2s \n" \ + "fcvtl2 v31.2d, v30.4s \n" \ + "fcvtl v30.2d, v30.2s \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" \ + "fmla v1.2d, v17.2d, v17.2d \n" \ + "fmla v2.2d, v18.2d, v18.2d \n" \ + "fmla v3.2d, v19.2d, v19.2d \n" \ + "fmla v4.2d, v20.2d, v20.2d \n" \ + "fmla v5.2d, v21.2d, v21.2d \n" \ + "fmla v6.2d, v22.2d, v22.2d \n" \ + "fmla v7.2d, v23.2d, v23.2d \n" \ + "fmla v0.2d, v24.2d, v24.2d \n" \ + "fmla v1.2d, v25.2d, v25.2d \n" \ + "fmla v2.2d, v26.2d, v26.2d \n" \ + "fmla v3.2d, v27.2d, v27.2d \n" \ + "fmla v4.2d, v28.2d, v28.2d \n" \ + "fmla v5.2d, v29.2d, v29.2d \n" \ + "fmla v6.2d, v30.2d, v30.2d \n" \ + "fmla v7.2d, v31.2d, v31.2d \n" \ + "prfm PLDL1KEEP, ["X", #1024] \n" \ + "prfm PLDL1KEEP, ["X", #1024+64] \n" + +#define KERNEL_F_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" \ + "faddp "SSQD", v0.2d \n" + +#define KERNEL_S1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fcvt "TMPFD", "TMPF" \n" \ + "fmadd "SSQD", "TMPFD", "TMPFD", "SSQD"\n" + +#define KERNEL_FINALIZE \ + "" + +#else + +#define N "x0" /* vector length */ +#define X "x1" /* X vector address */ +#define INC_X "x2" /* X stride */ +#define J "x5" /* loop variable */ + +#define TMPF "d16" +#define SSQD "d0" + +#define N_DIV_SHIFT "4" +#define N_REM_MASK "15" +#define INC_SHIFT "3" + +#define KERNEL_F1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", #8 \n" \ + "fcvtl v16.2d, v16.2s \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" + +#define KERNEL_F \ + "ldur q16, ["X"] \n" \ + "ldur q18, ["X", #16] \n" \ + "ldur q20, ["X", #32] \n" \ + "ldur q22, ["X", #48] \n" \ + "ldur q24, ["X", #64] \n" \ + "ldur q26, ["X", #80] \n" \ + "ldur q28, ["X", #96] \n" \ + "ldur q30, ["X", #112] \n" \ + "add "X", "X", #128 \n" \ + "fcvtl2 v17.2d, v16.4s \n" \ + "fcvtl v16.2d, v16.2s \n" \ + "fcvtl2 v19.2d, v18.4s \n" \ + "fcvtl v18.2d, v18.2s \n" \ + "fcvtl2 v21.2d, v20.4s \n" \ + "fcvtl v20.2d, v20.2s \n" \ + "fcvtl2 v23.2d, v22.4s \n" \ + "fcvtl v22.2d, v22.2s \n" \ + "fcvtl2 v25.2d, v24.4s \n" \ + "fcvtl v24.2d, v24.2s \n" \ + "fcvtl2 v27.2d, v26.4s \n" \ + "fcvtl v26.2d, v26.2s \n" \ + "fcvtl2 v29.2d, v28.4s \n" \ + "fcvtl v28.2d, v28.2s \n" \ + "fcvtl2 v31.2d, v30.4s \n" \ + "fcvtl v30.2d, v30.2s \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" \ + "fmla v1.2d, v17.2d, v17.2d \n" \ + "fmla v2.2d, v18.2d, v18.2d \n" \ + "fmla v3.2d, v19.2d, v19.2d \n" \ + "fmla v4.2d, v20.2d, v20.2d \n" \ + "fmla v5.2d, v21.2d, v21.2d \n" \ + "fmla v6.2d, v22.2d, v22.2d \n" \ + "fmla v7.2d, v23.2d, v23.2d \n" \ + "fmla v0.2d, v24.2d, v24.2d \n" \ + "fmla v1.2d, v25.2d, v25.2d \n" \ + "fmla v2.2d, v26.2d, v26.2d \n" \ + "fmla v3.2d, v27.2d, v27.2d \n" \ + "fmla v4.2d, v28.2d, v28.2d \n" \ + "fmla v5.2d, v29.2d, v29.2d \n" \ + "fmla v6.2d, v30.2d, v30.2d \n" \ + "fmla v7.2d, v31.2d, v31.2d \n" \ + "prfm PLDL1KEEP, ["X", #1024] \n" \ + "prfm PLDL1KEEP, ["X", #1024+64] \n" + +#define KERNEL_F_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" + +#define KERNEL_FINALIZE \ + "faddp "SSQD", v0.2d \n" + +#define KERNEL_S1 \ + "ldr "TMPF", ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fcvtl v16.2d, v16.2s \n" \ + "fmla v0.2d, v16.2d, v16.2d \n" +#endif + + +static double nrm2_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + double ret = 0.0 ; + + if (n <= 0) return ret; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SSQD", xzr \n" + " fmov d1, xzr \n" + " fmov d2, xzr \n" + " fmov d3, xzr \n" + " fmov d4, xzr \n" + " fmov d5, xzr \n" + " fmov d6, xzr \n" + " fmov d7, xzr \n" + " cmp "N", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lnrm2_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lnrm2_kernel_S_BEGIN \n" + + ".Lnrm2_kernel_F_BEGIN: \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Lnrm2_kernel_S_BEGIN \n" + + " .align 5 \n" + ".Lnrm2_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + + ".Lnrm2_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_F10 \n" + " b .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_S_BEGIN: \n" + " lsl "INC_X", "INC_X", #"INC_SHIFT" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lnrm2_kernel_S1 \n" + + ".Lnrm2_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_S4 \n" + + ".Lnrm2_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lnrm2_kernel_L999 \n" + + ".Lnrm2_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lnrm2_kernel_S10 \n" + + ".Lnrm2_kernel_L999: \n" + " "KERNEL_FINALIZE" \n" + " fmov %[RET_], "SSQD" \n" + + : [RET_] "=r" (ret) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return ret; +} + +#if defined(SMP) +static int nrm2_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *dummy3, + BLASLONG dummy4, FLOAT *result, BLASLONG dummy5) +{ + *(double *)result = nrm2_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha[2]; +#endif + FLOAT nrm2 = 0.0; + double nrm2_double = 0.0; + + if (n <= 0 || inc_x <= 0) return 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + nrm2_double = nrm2_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + double *ptr; + +#if !defined(COMPLEX) + mode = BLAS_SINGLE | BLAS_REAL; +#else + mode = BLAS_SINGLE | BLAS_COMPLEX; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)nrm2_thread_function, nthreads); + + ptr = (double *)result; + for (i = 0; i < nthreads; i++) { + nrm2_double = nrm2_double + (*ptr); + ptr = (double *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + nrm2_double = nrm2_compute(n, x, inc_x); +#endif + nrm2 = sqrt(nrm2_double); + + return nrm2; +} diff --git a/kernel/arm64/sgemm_kernel_16x4_thunderx2t99.S b/kernel/arm64/sgemm_kernel_16x4_thunderx2t99.S new file mode 100644 index 0000000000..0ee10e130e --- /dev/null +++ b/kernel/arm64/sgemm_kernel_16x4_thunderx2t99.S @@ -0,0 +1,2081 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* X0 X1 X2 s0 X3 x4 x5 x6 */ +/*int CNAME(BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc) */ + +#define origM x0 +#define origN x1 +#define origK x2 +#define origPA x3 +#define origPB x4 +#define pC x5 +#define LDC x6 +#define temp x7 +#define counterL x8 +#define counterI x9 +#define counterJ x10 +#define pB x11 +#define pCRow0 x12 +#define pCRow1 x13 +#define pCRow2 x14 +#define pCRow3 x15 +#define pA x16 +#define alpha w17 + +#define alpha0 s10 +#define alphaV0 v10.s[0] + +#define A_PRE_SIZE 2560 +#define B_PRE_SIZE 224 +#define C_PRE_SIZE 160 + + +// 00 origM +// 01 origN +// 02 origK +// 03 origPA +// 04 origPB +// 05 pC +// 06 origLDC -> LDC +// 07 offset +// 08 counterL +// 09 counterI +// 10 counterJ +// 11 pB +// 12 pCRow0 +// 13 pCRow1 +// 14 pCRow2 +// 15 pA +// 16 temp +// 17 +// 18 must save +// 19 must save +// 20 must save +// 21 must save +// 22 must save +// 23 must save +// 24 must save +// 25 must save +// 26 must save +// 27 must save +// 28 must save +// 29 frame +// 30 link +// 31 sp + +//v00 ALPHA -> pA0_00, pA0_01, pA0_02, pA0_03 +//v01 pA0_04, pA0_05, pA0_06, pA0_07 +//v02 pA0_08, pA0_09, pA0_10, pA0_11 +//v03 pA0_12, pA0_13, pA0_14, pA0_15 +//v04 pA1_00, pA1_01, pA1_02, pA1_03 +//v05 pA1_04, pA1_05, pA1_06, pA1_07 +//v06 pA1_08, pA1_09, pA1_10, pA1_11 +//v07 pA1_12, pA1_13, pA1_14, pA1_15 +//v08 must save pB00 +//v09 must save pB01 +//v10 must save pB02 +//v11 must save pB03 +//v12 must save pB10 +//v13 must save pB11 +//v14 must save pB12 +//v15 must save pB13 +//v16 must save C00, C01, C02, C03 +//v17 must save C04, C05, C06, C07 +//v18 C08, C09, C10, C11 +//v19 C12, C13, C14, C15 +//v20 C16, C17, C18, C19 +//v21 C20, C21, C22, C23 +//v22 C24, C25, C26, C27 +//v23 C28, C29, C30, C31 +//v24 C32, C33, C34, C35 +//v25 C36, C37, C38, C39 +//v26 C40, C41, C42, C43 +//v27 C44, C45, C46, C47 +//v28 C48, C49, C50, C51 +//v29 C52, C53, C54, C55 +//v30 C56, C57, C58, C59 +//v31 C60, C61, C62, C63 + +/******************************************************************************* +* Macro definitions +*******************************************************************************/ + +.macro INIT16x4 + fmov s16, wzr + fmov s17, wzr + fmov s18, s16 + fmov s19, s17 + fmov s20, wzr + fmov s21, s16 + fmov s22, s17 + fmov s23, s18 + fmov s24, wzr + fmov s25, s16 + fmov s26, s17 + fmov s27, s18 + fmov s28, wzr + fmov s29, s16 + fmov s30, s17 + fmov s31, s18 +.endm + +.macro KERNEL16x4_I + ldur q0, [pA] + ldur q1, [pA, #16] + + ldur q8, [pB] + + fmul v16.4s, v0.4s, v8.s[0] + fmul v20.4s, v0.4s, v8.s[1] + + fmul v24.4s, v0.4s, v8.s[2] + fmul v28.4s, v0.4s, v8.s[3] + + ldur q2, [pA, #32] + ldur q3, [pA, #48] + + fmul v17.4s, v1.4s, v8.s[0] + fmul v21.4s, v1.4s, v8.s[1] + + ldur q4, [pA, #64] + ldur q5, [pA, #80] + + fmul v25.4s, v1.4s, v8.s[2] + fmul v29.4s, v1.4s, v8.s[3] + + ldur q12, [pB, #16] + + fmul v18.4s, v2.4s, v8.s[0] + fmul v22.4s, v2.4s, v8.s[1] + + fmul v19.4s, v3.4s, v8.s[0] + fmul v23.4s, v3.4s, v8.s[1] + + ldur q6, [pA, #96] + ldur q7, [pA, #112] + + add pB, pB, #32 + add pA, pA, #128 + + fmul v26.4s, v2.4s, v8.s[2] + fmul v30.4s, v2.4s, v8.s[3] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + fmul v27.4s, v3.4s, v8.s[2] + fmul v31.4s, v3.4s, v8.s[3] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] +.endm + +.macro KERNEL16x4_M1 + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + + ldur q4, [pA] + ldur q5, [pA, #16] + + fmla v18.4s, v2.4s, v8.s[0] + fmla v19.4s, v3.4s, v8.s[0] + + fmla v20.4s, v0.4s, v8.s[1] + fmla v21.4s, v1.4s, v8.s[1] + + ldur q12, [pB] + + fmla v22.4s, v2.4s, v8.s[1] + fmla v23.4s, v3.4s, v8.s[1] + + add pB, pB, #16 + + fmla v24.4s, v0.4s, v8.s[2] + fmla v25.4s, v1.4s, v8.s[2] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] + + fmla v26.4s, v2.4s, v8.s[2] + fmla v27.4s, v3.4s, v8.s[2] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + fmla v28.4s, v0.4s, v8.s[3] + fmla v29.4s, v1.4s, v8.s[3] + + ldur q6, [pA, #32] + ldur q7, [pA, #48] + add pA, pA, #64 + + fmla v30.4s, v2.4s, v8.s[3] + fmla v31.4s, v3.4s, v8.s[3] +.endm + +.macro KERNEL16x4_M2 + fmla v16.4s, v4.4s, v12.s[0] + fmla v17.4s, v5.4s, v12.s[0] + + ldur q0, [pA] + ldur q1, [pA, #16] + + fmla v18.4s, v6.4s, v12.s[0] + fmla v19.4s, v7.4s, v12.s[0] + + fmla v20.4s, v4.4s, v12.s[1] + fmla v21.4s, v5.4s, v12.s[1] + + ldur q8, [pB] + + fmla v22.4s, v6.4s, v12.s[1] + fmla v23.4s, v7.4s, v12.s[1] + + add pB, pB, #16 + + fmla v24.4s, v4.4s, v12.s[2] + fmla v25.4s, v5.4s, v12.s[2] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + fmla v26.4s, v6.4s, v12.s[2] + fmla v27.4s, v7.4s, v12.s[2] + + ldur q2, [pA, #32] + ldur q3, [pA, #48] + add pA, pA, #64 + + fmla v28.4s, v4.4s, v12.s[3] + fmla v29.4s, v5.4s, v12.s[3] + + fmla v30.4s, v6.4s, v12.s[3] + fmla v31.4s, v7.4s, v12.s[3] +.endm + +.macro KERNEL16x4_E + fmla v16.4s, v4.4s, v12.s[0] + fmla v20.4s, v4.4s, v12.s[1] + fmla v24.4s, v4.4s, v12.s[2] + fmla v28.4s, v4.4s, v12.s[3] + + fmla v17.4s, v5.4s, v12.s[0] + fmla v21.4s, v5.4s, v12.s[1] + fmla v25.4s, v5.4s, v12.s[2] + fmla v29.4s, v5.4s, v12.s[3] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + fmla v18.4s, v6.4s, v12.s[0] + fmla v22.4s, v6.4s, v12.s[1] + fmla v26.4s, v6.4s, v12.s[2] + fmla v30.4s, v6.4s, v12.s[3] + + fmla v19.4s, v7.4s, v12.s[0] + fmla v23.4s, v7.4s, v12.s[1] + fmla v27.4s, v7.4s, v12.s[2] + fmla v31.4s, v7.4s, v12.s[3] +.endm + +.macro KERNEL16x4_SUB + ldur q0, [pA] + ldur q1, [pA, #16] + ldur q8, [pB] + + fmla v16.4s, v0.4s, v8.s[0] + fmla v20.4s, v0.4s, v8.s[1] + + add pB, pB, #16 + + fmla v24.4s, v0.4s, v8.s[2] + fmla v28.4s, v0.4s, v8.s[3] + + ldur q2, [pA, #32] + ldur q3, [pA, #48] + add pA, pA, #64 + + fmla v17.4s, v1.4s, v8.s[0] + fmla v21.4s, v1.4s, v8.s[1] + + fmla v25.4s, v1.4s, v8.s[2] + fmla v29.4s, v1.4s, v8.s[3] + + fmla v18.4s, v2.4s, v8.s[0] + fmla v22.4s, v2.4s, v8.s[1] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + fmla v19.4s, v3.4s, v8.s[0] + fmla v23.4s, v3.4s, v8.s[1] + + fmla v26.4s, v2.4s, v8.s[2] + fmla v30.4s, v2.4s, v8.s[3] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + fmla v27.4s, v3.4s, v8.s[2] + fmla v31.4s, v3.4s, v8.s[3] +.endm + +.macro SAVE16x4 + fmov alpha0, alpha + + prfm PLDL2KEEP, [pCRow0, #C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow1, #C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow2, #C_PRE_SIZE] + prfm PLDL2KEEP, [pCRow3, #C_PRE_SIZE] + + ldur q0, [pCRow0] + ldur q1, [pCRow0, #16] + ldur q2, [pCRow0, #32] + ldur q3, [pCRow0, #48] + + ldur q4, [pCRow1] + ldur q5, [pCRow1, #16] + ldur q6, [pCRow1, #32] + ldur q7, [pCRow1, #48] + + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + stp q0, q1, [pCRow0] + + fmla v2.4s, v18.4s, alphaV0 + fmla v3.4s, v19.4s, alphaV0 + stp q2, q3, [pCRow0, #32] + ldur q0, [pCRow2] + ldur q1, [pCRow2, #16] + + + fmla v4.4s, v20.4s, alphaV0 + fmla v5.4s, v21.4s, alphaV0 + stp q4, q5, [pCRow1] + ldur q2, [pCRow2, #32] + ldur q3, [pCRow2, #48] + + fmla v6.4s, v22.4s, alphaV0 + fmla v7.4s, v23.4s, alphaV0 + stp q6, q7, [pCRow1, #32] + ldur q4, [pCRow3] + ldur q5, [pCRow3, #16] + + fmla v0.4s, v24.4s, alphaV0 + fmla v1.4s, v25.4s, alphaV0 + stp q0, q1, [pCRow2] + ldur q6, [pCRow3, #32] + ldur q7, [pCRow3, #48] + + fmla v2.4s, v26.4s, alphaV0 + fmla v3.4s, v27.4s, alphaV0 + stp q2, q3, [pCRow2, #32] + + fmla v4.4s, v28.4s, alphaV0 + fmla v5.4s, v29.4s, alphaV0 + stp q4, q5, [pCRow3] + + fmla v6.4s, v30.4s, alphaV0 + fmla v7.4s, v31.4s, alphaV0 + stp q6, q7, [pCRow3, #32] + + add pCRow0, pCRow0, #64 + add pCRow1, pCRow1, #64 + add pCRow2, pCRow2, #64 + add pCRow3, pCRow3, #64 +.endm + +/******************************************************************************/ + +.macro INIT8x4 + fmov s16, wzr + fmov s17, wzr + fmov s20, wzr + fmov s21, s16 + fmov s24, wzr + fmov s25, s16 + fmov s28, wzr + fmov s29, s16 +.endm + +.macro KERNEL8x4_I + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 + ldr q1, [pA], #16 + + fmul v16.4s, v0.4s, v8.s[0] + fmul v17.4s, v1.4s, v8.s[0] + fmul v20.4s, v0.4s, v9.s[0] + fmul v21.4s, v1.4s, v9.s[0] + fmul v24.4s, v0.4s, v10.s[0] + fmul v25.4s, v1.4s, v10.s[0] + fmul v28.4s, v0.4s, v11.s[0] + fmul v29.4s, v1.4s, v11.s[0] + + ldp s12, s13, [pB], #8 + ldp s14, s15, [pB], #8 + + ldr q4, [pA], #16 + ldr q5, [pA], #16 +.endm + +.macro KERNEL8x4_M1 + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + fmla v20.4s, v0.4s, v9.s[0] + fmla v21.4s, v1.4s, v9.s[0] + fmla v24.4s, v0.4s, v10.s[0] + fmla v25.4s, v1.4s, v10.s[0] + fmla v28.4s, v0.4s, v11.s[0] + fmla v29.4s, v1.4s, v11.s[0] + + ldp s12, s13, [pB], #8 + ldp s14, s15, [pB], #8 + + ldr q4, [pA], #16 + ldr q5, [pA], #16 +.endm + +.macro KERNEL8x4_M2 + fmla v16.4s, v4.4s, v12.s[0] + fmla v17.4s, v5.4s, v12.s[0] + fmla v20.4s, v4.4s, v13.s[0] + fmla v21.4s, v5.4s, v13.s[0] + fmla v24.4s, v4.4s, v14.s[0] + fmla v25.4s, v5.4s, v14.s[0] + fmla v28.4s, v4.4s, v15.s[0] + fmla v29.4s, v5.4s, v15.s[0] + + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 + ldr q1, [pA], #16 +.endm + +.macro KERNEL8x4_E + fmla v16.4s, v4.4s, v12.s[0] + fmla v17.4s, v5.4s, v12.s[0] + fmla v20.4s, v4.4s, v13.s[0] + fmla v21.4s, v5.4s, v13.s[0] + fmla v24.4s, v4.4s, v14.s[0] + fmla v25.4s, v5.4s, v14.s[0] + fmla v28.4s, v4.4s, v15.s[0] + fmla v29.4s, v5.4s, v15.s[0] +.endm + +.macro KERNEL8x4_SUB + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 + ldr q1, [pA], #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + fmla v20.4s, v0.4s, v9.s[0] + fmla v21.4s, v1.4s, v9.s[0] + fmla v24.4s, v0.4s, v10.s[0] + fmla v25.4s, v1.4s, v10.s[0] + fmla v28.4s, v0.4s, v11.s[0] + fmla v29.4s, v1.4s, v11.s[0] +.endm + +.macro SAVE8x4 + fmov alpha0, alpha + + ldp q0, q1, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + stp q0, q1, [pCRow0] + + add pCRow0, pCRow0, #32 + + ldp q2, q3, [pCRow1] + fmla v2.4s, v20.4s, alphaV0 + fmla v3.4s, v21.4s, alphaV0 + stp q2, q3, [pCRow1] + + add pCRow1, pCRow1, #32 + + ldp q4, q5, [pCRow2] + fmla v4.4s, v24.4s, alphaV0 + fmla v5.4s, v25.4s, alphaV0 + stp q4, q5, [pCRow2] + + add pCRow2, pCRow2, #32 + + ldp q6, q7, [pCRow3] + fmla v6.4s, v28.4s, alphaV0 + fmla v7.4s, v29.4s, alphaV0 + stp q6, q7, [pCRow3] + + add pCRow3, pCRow3, #32 +.endm + +/******************************************************************************/ + +.macro INIT4x4 + fmov s16, wzr + fmov s20, wzr + fmov s24, wzr + fmov s28, wzr +.endm + +.macro KERNEL4x4_I + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 + + fmul v16.4s, v0.4s, v8.s[0] + fmul v20.4s, v0.4s, v9.s[0] + fmul v24.4s, v0.4s, v10.s[0] + fmul v28.4s, v0.4s, v11.s[0] + + ldp s12, s13, [pB], #8 + ldp s14, s15, [pB], #8 + + ldr q1, [pA], #16 +.endm + +.macro KERNEL4x4_M1 + fmla v16.4s, v0.4s, v8.s[0] + fmla v20.4s, v0.4s, v9.s[0] + fmla v24.4s, v0.4s, v10.s[0] + fmla v28.4s, v0.4s, v11.s[0] + + ldp s12, s13, [pB], #8 + ldp s14, s15, [pB], #8 + + ldr q1, [pA], #16 +.endm + +.macro KERNEL4x4_M2 + fmla v16.4s, v1.4s, v12.s[0] + fmla v20.4s, v1.4s, v13.s[0] + fmla v24.4s, v1.4s, v14.s[0] + fmla v28.4s, v1.4s, v15.s[0] + + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 +.endm + +.macro KERNEL4x4_E + fmla v16.4s, v1.4s, v12.s[0] + fmla v20.4s, v1.4s, v13.s[0] + fmla v24.4s, v1.4s, v14.s[0] + fmla v28.4s, v1.4s, v15.s[0] +.endm + +.macro KERNEL4x4_SUB + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr q0, [pA], #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v20.4s, v0.4s, v9.s[0] + fmla v24.4s, v0.4s, v10.s[0] + fmla v28.4s, v0.4s, v11.s[0] +.endm + +.macro SAVE4x4 + fmov alpha0, alpha + + ldr q0, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + str q0, [pCRow0] + + add pCRow0, pCRow0, #16 + + ldr q1, [pCRow1] + fmla v1.4s, v20.4s, alphaV0 + str q1, [pCRow1] + + add pCRow1, pCRow1, #16 + + ldr q2, [pCRow2] + fmla v2.4s, v24.4s, alphaV0 + str q2, [pCRow2] + + add pCRow2, pCRow2, #16 + + ldr q3, [pCRow3] + fmla v3.4s, v28.4s, alphaV0 + str q3, [pCRow3] + + add pCRow3, pCRow3, #16 +.endm + +/******************************************************************************/ + +.macro INIT2x4 + fmov s16, wzr + fmov s20, s16 + fmov s24, s20 + fmov s28, s16 +.endm + +.macro KERNEL2x4_SUB + ldp s8, s9, [pB], #8 + ldp s10, s11, [pB], #8 + + ldr d0, [pA], #8 + + fmla v16.2s, v0.2s, v8.s[0] + fmla v20.2s, v0.2s, v9.s[0] + fmla v24.2s, v0.2s, v10.s[0] + fmla v28.2s, v0.2s, v11.s[0] +.endm + +.macro SAVE2x4 + fmov alpha0, alpha + + ldr d0, [pCRow0] + fmla v0.2s, v16.2s, alphaV0 + str d0, [pCRow0] + + add pCRow0, pCRow0, #8 + + ldr d1, [pCRow1] + fmla v1.2s, v20.2s, alphaV0 + str d1, [pCRow1] + + add pCRow1, pCRow1, #8 + + ldr d0, [pCRow2] + fmla v0.2s, v24.2s, alphaV0 + str d0, [pCRow2] + + add pCRow2, pCRow2, #8 + + ldr d1, [pCRow3] + fmla v1.2s, v28.2s, alphaV0 + str d1, [pCRow3] + + add pCRow3, pCRow3, #8 +.endm + +/******************************************************************************/ + +.macro INIT1x4 + fmov s16, wzr + fmov s20, s16 +.endm + +.macro KERNEL1x4_SUB + ldr s0, [pA] + add pA, pA, #4 + + ld1 {v8.2s, v9.2s}, [pB] + add pB, pB, #16 + + fmla v16.2s, v8.2s, v0.s[0] + fmla v20.2s, v9.2s, v0.s[0] +.endm + +.macro SAVE1x4 + fmov alpha0, alpha + + ld1 {v8.s}[0], [pCRow0] + ld1 {v8.s}[1], [pCRow1] + fmla v8.2s, v16.2s, alphaV0 + st1 {v8.s}[0], [pCRow0] + st1 {v8.s}[1], [pCRow1] + + add pCRow0, pCRow0, #4 + add pCRow1, pCRow1, #4 + + ld1 {v12.s}[0], [pCRow2] + ld1 {v12.s}[1], [pCRow3] + fmla v12.2s, v20.2s, alphaV0 + st1 {v12.s}[0], [pCRow2] + st1 {v12.s}[1], [pCRow3] + + add pCRow2, pCRow2, #4 + add pCRow3, pCRow3, #4 +.endm + +/******************************************************************************/ + +.macro INIT16x2 + fmov s16, wzr + fmov s17, wzr + fmov s18, wzr + fmov s19, s16 + fmov s20, wzr + fmov s21, s16 + fmov s22, wzr + fmov s23, s16 +.endm + +.macro KERNEL16x2_SUB + ld1 {v8.2s}, [pB] + add pB, pB, #8 + ld1 {v0.4s}, [pA] + add pA, pA, #16 + ld1 {v1.4s}, [pA] + add pA, pA, #16 + ld1 {v2.4s}, [pA] + add pA, pA, #16 + ld1 {v3.4s}, [pA] + add pA, pA, #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + fmla v18.4s, v2.4s, v8.s[0] + fmla v19.4s, v3.4s, v8.s[0] + + fmla v20.4s, v0.4s, v8.s[1] + fmla v21.4s, v1.4s, v8.s[1] + fmla v22.4s, v2.4s, v8.s[1] + fmla v23.4s, v3.4s, v8.s[1] +.endm + +.macro SAVE16x2 + fmov alpha0, alpha + + add pCRow1, pCRow0, LDC + + ld1 {v0.4s, v1.4s, v2.4s, v3.4s}, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + fmla v2.4s, v18.4s, alphaV0 + fmla v3.4s, v19.4s, alphaV0 + st1 {v0.4s, v1.4s, v2.4s, v3.4s}, [pCRow0] + + ld1 {v4.4s, v5.4s, v6.4s, v7.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0 + fmla v5.4s, v21.4s, alphaV0 + fmla v6.4s, v22.4s, alphaV0 + fmla v7.4s, v23.4s, alphaV0 + st1 {v4.4s, v5.4s, v6.4s, v7.4s}, [pCRow1] + + add pCRow0, pCRow0, #64 +.endm + +/******************************************************************************/ + +.macro INIT8x2 + fmov s16, wzr + fmov s17, s16 + fmov s20, s17 + fmov s21, s16 +.endm + +.macro KERNEL8x2_SUB + ld1 {v8.2s}, [pB] + add pB, pB, #8 + ld1 {v0.4s}, [pA] + add pA, pA, #16 + ld1 {v1.4s}, [pA] + add pA, pA, #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + + fmla v20.4s, v0.4s, v8.s[1] + fmla v21.4s, v1.4s, v8.s[1] +.endm + +.macro SAVE8x2 + fmov alpha0, alpha + + add pCRow1, pCRow0, LDC + + ld1 {v0.4s, v1.4s}, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + st1 {v0.4s, v1.4s}, [pCRow0] + + add pCRow2, pCRow1, LDC + + ld1 {v4.4s, v5.4s}, [pCRow1] + fmla v4.4s, v20.4s, alphaV0 + fmla v5.4s, v21.4s, alphaV0 + st1 {v4.4s, v5.4s}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT4x2 + fmov s16, wzr + fmov s17, s16 + fmov s20, s17 + fmov s21, s16 +.endm + +.macro KERNEL4x2_SUB + ld1 {v8.2s}, [pB] + add pB, pB, #8 + ld1 {v0.2s, v1.2s}, [pA] + add pA, pA, #16 + + fmla v16.2s, v0.2s, v8.s[0] + fmla v17.2s, v1.2s, v8.s[0] + fmla v20.2s, v0.2s, v8.s[1] + fmla v21.2s, v1.2s, v8.s[1] +.endm + +.macro SAVE4x2 + fmov alpha0, alpha + + ld1 {v8.2s, v9.2s}, [pCRow0] + fmla v8.2s, v16.2s, alphaV0 + fmla v9.2s, v17.2s, alphaV0 + st1 {v8.2s, v9.2s}, [pCRow0] + + add pCRow1, pCRow0, LDC + ld1 {v12.2s, v13.2s}, [pCRow1] + fmla v12.2s, v20.2s, alphaV0 + fmla v13.2s, v21.2s, alphaV0 + st1 {v12.2s, v13.2s}, [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT2x2 + fmov s16, wzr + fmov s20, s16 +.endm + +.macro KERNEL2x2_SUB + ld1 {v8.2s}, [pB] + add pB, pB, #8 + + ld1 {v0.2s}, [pA] + add pA, pA, #8 + + fmla v16.2s, v0.2s, v8.s[0] + fmla v20.2s, v0.2s, v8.s[1] +.endm + +.macro SAVE2x2 + fmov alpha0, alpha + + ld1 {v8.2s}, [pCRow0] + fmla v8.2s, v16.2s, alphaV0 + st1 {v8.2s}, [pCRow0] + + add pCRow1 , pCRow0, LDC + ld1 {v12.2s}, [pCRow1] + fmla v12.2s, v20.2s, alphaV0 + st1 {v12.2s}, [pCRow1] + + add pCRow0, pCRow0, #8 +.endm + +/******************************************************************************/ + +.macro INIT1x2 + fmov s16, wzr +.endm + +.macro KERNEL1x2_SUB + ld1 {v8.2s} , [pB] + add pB , pB, #8 + + ldr s0 , [pA] + add pA, pA, #4 + + fmla v16.2s, v8.2s, v0.s[0] +.endm + +.macro SAVE1x2 + fmov alpha0, alpha + + add pCRow1 , pCRow0, LDC + ld1 {v8.s}[0], [pCRow0] + ld1 {v8.s}[1], [pCRow1] + fmla v8.2s, v16.2s, alphaV0 + st1 {v8.s}[0], [pCRow0] + st1 {v8.s}[1], [pCRow1] + + add pCRow0, pCRow0, #4 +.endm + +/******************************************************************************/ + +.macro INIT16x1 + fmov s16, wzr + fmov s17, wzr + fmov s18, wzr + fmov s19, s16 +.endm + +.macro KERNEL16x1_SUB + ldr s8, [pB] + add pB , pB, #4 + + ld1 {v0.4s}, [pA] + add pA, pA, #16 + ld1 {v1.4s}, [pA] + add pA, pA, #16 + ld1 {v2.4s}, [pA] + add pA, pA, #16 + ld1 {v3.4s}, [pA] + add pA, pA, #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] + fmla v18.4s, v2.4s, v8.s[0] + fmla v19.4s, v3.4s, v8.s[0] +.endm + +.macro SAVE16x1 + fmov alpha0, alpha + + ld1 {v0.4s, v1.4s, v2.4s, v3.4s}, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + fmla v2.4s, v18.4s, alphaV0 + fmla v3.4s, v19.4s, alphaV0 + st1 {v0.4s, v1.4s, v2.4s, v3.4s}, [pCRow0] + + add pCRow0, pCRow0, #64 +.endm + +/******************************************************************************/ + +.macro INIT8x1 + fmov s16, wzr + fmov s17, wzr +.endm + +.macro KERNEL8x1_SUB + ldr s8, [pB] + add pB , pB, #4 + + ld1 {v0.4s}, [pA] + add pA, pA, #16 + ld1 {v1.4s}, [pA] + add pA, pA, #16 + + fmla v16.4s, v0.4s, v8.s[0] + fmla v17.4s, v1.4s, v8.s[0] +.endm + +.macro SAVE8x1 + fmov alpha0, alpha + + ld1 {v0.4s, v1.4s}, [pCRow0] + fmla v0.4s, v16.4s, alphaV0 + fmla v1.4s, v17.4s, alphaV0 + st1 {v0.4s, v1.4s}, [pCRow0] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT4x1 + fmov s16, wzr + fmov s17, s16 +.endm + +.macro KERNEL4x1_SUB + ldr s8, [pB] + add pB , pB, #4 + + ld1 {v0.2s, v1.2s}, [pA] + add pA , pA, #16 + + fmla v16.2s, v0.2s, v8.s[0] + fmla v17.2s, v1.2s, v8.s[0] +.endm + +.macro SAVE4x1 + fmov alpha0, alpha + + ld1 {v8.2s, v9.2s}, [pCRow0] + fmla v8.2s, v16.2s, alphaV0 + fmla v9.2s, v17.2s, alphaV0 + st1 {v8.2s, v9.2s}, [pCRow0] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT2x1 + fmov s16, wzr +.endm + +.macro KERNEL2x1_SUB + ldr s8, [pB] + add pB , pB, #4 + + ld1 {v0.2s}, [pA] + add pA , pA, #8 + + fmla v16.2s, v0.2s, v8.s[0] +.endm + +.macro SAVE2x1 + fmov alpha0, alpha + + ld1 {v8.2s}, [pCRow0] + fmla v8.2s, v16.2s, alphaV0 + st1 {v8.2s}, [pCRow0] + + add pCRow0, pCRow0, #8 +.endm + +/******************************************************************************/ + +.macro INIT1x1 + fmov s16, wzr +.endm + +.macro KERNEL1x1_SUB + ldr s8, [pB] + add pB , pB, #4 + + ldr s0, [pA] + add pA , pA, #4 + + fmadd s16, s0, s8, s16 +.endm + +.macro SAVE1x1 + fmov alpha0, alpha + + ldr s8, [pCRow0] + fmla s8, s16, alphaV0 + str s8, [pCRow0] + + add pCRow0, pCRow0, #4 +.endm + +.macro KERNEL16x4_M1_M2_x1 + KERNEL16x4_M1 + KERNEL16x4_M2 +.endm + +.macro KERNEL16x4_M1_M2_x2 + KERNEL16x4_M1_M2_x1 + KERNEL16x4_M1_M2_x1 +.endm + +.macro KERNEL16x4_M1_M2_x4 + KERNEL16x4_M1_M2_x2 + KERNEL16x4_M1_M2_x2 +.endm + +.macro KERNEL16x4_M1_M2_x8 + KERNEL16x4_M1_M2_x4 + KERNEL16x4_M1_M2_x4 +.endm + +.macro KERNEL16x4_M1_M2_x16 + KERNEL16x4_M1_M2_x8 + KERNEL16x4_M1_M2_x8 +.endm + +.macro KERNEL16x4_M1_M2_x32 + KERNEL16x4_M1_M2_x16 + KERNEL16x4_M1_M2_x16 +.endm + +.macro KERNEL16x4_M1_M2_x64 + KERNEL16x4_M1_M2_x32 + KERNEL16x4_M1_M2_x32 +.endm + +/******************************************************************************* +* End of macro definitions +*******************************************************************************/ + + PROLOGUE + +sgemm_kernel_begin: + + .align 5 + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] + + prfm PLDL1KEEP, [origPB] + prfm PLDL1KEEP, [origPA] + + fmov alpha, s0 + + lsl LDC, LDC, #2 // ldc = ldc * 4 + + mov pB, origPB + + mov counterJ, origN + asr counterJ, counterJ, #2 // J = J / 4 + cmp counterJ, #0 + ble sgemm_kernel_L2_BEGIN + +/******************************************************************************/ + +sgemm_kernel_L4_BEGIN: + mov pCRow0, pC + add pCRow1, pCRow0, LDC + add pCRow2, pCRow1, LDC + add pCRow3, pCRow2, LDC + + add pC, pCRow3, LDC + + mov pA, origPA // pA = start of A array + +sgemm_kernel_L4_M16_BEGIN: + + mov counterI, origM + asr counterI, counterI, #4 // counterI = counterI / 16 + cmp counterI, #0 + ble sgemm_kernel_L4_M8_BEGIN + + .align 5 +sgemm_kernel_L4_M16_20: + + mov pB, origPB + + asr counterL , origK, #4 // L = K / 16 + cmp counterL , #2 + blt sgemm_kernel_L4_M16_32 + + KERNEL16x4_I + KERNEL16x4_M2 + KERNEL16x4_M1_M2_x4 + KERNEL16x4_M1_M2_x2 + KERNEL16x4_M1_M2_x1 + + subs counterL, counterL, #2 + ble sgemm_kernel_L4_M16_22a + + .align 5 +sgemm_kernel_L4_M16_22: + + KERNEL16x4_M1_M2_x8 + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M16_22 + + .align 5 +sgemm_kernel_L4_M16_22a: + + KERNEL16x4_M1_M2_x4 + KERNEL16x4_M1_M2_x2 + KERNEL16x4_M1_M2_x1 + KERNEL16x4_M1 + KERNEL16x4_E + + b sgemm_kernel_L4_M16_44 + + .align 5 +sgemm_kernel_L4_M16_32: + + tst counterL, #1 + ble sgemm_kernel_L4_M16_40 + + KERNEL16x4_I + KERNEL16x4_M2 + KERNEL16x4_M1_M2_x4 + KERNEL16x4_M1_M2_x2 + KERNEL16x4_M1 + KERNEL16x4_E + + b sgemm_kernel_L4_M16_44 + +sgemm_kernel_L4_M16_40: + + INIT16x4 + +sgemm_kernel_L4_M16_44: + + ands counterL , origK, #15 + ble sgemm_kernel_L4_M16_100 + + .align 5 +sgemm_kernel_L4_M16_46: + + KERNEL16x4_SUB + subs counterL, counterL, #1 + bne sgemm_kernel_L4_M16_46 + +sgemm_kernel_L4_M16_100: + prfm PLDL1KEEP, [pA] + prfm PLDL1KEEP, [pA, #64] + prfm PLDL1KEEP, [origPB] + + SAVE16x4 + +sgemm_kernel_L4_M16_END: + subs counterI, counterI, #1 + bne sgemm_kernel_L4_M16_20 + +//------------------------------------------------------------------------------ + +sgemm_kernel_L4_M8_BEGIN: + + mov counterI, origM + tst counterI , #15 + ble sgemm_kernel_L4_END + + tst counterI, #8 + ble sgemm_kernel_L4_M4_BEGIN + +sgemm_kernel_L4_M8_20: + + mov pB, origPB + + asr counterL , origK, #1 // L = K / 2 + cmp counterL , #2 // is there at least 4 to do? + blt sgemm_kernel_L4_M8_32 + + KERNEL8x4_I // do one in the K + KERNEL8x4_M2 // do another in the K + + subs counterL, counterL, #2 + ble sgemm_kernel_L4_M8_22a + .align 5 + +sgemm_kernel_L4_M8_22: + + KERNEL8x4_M1 + KERNEL8x4_M2 + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M8_22 + +sgemm_kernel_L4_M8_22a: + + KERNEL8x4_M1 + KERNEL8x4_E + + b sgemm_kernel_L4_M8_44 + +sgemm_kernel_L4_M8_32: + + tst counterL, #1 + ble sgemm_kernel_L4_M8_40 + + KERNEL8x4_I + KERNEL8x4_E + + b sgemm_kernel_L4_M8_44 + +sgemm_kernel_L4_M8_40: + + INIT8x4 + +sgemm_kernel_L4_M8_44: + + ands counterL , origK, #1 + ble sgemm_kernel_L4_M8_100 + +sgemm_kernel_L4_M8_46: + + KERNEL8x4_SUB + +sgemm_kernel_L4_M8_100: + + SAVE8x4 + +sgemm_kernel_L4_M8_END: + +//------------------------------------------------------------------------------ + +sgemm_kernel_L4_M4_BEGIN: + + mov counterI, origM + tst counterI , #7 + ble sgemm_kernel_L4_END + + tst counterI, #4 + ble sgemm_kernel_L4_M2_BEGIN + +sgemm_kernel_L4_M4_20: + + mov pB, origPB + + asr counterL , origK, #1 // L = K / 2 + cmp counterL , #2 // is there at least 4 to do? + blt sgemm_kernel_L4_M4_32 + + KERNEL4x4_I // do one in the K + KERNEL4x4_M2 // do another in the K + + subs counterL, counterL, #2 + ble sgemm_kernel_L4_M4_22a + .align 5 + +sgemm_kernel_L4_M4_22: + + KERNEL4x4_M1 + KERNEL4x4_M2 + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M4_22 + +sgemm_kernel_L4_M4_22a: + + KERNEL4x4_M1 + KERNEL4x4_E + + b sgemm_kernel_L4_M4_44 + +sgemm_kernel_L4_M4_32: + + tst counterL, #1 + ble sgemm_kernel_L4_M4_40 + + KERNEL4x4_I + KERNEL4x4_E + + b sgemm_kernel_L4_M4_44 + +sgemm_kernel_L4_M4_40: + + INIT4x4 + +sgemm_kernel_L4_M4_44: + + ands counterL , origK, #1 + ble sgemm_kernel_L4_M4_100 + +sgemm_kernel_L4_M4_46: + + KERNEL4x4_SUB + +sgemm_kernel_L4_M4_100: + + SAVE4x4 + +sgemm_kernel_L4_M4_END: + +//------------------------------------------------------------------------------ + +sgemm_kernel_L4_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble sgemm_kernel_L4_END + + tst counterI, #2 // counterI = counterI / 2 + ble sgemm_kernel_L4_M1_BEGIN + +sgemm_kernel_L4_M2_20: + + INIT2x4 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L4_M2_40 + +sgemm_kernel_L4_M2_22: + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M2_22 + + +sgemm_kernel_L4_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L4_M2_100 + +sgemm_kernel_L4_M2_42: + + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M2_42 + +sgemm_kernel_L4_M2_100: + + SAVE2x4 + +sgemm_kernel_L4_M2_END: + + +sgemm_kernel_L4_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble sgemm_kernel_L4_END + +sgemm_kernel_L4_M1_20: + + INIT1x4 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L4_M1_40 + +sgemm_kernel_L4_M1_22: + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M1_22 + + +sgemm_kernel_L4_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L4_M1_100 + +sgemm_kernel_L4_M1_42: + + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L4_M1_42 + +sgemm_kernel_L4_M1_100: + + SAVE1x4 + +sgemm_kernel_L4_END: + add origPB, origPB, origK, lsl #4 // B = B + K * 4 * 4 + + subs counterJ, counterJ , #1 // j-- + bgt sgemm_kernel_L4_BEGIN + + +/******************************************************************************/ + +sgemm_kernel_L2_BEGIN: // less than 2 left in N direction + + mov counterJ , origN + tst counterJ , #3 + ble sgemm_kernel_L999 + + tst counterJ , #2 + ble sgemm_kernel_L1_BEGIN + + mov pCRow0, pC // pCRow0 = pC + + add pC,pC,LDC, lsl #1 + + mov pA, origPA // pA = A + +sgemm_kernel_L2_M16_BEGIN: + + mov counterI, origM + asr counterI, counterI, #4 // counterI = counterI / 16 + cmp counterI,#0 + ble sgemm_kernel_L2_M8_BEGIN + +sgemm_kernel_L2_M16_20: + + INIT16x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble sgemm_kernel_L2_M16_40 + .align 5 + +sgemm_kernel_L2_M16_22: + KERNEL16x2_SUB + KERNEL16x2_SUB + KERNEL16x2_SUB + KERNEL16x2_SUB + + KERNEL16x2_SUB + KERNEL16x2_SUB + KERNEL16x2_SUB + KERNEL16x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M16_22 + + +sgemm_kernel_L2_M16_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L2_M16_100 + +sgemm_kernel_L2_M16_42: + + KERNEL16x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M16_42 + +sgemm_kernel_L2_M16_100: + + SAVE16x2 + +sgemm_kernel_L2_M16_END: + + subs counterI, counterI, #1 + bgt sgemm_kernel_L2_M16_20 + +//------------------------------------------------------------------------------ + +sgemm_kernel_L2_M8_BEGIN: + mov counterI, origM + tst counterI , #15 + ble sgemm_kernel_L2_END + + tst counterI, #8 + ble sgemm_kernel_L2_M4_BEGIN + +sgemm_kernel_L2_M8_20: + + INIT8x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble sgemm_kernel_L2_M8_40 + .align 5 + +sgemm_kernel_L2_M8_22: + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M8_22 + + +sgemm_kernel_L2_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L2_M8_100 + +sgemm_kernel_L2_M8_42: + + KERNEL8x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M8_42 + +sgemm_kernel_L2_M8_100: + + SAVE8x2 + +sgemm_kernel_L2_M8_END: + +//------------------------------------------------------------------------------ + +sgemm_kernel_L2_M4_BEGIN: + mov counterI, origM + tst counterI , #7 + ble sgemm_kernel_L2_END + + tst counterI, #4 + ble sgemm_kernel_L2_M2_BEGIN + +sgemm_kernel_L2_M4_20: + + INIT4x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble sgemm_kernel_L2_M4_40 + .align 5 + +sgemm_kernel_L2_M4_22: + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M4_22 + + +sgemm_kernel_L2_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L2_M4_100 + +sgemm_kernel_L2_M4_42: + + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M4_42 + +sgemm_kernel_L2_M4_100: + + SAVE4x2 + +sgemm_kernel_L2_M4_END: + +//------------------------------------------------------------------------------ + + +sgemm_kernel_L2_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble sgemm_kernel_L2_END + + tst counterI, #2 // counterI = counterI / 2 + ble sgemm_kernel_L2_M1_BEGIN + +sgemm_kernel_L2_M2_20: + + INIT2x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble sgemm_kernel_L2_M2_40 + +sgemm_kernel_L2_M2_22: + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M2_22 + + +sgemm_kernel_L2_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L2_M2_100 + +sgemm_kernel_L2_M2_42: + + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M2_42 + +sgemm_kernel_L2_M2_100: + + SAVE2x2 + +sgemm_kernel_L2_M2_END: + + +sgemm_kernel_L2_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble sgemm_kernel_L2_END + +sgemm_kernel_L2_M1_20: + + INIT1x2 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL, #0 + ble sgemm_kernel_L2_M1_40 + +sgemm_kernel_L2_M1_22: + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M1_22 + + +sgemm_kernel_L2_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L2_M1_100 + +sgemm_kernel_L2_M1_42: + + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L2_M1_42 + +sgemm_kernel_L2_M1_100: + + SAVE1x2 + +sgemm_kernel_L2_END: + + add origPB, origPB, origK, lsl #3 // B = B + K * 2 * 4 + +/******************************************************************************/ + +sgemm_kernel_L1_BEGIN: + + mov counterJ , origN + tst counterJ , #1 + ble sgemm_kernel_L999 // done + + + mov pCRow0, pC // pCRow0 = C + add pC , pC , LDC // Update pC to point to next + + mov pA, origPA // pA = A + +sgemm_kernel_L1_M16_BEGIN: + + mov counterI, origM + asr counterI, counterI, #4 // counterI = counterI / 16 + cmp counterI, #0 + ble sgemm_kernel_L1_M8_BEGIN + +sgemm_kernel_L1_M16_20: + + INIT16x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L1_M16_40 + .align 5 + +sgemm_kernel_L1_M16_22: + KERNEL16x1_SUB + KERNEL16x1_SUB + KERNEL16x1_SUB + KERNEL16x1_SUB + + KERNEL16x1_SUB + KERNEL16x1_SUB + KERNEL16x1_SUB + KERNEL16x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M16_22 + + +sgemm_kernel_L1_M16_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L1_M16_100 + +sgemm_kernel_L1_M16_42: + + KERNEL16x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M16_42 + +sgemm_kernel_L1_M16_100: + + SAVE16x1 + +sgemm_kernel_L1_M16_END: + + subs counterI, counterI, #1 + bgt sgemm_kernel_L1_M16_20 + +//------------------------------------------------------------------------------ + +sgemm_kernel_L1_M8_BEGIN: + + mov counterI, origM + tst counterI , #15 + ble sgemm_kernel_L1_END + + tst counterI, #8 + ble sgemm_kernel_L1_M4_BEGIN + +sgemm_kernel_L1_M8_20: + + INIT8x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L1_M8_40 + .align 5 + +sgemm_kernel_L1_M8_22: + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M8_22 + + +sgemm_kernel_L1_M8_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L1_M8_100 + +sgemm_kernel_L1_M8_42: + + KERNEL8x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M8_42 + +sgemm_kernel_L1_M8_100: + + SAVE8x1 + +sgemm_kernel_L1_M8_END: + +//------------------------------------------------------------------------------ + +sgemm_kernel_L1_M4_BEGIN: + mov counterI, origM + tst counterI , #7 + ble sgemm_kernel_L1_END + + tst counterI, #4 + ble sgemm_kernel_L1_M2_BEGIN + +sgemm_kernel_L1_M4_20: + + INIT4x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L1_M4_40 + .align 5 + +sgemm_kernel_L1_M4_22: + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M4_22 + + +sgemm_kernel_L1_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L1_M4_100 + +sgemm_kernel_L1_M4_42: + + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M4_42 + +sgemm_kernel_L1_M4_100: + + SAVE4x1 + +sgemm_kernel_L1_M4_END: + +//------------------------------------------------------------------------------ + +sgemm_kernel_L1_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble sgemm_kernel_L1_END + + tst counterI, #2 // counterI = counterI / 2 + ble sgemm_kernel_L1_M1_BEGIN + +sgemm_kernel_L1_M2_20: + + INIT2x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L1_M2_40 + +sgemm_kernel_L1_M2_22: + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M2_22 + + +sgemm_kernel_L1_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L1_M2_100 + +sgemm_kernel_L1_M2_42: + + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M2_42 + +sgemm_kernel_L1_M2_100: + + SAVE2x1 + +sgemm_kernel_L1_M2_END: + + +sgemm_kernel_L1_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble sgemm_kernel_L1_END + +sgemm_kernel_L1_M1_20: + + INIT1x1 + + mov pB, origPB + + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble sgemm_kernel_L1_M1_40 + +sgemm_kernel_L1_M1_22: + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M1_22 + + +sgemm_kernel_L1_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble sgemm_kernel_L1_M1_100 + +sgemm_kernel_L1_M1_42: + + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt sgemm_kernel_L1_M1_42 + +sgemm_kernel_L1_M1_100: + + SAVE1x1 + +sgemm_kernel_L1_END: + +sgemm_kernel_L999: + mov x0, #0 // set return value + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) + ret + + EPILOGUE + diff --git a/kernel/arm64/snrm2.S b/kernel/arm64/swap_thunderx2t99.S similarity index 56% rename from kernel/arm64/snrm2.S rename to kernel/arm64/swap_thunderx2t99.S index 02c23a15fa..8b97622f2c 100644 --- a/kernel/arm64/snrm2.S +++ b/kernel/arm64/swap_thunderx2t99.S @@ -1,5 +1,5 @@ /******************************************************************************* -Copyright (c) 2015, The OpenBLAS Project +Copyright (c) 2017, The OpenBLAS Project All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are @@ -29,61 +29,74 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #define N x0 /* vector length */ -#define X x1 /* X vector address */ -#define INC_X x2 /* X stride */ -#define I x5 /* loop variable */ +#define X x3 /* X vector address */ +#define INC_X x4 /* X stride */ +#define Y x5 /* Y vector address */ +#define INC_Y x6 /* Y stride */ +#define I x1 /* loop variable */ /******************************************************************************* * Macro definitions *******************************************************************************/ -#define TMPF s6 -#define SSQ s0 -#define TMPVF {v6.s}[0] -#define SZ 4 - -/******************************************************************************/ - -.macro INIT_F1 - ldr TMPF, [X], #SZ - fmul SSQ, TMPF, TMPF -.endm +#if !defined(COMPLEX) +#if !defined(DOUBLE) +#define TMPF0 s0 +#define TMPF1 s1 +#define INC_SHIFT 2 +#define N_DIV_SHIFT 2 +#define N_REM_MASK 3 +#else +#define TMPF0 d0 +#define TMPF1 d1 +#define INC_SHIFT 3 +#define N_DIV_SHIFT 1 +#define N_REM_MASK 1 +#endif +#else +#if !defined(DOUBLE) +#define TMPF0 d0 +#define TMPF1 d1 +#define INC_SHIFT 3 +#define N_DIV_SHIFT 1 +#define N_REM_MASK 1 +#else +#define TMPF0 q0 +#define TMPF1 q1 +#define INC_SHIFT 4 +#define N_DIV_SHIFT 0 +#define N_REM_MASK 0 +#endif +#endif .macro KERNEL_F1 - ldr TMPF, [X], #SZ - fmul TMPF, TMPF, TMPF - fadd SSQ, SSQ, TMPF + ldr TMPF0, [X] + ldr TMPF1, [Y] + str TMPF0, [Y] + str TMPF1, [X] + add X, X, INC_X + add Y, Y, INC_Y .endm -.macro INIT_F4 - ld1 {v1.4s}, [X], #16 - fmul v1.4s, v1.4s, v1.4s - ext v2.16b, v1.16b, v1.16b, #8 - fadd v2.2s, v1.2s, v2.2s - faddp SSQ, v2.2s -.endm +.macro KERNEL_F + ldr q0, [X] + ldr q1, [Y] + add X, X, #16 + add Y, Y, #16 -.macro KERNEL_F4 - ld1 {v1.4s}, [X], #16 - fmul v1.4s, v1.4s, v1.4s - ext v2.16b, v1.16b, v1.16b, #8 - fadd v2.2s, v1.2s, v2.2s - faddp TMPF, v2.2s - fadd SSQ, SSQ, TMPF -.endm + prfm PLDL1STRM, [X, #1024] + prfm PLDL1STRM, [Y, #1024] -.macro INIT_S - lsl INC_X, INC_X, #2 - ld1 TMPVF, [X], INC_X - fmul SSQ, TMPF, TMPF + str q0, [Y, #-16] + str q1, [X, #-16] .endm -.macro KERNEL_S1 - ld1 TMPVF, [X], INC_X - fmul TMPF, TMPF, TMPF - fadd SSQ, SSQ, TMPF +.macro INIT + lsl INC_X, INC_X, #INC_SHIFT + lsl INC_Y, INC_Y, #INC_SHIFT .endm + /******************************************************************************* * End of macro definitions *******************************************************************************/ @@ -91,88 +104,80 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PROLOGUE cmp N, xzr - ble nrm2_kernel_zero - cmp INC_X, xzr - ble nrm2_kernel_zero + ble .Lswap_kernel_L999 + cmp INC_X, #1 - bne nrm2_kernel_S_BEGIN + bne .Lswap_kernel_S_BEGIN + cmp INC_Y, #1 + bne .Lswap_kernel_S_BEGIN -nrm2_kernel_F_BEGIN: +.Lswap_kernel_F_BEGIN: + INIT - asr I, N, #2 + asr I, N, #N_DIV_SHIFT cmp I, xzr - beq nrm2_kernel_F1_INIT + beq .Lswap_kernel_F1 - INIT_F4 - subs I, I, #1 - beq nrm2_kernel_F1 + .align 5 +.Lswap_kernel_F: -nrm2_kernel_F4: - - KERNEL_F4 + KERNEL_F subs I, I, #1 - bne nrm2_kernel_F4 + bne .Lswap_kernel_F -nrm2_kernel_F1: +.Lswap_kernel_F1: - ands I, N, #3 - ble nrm2_kernel_L999 +#if defined(DOUBLE) && defined(COMPLEX) + b .Lswap_kernel_L999 +#else + ands I, N, #N_REM_MASK + ble .Lswap_kernel_L999 +#endif -nrm2_kernel_F10: +.Lswap_kernel_F10: KERNEL_F1 subs I, I, #1 - bne nrm2_kernel_F10 + bne .Lswap_kernel_F10 - b nrm2_kernel_L999 + b .Lswap_kernel_L999 -nrm2_kernel_F1_INIT: - INIT_F1 - subs N, N, #1 - b nrm2_kernel_F1 -nrm2_kernel_S_BEGIN: +.Lswap_kernel_S_BEGIN: - INIT_S - - subs N, N, #1 - ble nrm2_kernel_L999 + INIT asr I, N, #2 cmp I, xzr - ble nrm2_kernel_S1 + ble .Lswap_kernel_S1 -nrm2_kernel_S4: +.Lswap_kernel_S4: - KERNEL_S1 - KERNEL_S1 - KERNEL_S1 - KERNEL_S1 + KERNEL_F1 + KERNEL_F1 + KERNEL_F1 + KERNEL_F1 subs I, I, #1 - bne nrm2_kernel_S4 + bne .Lswap_kernel_S4 -nrm2_kernel_S1: +.Lswap_kernel_S1: ands I, N, #3 - ble nrm2_kernel_L999 + ble .Lswap_kernel_L999 -nrm2_kernel_S10: +.Lswap_kernel_S10: - KERNEL_S1 - - subs I, I, #1 - bne nrm2_kernel_S10 + KERNEL_F1 -nrm2_kernel_L999: - fsqrt SSQ, SSQ - ret + subs I, I, #1 + bne .Lswap_kernel_S10 -nrm2_kernel_zero: - fmov SSQ, wzr +.Lswap_kernel_L999: + mov w0, wzr ret EPILOGUE diff --git a/kernel/arm64/zasum_thunderx2t99.c b/kernel/arm64/zasum_thunderx2t99.c new file mode 100644 index 0000000000..e0f4ae21a7 --- /dev/null +++ b/kernel/arm64/zasum_thunderx2t99.c @@ -0,0 +1,265 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +#include "common.h" + +#include + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define J "x5" /* loop variable */ + +#define REG0 "xzr" +#define SUMF "d0" +#define TMPF "d1" + +/******************************************************************************/ + +#define KERNEL_F1 \ + "ldr q1, ["X"] \n" \ + "add "X", "X", #16 \n" \ + "fabs v1.2d, v1.2d \n" \ + "faddp d1, v1.2d \n" \ + "fadd "SUMF", "SUMF", d1 \n" + +#define KERNEL_F16 \ + "ldr q16, ["X"] \n" \ + "ldr q17, ["X", #16] \n" \ + "ldr q18, ["X", #32] \n" \ + "ldr q19, ["X", #48] \n" \ + "ldp q20, q21, ["X", #64] \n" \ + "ldp q22, q23, ["X", #96] \n" \ + "fabs v16.2d, v16.2d \n" \ + "fabs v17.2d, v17.2d \n" \ + "fabs v18.2d, v18.2d \n" \ + "fabs v19.2d, v19.2d \n" \ + "ldp q24, q25, ["X", #128] \n" \ + "ldp q26, q27, ["X", #160] \n" \ + "fabs v20.2d, v20.2d \n" \ + "fabs v21.2d, v21.2d \n" \ + "fabs v22.2d, v22.2d \n" \ + "fabs v23.2d, v23.2d \n" \ + "fadd v16.2d, v16.2d, v17.2d \n" \ + "fadd v18.2d, v18.2d, v19.2d \n" \ + "ldp q28, q29, ["X", #192] \n" \ + "ldp q30, q31, ["X", #224] \n" \ + "fabs v24.2d, v24.2d \n" \ + "fabs v25.2d, v25.2d \n" \ + "fabs v26.2d, v26.2d \n" \ + "fabs v27.2d, v27.2d \n" \ + "add "X", "X", #256 \n" \ + "fadd v20.2d, v20.2d, v21.2d \n" \ + "fadd v22.2d, v22.2d, v23.2d \n" \ + "fabs v28.2d, v28.2d \n" \ + "fabs v29.2d, v29.2d \n" \ + "fabs v30.2d, v30.2d \n" \ + "fabs v31.2d, v31.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + "fadd v24.2d, v24.2d, v25.2d \n" \ + "fadd v26.2d, v26.2d, v27.2d \n" \ + "fadd v28.2d, v28.2d, v29.2d \n" \ + "fadd v30.2d, v30.2d, v31.2d \n" \ + "fadd v0.2d, v0.2d, v16.2d \n" \ + "fadd v1.2d, v1.2d, v18.2d \n" \ + "fadd v2.2d, v2.2d, v20.2d \n" \ + "fadd v3.2d, v3.2d, v22.2d \n" \ + "PRFM PLDL1KEEP, ["X", #1024+128] \n" \ + "PRFM PLDL1KEEP, ["X", #1024+192] \n" \ + "fadd v4.2d, v4.2d, v24.2d \n" \ + "fadd v5.2d, v5.2d, v26.2d \n" \ + "fadd v6.2d, v6.2d, v28.2d \n" \ + "fadd v7.2d, v7.2d, v30.2d \n" + +#define KERNEL_F16_FINALIZE \ + "fadd v0.2d, v0.2d, v1.2d \n" \ + "fadd v2.2d, v2.2d, v3.2d \n" \ + "fadd v4.2d, v4.2d, v5.2d \n" \ + "fadd v6.2d, v6.2d, v7.2d \n" \ + "fadd v0.2d, v0.2d, v2.2d \n" \ + "fadd v4.2d, v4.2d, v6.2d \n" \ + "fadd v0.2d, v0.2d, v4.2d \n" \ + "faddp "SUMF", v0.2d \n" + +#define INIT_S \ + "lsl "INC_X", "INC_X", #4 \n" + +#define KERNEL_S1 \ + "ldr q1, ["X"] \n" \ + "add "X", "X", "INC_X" \n" \ + "fabs v1.2d, v1.2d \n" \ + "faddp d1, v1.2d \n" \ + "fadd "SUMF", "SUMF", d1 \n" + + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + + +static FLOAT zasum_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ + FLOAT asum = 0.0 ; + + if ( n < 0 ) return(asum); + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " fmov "SUMF", "REG0" \n" + " fmov d1, "REG0" \n" + " fmov d2, "REG0" \n" + " fmov d3, "REG0" \n" + " fmov d4, "REG0" \n" + " fmov d5, "REG0" \n" + " fmov d6, "REG0" \n" + " fmov d7, "REG0" \n" + " cmp "N", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", xzr \n" + " ble .Lasum_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Lasum_kernel_S_BEGIN \n" + + ".Lasum_kernel_F_BEGIN: \n" + " asr "J", "N", #4 \n" + " cmp "J", xzr \n" + " beq .Lasum_kernel_F1 \n" + + ".align 5 \n" + ".Lasum_kernel_F16: \n" + " "KERNEL_F16" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F16 \n" + " "KERNEL_F16_FINALIZE" \n" + + ".Lasum_kernel_F1: \n" + " ands "J", "N", #15 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_F10 \n" + " b .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S_BEGIN: \n" + " "INIT_S" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Lasum_kernel_S1 \n" + + ".Lasum_kernel_S4: \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S4 \n" + + ".Lasum_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Lasum_kernel_L999 \n" + + ".Lasum_kernel_S10: \n" + " "KERNEL_S1" \n" + " subs "J", "J", #1 \n" + " bne .Lasum_kernel_S10 \n" + + ".Lasum_kernel_L999: \n" + " fmov %[ASUM_], "SUMF" \n" + + : [ASUM_] "=r" (asum) //%0 + : [N_] "r" (n), //%1 + [X_] "r" (x), //%2 + [INCX_] "r" (inc_x) //%3 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + return asum; +} + +#if defined(SMP) +static int zasum_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + *result = zasum_compute(n, x, inc_x); + + return 0; +} +#endif + +FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + FLOAT asum = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + asum = zasum_compute(n, x, inc_x); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + FLOAT *ptr; + + mode = BLAS_DOUBLE | BLAS_COMPLEX; + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, NULL, 0, result, 0, + ( void *)zasum_thread_function, nthreads); + + ptr = (FLOAT *)result; + for (i = 0; i < nthreads; i++) { + asum = asum + (*ptr); + ptr = (FLOAT *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + asum = zasum_compute(n, x, inc_x); +#endif + + return asum; +} diff --git a/kernel/arm64/zdot_thunderx2t99.c b/kernel/arm64/zdot_thunderx2t99.c new file mode 100644 index 0000000000..64823871ff --- /dev/null +++ b/kernel/arm64/zdot_thunderx2t99.c @@ -0,0 +1,357 @@ +/*************************************************************************** +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + + +#include "common.h" + +#include + +#define N "x0" /* vector length */ +#define X "x1" /* "X" vector address */ +#define INC_X "x2" /* "X" stride */ +#define Y "x3" /* "Y" vector address */ +#define INC_Y "x4" /* "Y" stride */ +#define J "x5" /* loop variable */ + +#if !defined(DOUBLE) +#define REG0 "wzr" +#define DOTF "s0" +#define DOTI "s1" +#define INC_SHIFT "3" +#define N_DIV_SHIFT "4" +#define N_REM_MASK "15" +#else +#define REG0 "xzr" +#define DOTF "d0" +#define DOTI "d1" +#define INC_SHIFT "4" +#define N_DIV_SHIFT "3" +#define N_REM_MASK "7" +#endif + +#if !defined(CONJ) +#define f_ii "fmls" +#define f_ir "fmla" +#define a_ii "fsub" +#define a_ir "fadd" +#else +#define f_ii "fmla" +#define f_ir "fmls" +#define a_ii "fadd" +#define a_ir "fsub" +#endif + +#if !defined(DOUBLE) +#define KERNEL_F1 \ + " ldr d16, ["X"] \n" \ + " ldr d24, ["Y"] \n" \ + " add "X", "X", "INC_X" \n" \ + " add "Y", "Y", "INC_Y" \n" \ + " ins v17.s[0], v16.s[1] \n" \ + " fmla "DOTF", s16, v24.s[0] \n" \ + " "f_ii" "DOTF", s17, v24.s[1] \n" \ + " "f_ir" "DOTI", s17, v24.s[0] \n" \ + " fmla "DOTI", s16, v24.s[1] \n" + +#define KERNEL_F \ + " ld2 {v16.4s, v17.4s}, ["X"] \n" \ + " ld2 {v24.4s, v25.4s}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " ld2 {v18.4s, v19.4s}, ["X"] \n" \ + " ld2 {v26.4s, v27.4s}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " fmla v0.4s, v16.4s, v24.4s \n" \ + " fmla v1.4s, v17.4s, v25.4s \n" \ + " fmla v2.4s, v16.4s, v25.4s \n" \ + " fmla v3.4s, v17.4s, v24.4s \n" \ + " ld2 {v20.4s, v21.4s}, ["X"] \n" \ + " ld2 {v28.4s, v29.4s}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " fmla v4.4s, v18.4s, v26.4s \n" \ + " fmla v5.4s, v19.4s, v27.4s \n" \ + " fmla v6.4s, v18.4s, v27.4s \n" \ + " fmla v7.4s, v19.4s, v26.4s \n" \ + " ld2 {v22.4s, v23.4s}, ["X"] \n" \ + " ld2 {v30.4s, v31.4s}, ["Y"] \n" \ + " fmla v0.4s, v20.4s, v28.4s \n" \ + " fmla v1.4s, v21.4s, v29.4s \n" \ + " fmla v2.4s, v20.4s, v29.4s \n" \ + " fmla v3.4s, v21.4s, v28.4s \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " PRFM PLDL1KEEP, ["X", #1024] \n" \ + " PRFM PLDL1KEEP, ["Y", #1024] \n" \ + " PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #1024+64] \n" \ + " fmla v4.4s, v22.4s, v30.4s \n" \ + " fmla v5.4s, v23.4s, v31.4s \n" \ + " fmla v6.4s, v22.4s, v31.4s \n" \ + " fmla v7.4s, v23.4s, v30.4s \n" + +#define KERNEL_F_FINALIZE \ + " fadd v0.4s, v0.4s, v4.4s \n" \ + " fadd v1.4s, v1.4s, v5.4s \n" \ + " fadd v2.4s, v2.4s, v6.4s \n" \ + " fadd v3.4s, v3.4s, v7.4s \n" \ + " "a_ii" v0.4s, v0.4s, v1.4s \n" \ + " "a_ir" v1.4s, v2.4s, v3.4s \n" \ + " faddp v0.4s, v0.4s, v0.4s \n" \ + " faddp v0.4s, v0.4s, v0.4s \n" \ + " faddp v1.4s, v1.4s, v1.4s \n" \ + " faddp v1.4s, v1.4s, v1.4s \n" + +#else + +#define KERNEL_F1 \ + " ldr q16, ["X"] \n" \ + " ldr q24, ["Y"] \n" \ + " add "X", "X", "INC_X" \n" \ + " add "Y", "Y", "INC_Y" \n" \ + " ins v17.d[0], v16.d[1] \n" \ + " fmla "DOTF", d16, v24.d[0] \n" \ + " "f_ii" "DOTF", d17, v24.d[1] \n" \ + " "f_ir" "DOTI", d17, v24.d[0] \n" \ + " fmla "DOTI", d16, v24.d[1] \n" + +#define KERNEL_F \ + " ld2 {v16.2d, v17.2d}, ["X"] \n" \ + " ld2 {v24.2d, v25.2d}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " ld2 {v18.2d, v19.2d}, ["X"] \n" \ + " ld2 {v26.2d, v27.2d}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " fmla v0.2d, v16.2d, v24.2d \n" \ + " fmla v1.2d, v17.2d, v25.2d \n" \ + " fmla v2.2d, v16.2d, v25.2d \n" \ + " fmla v3.2d, v17.2d, v24.2d \n" \ + " ld2 {v20.2d, v21.2d}, ["X"] \n" \ + " ld2 {v28.2d, v29.2d}, ["Y"] \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " fmla v4.2d, v18.2d, v26.2d \n" \ + " fmla v5.2d, v19.2d, v27.2d \n" \ + " fmla v6.2d, v18.2d, v27.2d \n" \ + " fmla v7.2d, v19.2d, v26.2d \n" \ + " ld2 {v22.2d, v23.2d}, ["X"] \n" \ + " ld2 {v30.2d, v31.2d}, ["Y"] \n" \ + " fmla v0.2d, v20.2d, v28.2d \n" \ + " fmla v1.2d, v21.2d, v29.2d \n" \ + " fmla v2.2d, v20.2d, v29.2d \n" \ + " fmla v3.2d, v21.2d, v28.2d \n" \ + " add "X", "X", #32 \n" \ + " add "Y", "Y", #32 \n" \ + " PRFM PLDL1KEEP, ["X", #1024] \n" \ + " PRFM PLDL1KEEP, ["Y", #1024] \n" \ + " PRFM PLDL1KEEP, ["X", #1024+64] \n" \ + " PRFM PLDL1KEEP, ["Y", #1024+64] \n" \ + " fmla v4.2d, v22.2d, v30.2d \n" \ + " fmla v5.2d, v23.2d, v31.2d \n" \ + " fmla v6.2d, v22.2d, v31.2d \n" \ + " fmla v7.2d, v23.2d, v30.2d \n" + +#define KERNEL_F_FINALIZE \ + " fadd v0.2d, v0.2d, v4.2d \n" \ + " fadd v1.2d, v1.2d, v5.2d \n" \ + " fadd v2.2d, v2.2d, v6.2d \n" \ + " fadd v3.2d, v3.2d, v7.2d \n" \ + " "a_ii" v0.2d, v0.2d, v1.2d \n" \ + " "a_ir" v1.2d, v2.2d, v3.2d \n" \ + " faddp "DOTF", v0.2d \n" \ + " faddp "DOTI", v1.2d \n" +#endif + +#if defined(SMP) +extern int blas_level1_thread_with_return_value(int mode, BLASLONG m, BLASLONG n, + BLASLONG k, void *alpha, void *a, BLASLONG lda, void *b, BLASLONG ldb, + void *c, BLASLONG ldc, int (*function)(), int nthreads); +#endif + +static void zdot_compute(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, OPENBLAS_COMPLEX_FLOAT *result) +{ + FLOAT dotr = 0.0, doti = 0.0; + CREAL(*result) = 0.0; + CIMAG(*result) = 0.0; + + if ( n < 0 ) return; + + __asm__ __volatile__ ( + " mov "N", %[N_] \n" + " mov "X", %[X_] \n" + " mov "INC_X", %[INCX_] \n" + " mov "Y", %[Y_] \n" + " mov "INC_Y", %[INCY_] \n" + " fmov "DOTF", "REG0" \n" + " fmov "DOTI", "REG0" \n" + " fmov d2, xzr \n" + " fmov d3, xzr \n" + " fmov d4, xzr \n" + " fmov d5, xzr \n" + " fmov d6, xzr \n" + " fmov d7, xzr \n" + " cmp "N", xzr \n" + " ble .Ldot_kernel_L999 \n" + " cmp "INC_X", #1 \n" + " bne .Ldot_kernel_S_BEGIN \n" + " cmp "INC_Y", #1 \n" + " bne .Ldot_kernel_S_BEGIN \n" + + ".Ldot_kernel_F_BEGIN: \n" + " lsl "INC_X", "INC_X", "INC_SHIFT" \n" + " lsl "INC_Y", "INC_Y", "INC_SHIFT" \n" + " asr "J", "N", #"N_DIV_SHIFT" \n" + " cmp "J", xzr \n" + " beq .Ldot_kernel_F1 \n" + + " .align 5 \n" + ".Ldot_kernel_F: \n" + " "KERNEL_F" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_F \n" + " "KERNEL_F_FINALIZE" \n" + + ".Ldot_kernel_F1: \n" + " ands "J", "N", #"N_REM_MASK" \n" + " ble .Ldot_kernel_L999 \n" + + ".Ldot_kernel_F10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_F10 \n" + " b .Ldot_kernel_L999 \n" + + ".Ldot_kernel_S_BEGIN: \n" + " lsl "INC_X", "INC_X", "INC_SHIFT" \n" + " lsl "INC_Y", "INC_Y", "INC_SHIFT" \n" + " asr "J", "N", #2 \n" + " cmp "J", xzr \n" + " ble .Ldot_kernel_S1 \n" + + ".Ldot_kernel_S4: \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_S4 \n" + + ".Ldot_kernel_S1: \n" + " ands "J", "N", #3 \n" + " ble .Ldot_kernel_L999 \n" + + ".Ldot_kernel_S10: \n" + " "KERNEL_F1" \n" + " subs "J", "J", #1 \n" + " bne .Ldot_kernel_S10 \n" + + ".Ldot_kernel_L999: \n" + " str "DOTF", [%[DOTR_]] \n" + " str "DOTI", [%[DOTI_]] \n" + + : + : [DOTR_] "r" (&dotr), //%0 + [DOTI_] "r" (&doti), //%1 + [N_] "r" (n), //%2 + [X_] "r" (x), //%3 + [INCX_] "r" (inc_x), //%4 + [Y_] "r" (y), //%5 + [INCY_] "r" (inc_y) //%6 + : "cc", + "memory", + "x0", "x1", "x2", "x3", "x4", "x5", + "d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7" + ); + + CREAL(*result) = dotr; + CIMAG(*result) = doti; + return; +} + +#if defined(SMP) +static int zdot_thread_function(BLASLONG n, BLASLONG dummy0, + BLASLONG dummy1, FLOAT dummy2, FLOAT *x, BLASLONG inc_x, FLOAT *y, + BLASLONG inc_y, FLOAT *result, BLASLONG dummy3) +{ + zdot_compute(n, x, inc_x, y, inc_y, (void *)result); + + return 0; +} +#endif + +OPENBLAS_COMPLEX_FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ +#if defined(SMP) + int nthreads; + FLOAT dummy_alpha; +#endif + OPENBLAS_COMPLEX_FLOAT zdot; + CREAL(zdot) = 0.0; + CIMAG(zdot) = 0.0; + +#if defined(SMP) + nthreads = num_cpu_avail(1); + + if (inc_x == 0 || inc_y == 0) + nthreads = 1; + + if (n <= 10000) + nthreads = 1; + + if (nthreads == 1) { + zdot_compute(n, x, inc_x, y, inc_y, &zdot); + } else { + int mode, i; + char result[MAX_CPU_NUMBER * sizeof(double) * 2]; + OPENBLAS_COMPLEX_FLOAT *ptr; + +#if !defined(DOUBLE) + mode = BLAS_SINGLE | BLAS_COMPLEX; +#else + mode = BLAS_DOUBLE | BLAS_COMPLEX; +#endif + + blas_level1_thread_with_return_value(mode, n, 0, 0, &dummy_alpha, + x, inc_x, y, inc_y, result, 0, + ( void *)zdot_thread_function, nthreads); + + ptr = (OPENBLAS_COMPLEX_FLOAT *)result; + for (i = 0; i < nthreads; i++) { + CREAL(zdot) = CREAL(zdot) + CREAL(*ptr); + CIMAG(zdot) = CIMAG(zdot) + CIMAG(*ptr); + ptr = (void *)(((char *)ptr) + sizeof(double) * 2); + } + } +#else + zdot_compute(n, x, inc_x, y, inc_y, &zdot); +#endif + + return zdot; +} diff --git a/kernel/arm64/zgemm_kernel_4x4_thunderx2t99.S b/kernel/arm64/zgemm_kernel_4x4_thunderx2t99.S new file mode 100644 index 0000000000..e5b4cba9c5 --- /dev/null +++ b/kernel/arm64/zgemm_kernel_4x4_thunderx2t99.S @@ -0,0 +1,1698 @@ +/******************************************************************************* +Copyright (c) 2015, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* X0 X1 X2 s0 X3 x4 x5 x6 */ +/*int CNAME(BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha0,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc */ + +#define origM x0 +#define origN x1 +#define origK x2 +#define origPA x3 +#define origPB x4 +#define pC x5 +#define LDC x6 +#define temp x7 +#define counterL x8 +#define counterI x9 +#define counterJ x10 +#define pB x11 +#define pCRow0 x12 +#define pCRow1 x13 +#define pCRow2 x14 +#define pCRow3 x15 +#define pA x16 +#define alphaR x17 +#define alphaI x18 + +#define alpha0_R d10 +#define alphaV0_R v10.d[0] +#define alpha0_I d11 +#define alphaV0_I v11.d[0] + +#define A_PRE_SIZE 3584 +#define B_PRE_SIZE 512 +#define C_PRE_SIZE 128 + +#if defined(NN) || defined(NT) || defined(TN) || defined(TT) +#define OP_rr fmla +#define OP_ii fmls +#define OP_ri fmla +#define OP_ir fmla +#elif defined(NR) || defined(NC) || defined(TR) || defined(TC) +#define OP_rr fmla +#define OP_ii fmla +#define OP_ri fmls +#define OP_ir fmla +#elif defined(RN) || defined(RT) || defined(CN) || defined(CT) +#define OP_rr fmla +#define OP_ii fmla +#define OP_ri fmla +#define OP_ir fmls +#elif defined(RR) || defined(RC) || defined(CR) || defined(CC) +#define OP_rr fmla +#define OP_ii fmls +#define OP_ri fmls +#define OP_ir fmls +#endif + +// 00 origM +// 01 origN +// 02 origK +// 03 origPA +// 04 origPB +// 05 pC +// 06 origLDC -> LDC +// 07 offset -> temp +// 08 counterL +// 09 counterI +// 10 counterJ +// 11 pB +// 12 pCRow0 +// 13 pCRow1 +// 14 pCRow2 +// 15 pCRow3 +// 16 pA +// 17 alpha_save_R +// 18 must save alpha_save_I +// 19 must save +// 20 must save +// 21 must save +// 22 must save +// 23 must save +// 24 must save +// 25 must save +// 26 must save +// 27 must save +// 28 must save +// 29 frame +// 30 link +// 31 sp + +//v00 ALPHA_R -> pA00_R, pA01_R +//v01 ALPHA_I -> pA00_I, pA01_I +//v02 pA02_R, pA03_R +//v03 pA02_I, pA03_I +//v04 pA10_R, pA11_R +//v05 pA10_I, pA11_I +//v06 pA12_R, pA13_R +//v07 pA12_I, pA13_I +//v08 must save pB00_R, pB01_R +//v09 must save pB00_I, pB01_I +//v10 must save pB02_R, pB03_R OR ALPHA0_R +//v11 must save pB02_I, pB03_I OR ALPHA0_I +//v12 must save pB10_R, pB11_R +//v13 must save pB10_I, pB11_I +//v14 must save pB12_R, pB13_R OR ALPHA1_R +//v15 must save pB12_I, pB13_I OR ALPHA1_R +//v16 must save pC00_R, pC01_R +//v17 must save pC00_I, pC01_I +//v18 pC02_R, pC03_R +//v19 pC02_I, pC03_I +//v20 pC10_R, pC11_R +//v21 pC10_I, pC11_I +//v22 pC12_R, pC13_R +//v23 pC12_I, pC13_I +//v24 pC20_R, pC21_R +//v25 pC20_I, pC21_I +//v26 pC22_R, pC23_R +//v27 pC22_I, pC23_I +//v28 pC30_R, pC31_R +//v29 pC30_I, pC31_I +//v30 pC32_R, pC33_R +//v31 pC32_I, pC33_I + +/******************************************************************************* +* Macro definitions +*******************************************************************************/ + +.macro INIT4x4 + fmov d16, xzr + fmov d17, d16 + fmov d18, d17 + fmov d19, d16 + fmov d20, d17 + fmov d21, d16 + fmov d22, d17 + fmov d23, d16 + fmov d24, d17 + fmov d25, d16 + fmov d26, d17 + fmov d27, d16 + fmov d28, d17 + fmov d29, d16 + fmov d30, d17 + fmov d31, d16 +.endm + +.macro KERNEL4x4_I + ldr q8, [pB] + ldr q9, [pB, #16] + add pB, pB, #32 + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + fmul v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v8.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v17.16b, v17.16b, v17.16b + fmls v17.2d, v0.2d, v8.d[1] +#else + fmul v17.2d, v0.2d, v8.d[1] +#endif + OP_ir v17.2d, v1.2d, v8.d[0] + + ld2 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + fmul v20.2d, v0.2d, v9.d[0] + OP_ii v20.2d, v1.2d, v9.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v21.16b, v21.16b, v21.16b + fmls v21.2d, v0.2d, v9.d[1] +#else + fmul v21.2d, v0.2d, v9.d[1] +#endif + OP_ir v21.2d, v1.2d, v9.d[0] + + ldr q10, [pB] + ldr q11, [pB, #16] + add pB, pB, #32 + + fmul v22.2d, v2.2d, v9.d[0] + OP_ii v22.2d, v3.2d, v9.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v23.16b, v23.16b, v23.16b + fmls v23.2d, v2.2d, v9.d[1] +#else + fmul v23.2d, v2.2d, v9.d[1] +#endif + OP_ir v23.2d, v3.2d, v9.d[0] + + ldr q12, [pB] + ldr q13, [pB, #16] + add pB, pB, #32 + + fmul v18.2d, v2.2d, v8.d[0] + OP_ii v18.2d, v3.2d, v8.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v19.16b, v19.16b, v19.16b + fmls v19.2d, v2.2d, v8.d[1] +#else + fmul v19.2d, v2.2d, v8.d[1] +#endif + OP_ir v19.2d, v3.2d, v8.d[0] + + ld2 {v4.2d, v5.2d} , [pA] + add pA, pA, #32 + + fmul v24.2d, v0.2d, v10.d[0] + OP_ii v24.2d, v1.2d, v10.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v25.16b, v25.16b, v25.16b + fmls v25.2d, v0.2d, v10.d[1] +#else + fmul v25.2d, v0.2d, v10.d[1] +#endif + OP_ir v25.2d, v1.2d, v10.d[0] + + ld2 {v6.2d, v7.2d} , [pA] + add pA, pA, #32 + + fmul v26.2d, v2.2d, v10.d[0] + OP_ii v26.2d, v3.2d, v10.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v27.16b, v27.16b, v27.16b + fmls v27.2d, v2.2d, v10.d[1] +#else + fmul v27.2d, v2.2d, v10.d[1] +#endif + OP_ir v27.2d, v3.2d, v10.d[0] + + ldr q14, [pB] + ldr q15, [pB, #16] + add pB, pB, #32 + + fmul v28.2d, v0.2d, v11.d[0] + OP_ii v28.2d, v1.2d, v11.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v29.16b, v29.16b, v29.16b + fmls v29.2d, v0.2d, v11.d[1] +#else + fmul v29.2d, v0.2d, v11.d[1] +#endif + OP_ir v29.2d, v1.2d, v11.d[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + fmul v30.2d, v2.2d, v11.d[0] + OP_ii v30.2d, v3.2d, v11.d[1] +#if defined(NR) || defined(NC) || defined(TR) || defined(TC) || \ + defined(RR) || defined(RC) || defined(CR) || defined(CC) + eor v31.16b, v31.16b, v31.16b + fmls v31.2d, v2.2d, v11.d[1] +#else + fmul v31.2d, v2.2d, v11.d[1] +#endif + OP_ir v31.2d, v3.2d, v11.d[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] +.endm + +.macro KERNEL4x4_M1 + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v8.d[1] + OP_ri v17.2d, v0.2d, v8.d[1] + OP_ir v17.2d, v1.2d, v8.d[0] + + ldr q12, [pB] + ldr q13, [pB, #16] + add pB, pB, #32 + + OP_rr v18.2d, v2.2d, v8.d[0] + OP_ii v18.2d, v3.2d, v8.d[1] + OP_ri v19.2d, v2.2d, v8.d[1] + OP_ir v19.2d, v3.2d, v8.d[0] + + ld2 {v4.2d, v5.2d} , [pA] + add pA, pA, #32 + + OP_rr v20.2d, v0.2d, v9.d[0] + OP_ii v20.2d, v1.2d, v9.d[1] + OP_ri v21.2d, v0.2d, v9.d[1] + OP_ir v21.2d, v1.2d, v9.d[0] + + ld2 {v6.2d, v7.2d} , [pA] + add pA, pA, #32 + + OP_rr v22.2d, v2.2d, v9.d[0] + OP_ii v22.2d, v3.2d, v9.d[1] + OP_ri v23.2d, v2.2d, v9.d[1] + OP_ir v23.2d, v3.2d, v9.d[0] + + ldr q14, [pB] + ldr q15, [pB, #16] + add pB, pB, #32 + + OP_rr v24.2d, v0.2d, v10.d[0] + OP_ii v24.2d, v1.2d, v10.d[1] + OP_ri v25.2d, v0.2d, v10.d[1] + OP_ir v25.2d, v1.2d, v10.d[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + OP_rr v26.2d, v2.2d, v10.d[0] + OP_ii v26.2d, v3.2d, v10.d[1] + OP_ri v27.2d, v2.2d, v10.d[1] + OP_ir v27.2d, v3.2d, v10.d[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE+64] + + OP_rr v28.2d, v0.2d, v11.d[0] + OP_ii v28.2d, v1.2d, v11.d[1] + OP_ri v29.2d, v0.2d, v11.d[1] + OP_ir v29.2d, v1.2d, v11.d[0] + + OP_rr v30.2d, v2.2d, v11.d[0] + OP_ii v30.2d, v3.2d, v11.d[1] + OP_ri v31.2d, v2.2d, v11.d[1] + OP_ir v31.2d, v3.2d, v11.d[0] +.endm + +.macro KERNEL4x4_M2 + OP_rr v16.2d, v4.2d, v12.d[0] + OP_ii v16.2d, v5.2d, v12.d[1] + OP_ri v17.2d, v4.2d, v12.d[1] + OP_ir v17.2d, v5.2d, v12.d[0] + + ldr q8, [pB] + ldr q9, [pB, #16] + add pB, pB, #32 + + OP_rr v18.2d, v6.2d, v12.d[0] + OP_ii v18.2d, v7.2d, v12.d[1] + OP_ri v19.2d, v6.2d, v12.d[1] + OP_ir v19.2d, v7.2d, v12.d[0] + + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + OP_rr v20.2d, v4.2d, v13.d[0] + OP_ii v20.2d, v5.2d, v13.d[1] + OP_ri v21.2d, v4.2d, v13.d[1] + OP_ir v21.2d, v5.2d, v13.d[0] + + ld2 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + OP_rr v22.2d, v6.2d, v13.d[0] + OP_ii v22.2d, v7.2d, v13.d[1] + OP_ri v23.2d, v6.2d, v13.d[1] + OP_ir v23.2d, v7.2d, v13.d[0] + + ldr q10, [pB] + ldr q11, [pB, #16] + add pB, pB, #32 + + OP_rr v24.2d, v4.2d, v14.d[0] + OP_ii v24.2d, v5.2d, v14.d[1] + OP_ri v25.2d, v4.2d, v14.d[1] + OP_ir v25.2d, v5.2d, v14.d[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v26.2d, v6.2d, v14.d[0] + OP_ii v26.2d, v7.2d, v14.d[1] + OP_ri v27.2d, v6.2d, v14.d[1] + OP_ir v27.2d, v7.2d, v14.d[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE+64] + + OP_rr v28.2d, v4.2d, v15.d[0] + OP_ii v28.2d, v5.2d, v15.d[1] + OP_ri v29.2d, v4.2d, v15.d[1] + OP_ir v29.2d, v5.2d, v15.d[0] + + OP_rr v30.2d, v6.2d, v15.d[0] + OP_ii v30.2d, v7.2d, v15.d[1] + OP_ri v31.2d, v6.2d, v15.d[1] + OP_ir v31.2d, v7.2d, v15.d[0] +.endm + +.macro KERNEL4x4_E + OP_rr v16.2d, v4.2d, v12.d[0] + OP_ii v16.2d, v5.2d, v12.d[1] + OP_ri v17.2d, v4.2d, v12.d[1] + OP_ir v17.2d, v5.2d, v12.d[0] + + OP_rr v18.2d, v6.2d, v12.d[0] + OP_ii v18.2d, v7.2d, v12.d[1] + OP_ri v19.2d, v6.2d, v12.d[1] + OP_ir v19.2d, v7.2d, v12.d[0] + + OP_rr v20.2d, v4.2d, v13.d[0] + OP_ii v20.2d, v5.2d, v13.d[1] + OP_ri v21.2d, v4.2d, v13.d[1] + OP_ir v21.2d, v5.2d, v13.d[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v22.2d, v6.2d, v13.d[0] + OP_ii v22.2d, v7.2d, v13.d[1] + OP_ri v23.2d, v6.2d, v13.d[1] + OP_ir v23.2d, v7.2d, v13.d[0] + + OP_rr v24.2d, v4.2d, v14.d[0] + OP_ii v24.2d, v5.2d, v14.d[1] + OP_ri v25.2d, v4.2d, v14.d[1] + OP_ir v25.2d, v5.2d, v14.d[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE+64] + + OP_rr v26.2d, v6.2d, v14.d[0] + OP_ii v26.2d, v7.2d, v14.d[1] + OP_ri v27.2d, v6.2d, v14.d[1] + OP_ir v27.2d, v7.2d, v14.d[0] + + OP_rr v28.2d, v4.2d, v15.d[0] + OP_ii v28.2d, v5.2d, v15.d[1] + OP_ri v29.2d, v4.2d, v15.d[1] + OP_ir v29.2d, v5.2d, v15.d[0] + + OP_rr v30.2d, v6.2d, v15.d[0] + OP_ii v30.2d, v7.2d, v15.d[1] + OP_ri v31.2d, v6.2d, v15.d[1] + OP_ir v31.2d, v7.2d, v15.d[0] +.endm + +.macro KERNEL4x4_SUB + ldr q8, [pB] + ldr q9, [pB, #16] + add pB, pB, #32 + + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v8.d[1] + OP_ri v17.2d, v0.2d, v8.d[1] + OP_ir v17.2d, v1.2d, v8.d[0] + + ld2 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + OP_rr v20.2d, v0.2d, v9.d[0] + OP_ii v20.2d, v1.2d, v9.d[1] + OP_ri v21.2d, v0.2d, v9.d[1] + OP_ir v21.2d, v1.2d, v9.d[0] + + ldr q10, [pB] + ldr q11, [pB, #16] + add pB, pB, #32 + + OP_rr v18.2d, v2.2d, v8.d[0] + OP_ii v18.2d, v3.2d, v8.d[1] + OP_ri v19.2d, v2.2d, v8.d[1] + OP_ir v19.2d, v3.2d, v8.d[0] + + prfm PLDL1KEEP, [pB, #B_PRE_SIZE] + + OP_rr v22.2d, v2.2d, v9.d[0] + OP_ii v22.2d, v3.2d, v9.d[1] + OP_ri v23.2d, v2.2d, v9.d[1] + OP_ir v23.2d, v3.2d, v9.d[0] + + prfm PLDL1KEEP, [pA, #A_PRE_SIZE] + + OP_rr v24.2d, v0.2d, v10.d[0] + OP_ii v24.2d, v1.2d, v10.d[1] + OP_ri v25.2d, v0.2d, v10.d[1] + OP_ir v25.2d, v1.2d, v10.d[0] + + OP_rr v26.2d, v2.2d, v10.d[0] + OP_ii v26.2d, v3.2d, v10.d[1] + OP_ri v27.2d, v2.2d, v10.d[1] + OP_ir v27.2d, v3.2d, v10.d[0] + + OP_rr v28.2d, v0.2d, v11.d[0] + OP_ii v28.2d, v1.2d, v11.d[1] + OP_ri v29.2d, v0.2d, v11.d[1] + OP_ir v29.2d, v1.2d, v11.d[0] + + OP_rr v30.2d, v2.2d, v11.d[0] + OP_ii v30.2d, v3.2d, v11.d[1] + OP_ri v31.2d, v2.2d, v11.d[1] + OP_ir v31.2d, v3.2d, v11.d[0] +.endm + +.macro SAVE4x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + prfm PLDL2KEEP, [pCRow0, #C_PRE_SIZE] + + ld2 {v0.2d, v1.2d}, [pCRow0] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow0] + + add pCRow0, pCRow0, #32 + + ld2 {v2.2d, v3.2d}, [pCRow0] + fmla v2.2d, v18.2d, alphaV0_R + fmls v2.2d, v19.2d, alphaV0_I + fmla v3.2d, v18.2d, alphaV0_I + fmla v3.2d, v19.2d, alphaV0_R + st2 {v2.2d, v3.2d}, [pCRow0] + + add pCRow0, pCRow0, #32 + prfm PLDL2KEEP, [pCRow1, #C_PRE_SIZE] + + ld2 {v4.2d, v5.2d}, [pCRow1] + fmla v4.2d, v20.2d, alphaV0_R + fmls v4.2d, v21.2d, alphaV0_I + fmla v5.2d, v20.2d, alphaV0_I + fmla v5.2d, v21.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow1] + + add pCRow1, pCRow1, #32 + + ld2 {v6.2d, v7.2d}, [pCRow1] + fmla v6.2d, v22.2d, alphaV0_R + fmls v6.2d, v23.2d, alphaV0_I + fmla v7.2d, v22.2d, alphaV0_I + fmla v7.2d, v23.2d, alphaV0_R + st2 {v6.2d, v7.2d}, [pCRow1] + + add pCRow1, pCRow1, #32 + prfm PLDL2KEEP, [pCRow2, #C_PRE_SIZE] + + ld2 {v0.2d, v1.2d}, [pCRow2] + fmla v0.2d, v24.2d, alphaV0_R + fmls v0.2d, v25.2d, alphaV0_I + fmla v1.2d, v24.2d, alphaV0_I + fmla v1.2d, v25.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow2] + + add pCRow2, pCRow2, #32 + + ld2 {v2.2d, v3.2d}, [pCRow2] + fmla v2.2d, v26.2d, alphaV0_R + fmls v2.2d, v27.2d, alphaV0_I + fmla v3.2d, v26.2d, alphaV0_I + fmla v3.2d, v27.2d, alphaV0_R + st2 {v2.2d, v3.2d}, [pCRow2] + + add pCRow2, pCRow2, #32 + prfm PLDL2KEEP, [pCRow3, #C_PRE_SIZE] + + ld2 {v4.2d, v5.2d}, [pCRow3] + fmla v4.2d, v28.2d, alphaV0_R + fmls v4.2d, v29.2d, alphaV0_I + fmla v5.2d, v28.2d, alphaV0_I + fmla v5.2d, v29.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow3] + + add pCRow3, pCRow3, #32 + + ld2 {v6.2d, v7.2d}, [pCRow3] + fmla v6.2d, v30.2d, alphaV0_R + fmls v6.2d, v31.2d, alphaV0_I + fmla v7.2d, v30.2d, alphaV0_I + fmla v7.2d, v31.2d, alphaV0_R + st2 {v6.2d, v7.2d}, [pCRow3] + + add pCRow3, pCRow3, #32 +.endm + +/******************************************************************************/ + +.macro INIT2x4 + fmov d16, xzr + fmov d17, xzr + fmov d20, d16 + fmov d21, d17 + fmov d24, d16 + fmov d25, d17 + fmov d28, d16 + fmov d29, d17 +.endm + +.macro KERNEL2x4_SUB + ld2 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld2 {v10.2d, v11.2d}, [pB] + add pB, pB, #32 + + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v9.d[0] + OP_ri v17.2d, v0.2d, v9.d[0] + OP_ir v17.2d, v1.2d, v8.d[0] + + OP_rr v20.2d, v0.2d, v8.d[1] + OP_ii v20.2d, v1.2d, v9.d[1] + OP_ri v21.2d, v0.2d, v9.d[1] + OP_ir v21.2d, v1.2d, v8.d[1] + + OP_rr v24.2d, v0.2d, v10.d[0] + OP_ii v24.2d, v1.2d, v11.d[0] + OP_ri v25.2d, v0.2d, v11.d[0] + OP_ir v25.2d, v1.2d, v10.d[0] + + OP_rr v28.2d, v0.2d, v10.d[1] + OP_ii v28.2d, v1.2d, v11.d[1] + OP_ri v29.2d, v0.2d, v11.d[1] + OP_ir v29.2d, v1.2d, v10.d[1] +.endm + +.macro SAVE2x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2d, v5.2d}, [pCRow1] + fmla v4.2d, v20.2d, alphaV0_R + fmls v4.2d, v21.2d, alphaV0_I + fmla v5.2d, v20.2d, alphaV0_I + fmla v5.2d, v21.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v24.2d, alphaV0_R + fmls v0.2d, v25.2d, alphaV0_I + fmla v1.2d, v24.2d, alphaV0_I + fmla v1.2d, v25.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2d, v5.2d}, [pCRow1] + fmla v4.2d, v28.2d, alphaV0_R + fmls v4.2d, v29.2d, alphaV0_I + fmla v5.2d, v28.2d, alphaV0_I + fmla v5.2d, v29.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT1x4 + fmov d16, xzr + fmov d17, xzr + fmov d20, d16 + fmov d21, d17 + fmov d24, d16 + fmov d25, d17 + fmov d28, d16 + fmov d29, d17 +.endm + +.macro KERNEL1x4_SUB + ld2 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld2 {v10.2d, v11.2d}, [pB] + add pB, pB, #32 + ld2 {v0.d, v1.d}[0], [pA] + add pA, pA, #16 + + OP_rr d16, d0, v8.d[0] + OP_ii d16, d1, v9.d[0] + OP_ri d17, d0, v9.d[0] + OP_ir d17, d1, v8.d[0] + + OP_rr d20, d0, v8.d[1] + OP_ii d20, d1, v9.d[1] + OP_ri d21, d0, v9.d[1] + OP_ir d21, d1, v8.d[1] + + OP_rr d24, d0, v10.d[0] + OP_ii d24, d1, v11.d[0] + OP_ri d25, d0, v11.d[0] + OP_ir d25, d1, v10.d[0] + + OP_rr d28, d0, v10.d[1] + OP_ii d28, d1, v11.d[1] + OP_ri d29, d0, v11.d[1] + OP_ir d29, d1, v10.d[1] +.endm + +.macro SAVE1x4 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.d, v1.d}[0], [pCRow1] + fmla d0, d16, alphaV0_R + fmls d0, d17, alphaV0_I + fmla d1, d16, alphaV0_I + fmla d1, d17, alphaV0_R + st2 {v0.d, v1.d}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.d, v5.d}[0], [pCRow1] + fmla d4, d20, alphaV0_R + fmls d4, d21, alphaV0_I + fmla d5, d20, alphaV0_I + fmla d5, d21, alphaV0_R + st2 {v4.d, v5.d}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v0.d, v1.d}[0], [pCRow1] + fmla d0, d24, alphaV0_R + fmls d0, d25, alphaV0_I + fmla d1, d24, alphaV0_I + fmla d1, d25, alphaV0_R + st2 {v0.d, v1.d}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.d, v5.d}[0], [pCRow1] + fmla d4, d28, alphaV0_R + fmls d4, d29, alphaV0_I + fmla d5, d28, alphaV0_I + fmla d5, d29, alphaV0_R + st2 {v4.d, v5.d}[0], [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT4x2 + fmov d16, xzr + fmov d17, xzr + fmov d18, d16 + fmov d19, d17 + fmov d20, d16 + fmov d21, d17 + fmov d22, d16 + fmov d23, d17 +.endm + +.macro KERNEL4x2_SUB + ld2 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + ld2 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v9.d[0] + OP_ri v17.2d, v0.2d, v9.d[0] + OP_ir v17.2d, v1.2d, v8.d[0] + + OP_rr v18.2d, v2.2d, v8.d[0] + OP_ii v18.2d, v3.2d, v9.d[0] + OP_ri v19.2d, v2.2d, v9.d[0] + OP_ir v19.2d, v3.2d, v8.d[0] + + OP_rr v20.2d, v0.2d, v8.d[1] + OP_ii v20.2d, v1.2d, v9.d[1] + OP_ri v21.2d, v0.2d, v9.d[1] + OP_ir v21.2d, v1.2d, v8.d[1] + + OP_rr v22.2d, v2.2d, v8.d[1] + OP_ii v22.2d, v3.2d, v9.d[1] + OP_ri v23.2d, v2.2d, v9.d[1] + OP_ir v23.2d, v3.2d, v8.d[1] +.endm + +.macro SAVE4x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + add pCRow2, pCRow1, #32 + ld2 {v2.2d, v3.2d}, [pCRow2] + fmla v2.2d, v18.2d, alphaV0_R + fmls v2.2d, v19.2d, alphaV0_I + fmla v3.2d, v18.2d, alphaV0_I + fmla v3.2d, v19.2d, alphaV0_R + st2 {v2.2d, v3.2d}, [pCRow2] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2d, v5.2d}, [pCRow1] + fmla v4.2d, v20.2d, alphaV0_R + fmls v4.2d, v21.2d, alphaV0_I + fmla v5.2d, v20.2d, alphaV0_I + fmla v5.2d, v21.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow1] + add pCRow2, pCRow1, #32 + ld2 {v6.2d, v7.2d}, [pCRow2] + fmla v6.2d, v22.2d, alphaV0_R + fmls v6.2d, v23.2d, alphaV0_I + fmla v7.2d, v22.2d, alphaV0_I + fmla v7.2d, v23.2d, alphaV0_R + st2 {v6.2d, v7.2d}, [pCRow2] + + add pCRow0, pCRow0, #64 +.endm + +/******************************************************************************/ + +.macro INIT2x2 + fmov d16, xzr + fmov d17, xzr + fmov d20, d16 + fmov d21, d17 +.endm + +.macro KERNEL2x2_SUB + ld2 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v9.d[0] + OP_ri v17.2d, v0.2d, v9.d[0] + OP_ir v17.2d, v1.2d, v8.d[0] + + OP_rr v20.2d, v0.2d, v8.d[1] + OP_ii v20.2d, v1.2d, v9.d[1] + OP_ri v21.2d, v0.2d, v9.d[1] + OP_ir v21.2d, v1.2d, v8.d[1] +.endm + +.macro SAVE2x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.2d, v5.2d}, [pCRow1] + fmla v4.2d, v20.2d, alphaV0_R + fmls v4.2d, v21.2d, alphaV0_I + fmla v5.2d, v20.2d, alphaV0_I + fmla v5.2d, v21.2d, alphaV0_R + st2 {v4.2d, v5.2d}, [pCRow1] + + add pCRow0, pCRow0, #32 +.endm + +/******************************************************************************/ + +.macro INIT1x2 + fmov d16, xzr + fmov d17, xzr + fmov d20, xzr + fmov d21, xzr +.endm + +.macro KERNEL1x2_SUB + ld2 {v8.2d, v9.2d}, [pB] + add pB, pB, #32 + ld2 {v0.d, v1.d}[0], [pA] + add pA, pA, #16 + + OP_rr d16, d0, v8.d[0] + OP_ii d16, d1, v9.d[0] + OP_ri d17, d0, v9.d[0] + OP_ir d17, d1, v8.d[0] + + OP_rr d20, d0, v8.d[1] + OP_ii d20, d1, v9.d[1] + OP_ri d21, d0, v9.d[1] + OP_ir d21, d1, v8.d[1] +.endm + +.macro SAVE1x2 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.d, v1.d}[0], [pCRow1] + fmla d0, d16, alphaV0_R + fmls d0, d17, alphaV0_I + fmla d1, d16, alphaV0_I + fmla d1, d17, alphaV0_R + st2 {v0.d, v1.d}[0], [pCRow1] + + add pCRow1, pCRow1, LDC + + ld2 {v4.d, v5.d}[0], [pCRow1] + fmla d4, d20, alphaV0_R + fmls d4, d21, alphaV0_I + fmla d5, d20, alphaV0_I + fmla d5, d21, alphaV0_R + st2 {v4.d, v5.d}[0], [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************/ + +.macro INIT4x1 + fmov d16, xzr + fmov d17, d16 + fmov d18, d16 + fmov d19, d17 +.endm + +.macro KERNEL4x1_SUB + ld2 {v8.d, v9.d}[0], [pB] + add pB, pB, #16 + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + ld2 {v2.2d, v3.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v9.d[0] + OP_ri v17.2d, v0.2d, v9.d[0] + OP_ir v17.2d, v1.2d, v8.d[0] + + OP_rr v18.2d, v2.2d, v8.d[0] + OP_ii v18.2d, v3.2d, v9.d[0] + OP_ri v19.2d, v2.2d, v9.d[0] + OP_ir v19.2d, v3.2d, v8.d[0] +.endm + +.macro SAVE4x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + add pCRow2, pCRow1, #32 + ld2 {v2.2d, v3.2d}, [pCRow2] + fmla v2.2d, v18.2d, alphaV0_R + fmls v2.2d, v19.2d, alphaV0_I + fmla v3.2d, v18.2d, alphaV0_I + fmla v3.2d, v19.2d, alphaV0_R + st2 {v2.2d, v3.2d}, [pCRow2] + + add pCRow0, pCRow0, #64 +.endm + +/******************************************************************************/ + +.macro INIT2x1 + fmov d16, xzr + fmov d17, xzr +.endm + +.macro KERNEL2x1_SUB + ld2 {v8.d, v9.d}[0], [pB] + add pB, pB, #16 + ld2 {v0.2d, v1.2d}, [pA] + add pA, pA, #32 + + OP_rr v16.2d, v0.2d, v8.d[0] + OP_ii v16.2d, v1.2d, v9.d[0] + OP_ri v17.2d, v0.2d, v9.d[0] + OP_ir v17.2d, v1.2d, v8.d[0] +.endm + +.macro SAVE2x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.2d, v1.2d}, [pCRow1] + fmla v0.2d, v16.2d, alphaV0_R + fmls v0.2d, v17.2d, alphaV0_I + fmla v1.2d, v16.2d, alphaV0_I + fmla v1.2d, v17.2d, alphaV0_R + st2 {v0.2d, v1.2d}, [pCRow1] + + add pCRow0, pCRow0, #32 + +.endm + +/******************************************************************************/ + +.macro INIT1x1 + fmov d16, xzr + fmov d17, xzr +.endm + +.macro KERNEL1x1_SUB + ld2 {v8.d, v9.d}[0], [pB] + add pB, pB, #16 + ld2 {v0.d, v1.d}[0], [pA] + add pA, pA, #16 + + OP_rr d16, d0, v8.d[0] + OP_ii d16, d1, v9.d[0] + OP_ri d17, d0, v9.d[0] + OP_ir d17, d1, v8.d[0] +.endm + +.macro SAVE1x1 + fmov alpha0_R, alphaR + fmov alpha0_I, alphaI + + mov pCRow1, pCRow0 + + ld2 {v0.d, v1.d}[0], [pCRow1] + fmla d0, d16, alphaV0_R + fmls d0, d17, alphaV0_I + fmla d1, d16, alphaV0_I + fmla d1, d17, alphaV0_R + st2 {v0.d, v1.d}[0], [pCRow1] + + add pCRow0, pCRow0, #16 +.endm + +/******************************************************************************* +* End of macro definitions +*******************************************************************************/ + + PROLOGUE + + .align 5 + add sp, sp, #-(11 * 16) + stp d8, d9, [sp, #(0 * 16)] + stp d10, d11, [sp, #(1 * 16)] + stp d12, d13, [sp, #(2 * 16)] + stp d14, d15, [sp, #(3 * 16)] + stp d16, d17, [sp, #(4 * 16)] + stp x18, x19, [sp, #(5 * 16)] + stp x20, x21, [sp, #(6 * 16)] + stp x22, x23, [sp, #(7 * 16)] + stp x24, x25, [sp, #(8 * 16)] + stp x26, x27, [sp, #(9 * 16)] + str x28, [sp, #(10 * 16)] + + prfm PLDL1KEEP, [origPB] + prfm PLDL1KEEP, [origPA] + + fmov alphaR, d0 + fmov alphaI, d1 + + lsl LDC, LDC, #4 // ldc = ldc * 2 * 8 + + mov pB, origPB + + mov counterJ, origN + asr counterJ, counterJ, #2 // J = J / 4 + cmp counterJ, #0 + ble zgemm_kernel_L2_BEGIN + +zgemm_kernel_L4_BEGIN: + mov pCRow0, pC + add pCRow1, pCRow0, LDC + add pCRow2, pCRow1, LDC + add pCRow3, pCRow2, LDC + + add pC, pCRow3, LDC + + mov pA, origPA // pA = start of A array + +zgemm_kernel_L4_M4_BEGIN: + + mov counterI, origM + asr counterI, counterI, #2 // counterI = counterI / 4 + cmp counterI, #0 + ble zgemm_kernel_L4_M2_BEGIN + + .align 5 +zgemm_kernel_L4_M4_20: + + mov pB, origPB + asr counterL , origK, #3 + cmp counterL , #2 + blt zgemm_kernel_L4_M4_32 + + KERNEL4x4_I + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + + subs counterL, counterL, #2 // subtract 2 + ble zgemm_kernel_L4_M4_22a + + .align 5 +zgemm_kernel_L4_M4_22: + + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + + subs counterL, counterL, #1 + bgt zgemm_kernel_L4_M4_22 + + .align 5 +zgemm_kernel_L4_M4_22a: + + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_E + + b zgemm_kernel_L4_M4_44 + + .align 5 +zgemm_kernel_L4_M4_32: + + tst counterL, #1 + ble zgemm_kernel_L4_M4_40 + + KERNEL4x4_I + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_M2 + KERNEL4x4_M1 + KERNEL4x4_E + + b zgemm_kernel_L4_M4_44 + + +zgemm_kernel_L4_M4_40: + + INIT4x4 + +zgemm_kernel_L4_M4_44: + + ands counterL , origK, #7 + ble zgemm_kernel_L4_M4_100 + + .align 5 +zgemm_kernel_L4_M4_46: + KERNEL4x4_SUB + + subs counterL, counterL, #1 + bne zgemm_kernel_L4_M4_46 + +zgemm_kernel_L4_M4_100: + prfm PLDL1KEEP, [pA] + prfm PLDL1KEEP, [pA, #64] + prfm PLDL1KEEP, [origPB] + + SAVE4x4 + +zgemm_kernel_L4_M4_END: + subs counterI, counterI, #1 + bne zgemm_kernel_L4_M4_20 + +zgemm_kernel_L4_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble zgemm_kernel_L4_END + + tst counterI, #2 // counterI = counterI / 2 + ble zgemm_kernel_L4_M1_BEGIN + +zgemm_kernel_L4_M2_20: + + INIT2x4 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble zgemm_kernel_L4_M2_40 + +zgemm_kernel_L4_M2_22: + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L4_M2_22 + + +zgemm_kernel_L4_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L4_M2_100 + +zgemm_kernel_L4_M2_42: + + KERNEL2x4_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L4_M2_42 + +zgemm_kernel_L4_M2_100: + + SAVE2x4 + +zgemm_kernel_L4_M2_END: + + +zgemm_kernel_L4_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble zgemm_kernel_L4_END + +zgemm_kernel_L4_M1_20: + + INIT1x4 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble zgemm_kernel_L4_M1_40 + +zgemm_kernel_L4_M1_22: + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L4_M1_22 + + +zgemm_kernel_L4_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L4_M1_100 + +zgemm_kernel_L4_M1_42: + + KERNEL1x4_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L4_M1_42 + +zgemm_kernel_L4_M1_100: + + SAVE1x4 + + +zgemm_kernel_L4_END: + + lsl temp, origK, #6 + add origPB, origPB, temp // B = B + K * 4 * 8 * 2 + + subs counterJ, counterJ , #1 // j-- + bgt zgemm_kernel_L4_BEGIN + + +/******************************************************************************/ + +zgemm_kernel_L2_BEGIN: // less than 2 left in N direction + + mov counterJ , origN + tst counterJ , #3 + ble zgemm_kernel_L999 + + tst counterJ , #2 + ble zgemm_kernel_L1_BEGIN + + mov pCRow0, pC // pCRow0 = pC + + add pC,pC,LDC, lsl #1 + + mov pA, origPA // pA = A + + + +zgemm_kernel_L2_M4_BEGIN: + + mov counterI, origM + asr counterI, counterI, #2 // counterI = counterI / 4 + cmp counterI,#0 + ble zgemm_kernel_L2_M2_BEGIN + +zgemm_kernel_L2_M4_20: + + INIT4x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble zgemm_kernel_L2_M4_40 + .align 5 + +zgemm_kernel_L2_M4_22: + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M4_22 + + +zgemm_kernel_L2_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L2_M4_100 + +zgemm_kernel_L2_M4_42: + + KERNEL4x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M4_42 + +zgemm_kernel_L2_M4_100: + + SAVE4x2 + +zgemm_kernel_L2_M4_END: + + subs counterI, counterI, #1 + bgt zgemm_kernel_L2_M4_20 + + +zgemm_kernel_L2_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble zgemm_kernel_L2_END + + tst counterI, #2 // counterI = counterI / 2 + ble zgemm_kernel_L2_M1_BEGIN + +zgemm_kernel_L2_M2_20: + + INIT2x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL,#0 + ble zgemm_kernel_L2_M2_40 + +zgemm_kernel_L2_M2_22: + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M2_22 + + +zgemm_kernel_L2_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L2_M2_100 + +zgemm_kernel_L2_M2_42: + + KERNEL2x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M2_42 + +zgemm_kernel_L2_M2_100: + + SAVE2x2 + +zgemm_kernel_L2_M2_END: + + +zgemm_kernel_L2_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble zgemm_kernel_L2_END + +zgemm_kernel_L2_M1_20: + + INIT1x2 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL, #0 + ble zgemm_kernel_L2_M1_40 + +zgemm_kernel_L2_M1_22: + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M1_22 + + +zgemm_kernel_L2_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L2_M1_100 + +zgemm_kernel_L2_M1_42: + + KERNEL1x2_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L2_M1_42 + +zgemm_kernel_L2_M1_100: + + SAVE1x2 + + +zgemm_kernel_L2_END: + lsl temp, origK, #5 + add origPB, origPB, temp // B = B + K * 2 * 8 * 2 + +/******************************************************************************/ + +zgemm_kernel_L1_BEGIN: + + mov counterJ , origN + tst counterJ , #1 + ble zgemm_kernel_L999 // done + + + mov pCRow0, pC // pCRow0 = C + add pC , pC , LDC // Update pC to point to next + + mov pA, origPA // pA = A + + + +zgemm_kernel_L1_M4_BEGIN: + + mov counterI, origM + asr counterI, counterI, #2 // counterI = counterI / 4 + cmp counterI, #0 + ble zgemm_kernel_L1_M2_BEGIN + +zgemm_kernel_L1_M4_20: + + INIT4x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble zgemm_kernel_L1_M4_40 + .align 5 + +zgemm_kernel_L1_M4_22: + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M4_22 + + +zgemm_kernel_L1_M4_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L1_M4_100 + +zgemm_kernel_L1_M4_42: + + KERNEL4x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M4_42 + +zgemm_kernel_L1_M4_100: + + SAVE4x1 + +zgemm_kernel_L1_M4_END: + + subs counterI, counterI, #1 + bgt zgemm_kernel_L1_M4_20 + + +zgemm_kernel_L1_M2_BEGIN: + + mov counterI, origM + tst counterI , #3 + ble zgemm_kernel_L1_END + + tst counterI, #2 // counterI = counterI / 2 + ble zgemm_kernel_L1_M1_BEGIN + +zgemm_kernel_L1_M2_20: + + INIT2x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble zgemm_kernel_L1_M2_40 + +zgemm_kernel_L1_M2_22: + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M2_22 + + +zgemm_kernel_L1_M2_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L1_M2_100 + +zgemm_kernel_L1_M2_42: + + KERNEL2x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M2_42 + +zgemm_kernel_L1_M2_100: + + SAVE2x1 + +zgemm_kernel_L1_M2_END: + + +zgemm_kernel_L1_M1_BEGIN: + + tst counterI, #1 // counterI = counterI % 2 + ble zgemm_kernel_L1_END + +zgemm_kernel_L1_M1_20: + + INIT1x1 + + mov pB, origPB + asr counterL , origK, #3 // counterL = counterL / 8 + cmp counterL , #0 + ble zgemm_kernel_L1_M1_40 + +zgemm_kernel_L1_M1_22: + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M1_22 + + +zgemm_kernel_L1_M1_40: + + ands counterL , origK, #7 // counterL = counterL % 8 + ble zgemm_kernel_L1_M1_100 + +zgemm_kernel_L1_M1_42: + + KERNEL1x1_SUB + + subs counterL, counterL, #1 + bgt zgemm_kernel_L1_M1_42 + +zgemm_kernel_L1_M1_100: + + SAVE1x1 + + +zgemm_kernel_L1_END: + + +zgemm_kernel_L999: + mov x0, #0 // set return value + ldp d8, d9, [sp, #(0 * 16)] + ldp d10, d11, [sp, #(1 * 16)] + ldp d12, d13, [sp, #(2 * 16)] + ldp d14, d15, [sp, #(3 * 16)] + ldp d16, d17, [sp, #(4 * 16)] + ldp x18, x19, [sp, #(5 * 16)] + ldp x20, x21, [sp, #(6 * 16)] + ldp x22, x23, [sp, #(7 * 16)] + ldp x24, x25, [sp, #(8 * 16)] + ldp x26, x27, [sp, #(9 * 16)] + ldr x28, [sp, #(10 * 16)] + add sp, sp, #(11*16) + ret + + EPILOGUE + diff --git a/kernel/generic/trsm_ltcopy_8.c b/kernel/generic/trsm_ltcopy_8.c index 9d64e263c9..35179d1853 100644 --- a/kernel/generic/trsm_ltcopy_8.c +++ b/kernel/generic/trsm_ltcopy_8.c @@ -798,7 +798,7 @@ int CNAME(BLASLONG m, BLASLONG n, FLOAT *a, BLASLONG lda, BLASLONG offset, FLOAT *(b + 1) = data02; *(b + 2) = data03; *(b + 3) = data04; - *(b + 4) = data05; + // *(b + 4) = data05; } if (ii < jj) { diff --git a/kernel/generic/zgemm_tcopy_4.c b/kernel/generic/zgemm_tcopy_4.c index 3c12a6f96e..969928d803 100644 --- a/kernel/generic/zgemm_tcopy_4.c +++ b/kernel/generic/zgemm_tcopy_4.c @@ -293,8 +293,8 @@ int CNAME(BLASLONG m, BLASLONG n, FLOAT *a, BLASLONG lda, FLOAT *b){ aoffset1 += 8; aoffset2 += 8; - aoffset3 += 8; - aoffset4 += 8; + // aoffset3 += 8; + // aoffset4 += 8; boffset1 += m * 8; i --; diff --git a/kernel/mips/KERNEL.P5600 b/kernel/mips/KERNEL.P5600 index 6835792211..9a16704d5e 100644 --- a/kernel/mips/KERNEL.P5600 +++ b/kernel/mips/KERNEL.P5600 @@ -42,15 +42,29 @@ CASUMKERNEL = ../mips/asum.c ZASUMKERNEL = ../mips/asum.c endif +ifdef HAVE_MSA +SAXPYKERNEL = ../mips/saxpy_msa.c +DAXPYKERNEL = ../mips/daxpy_msa.c +CAXPYKERNEL = ../mips/caxpy_msa.c +ZAXPYKERNEL = ../mips/zaxpy_msa.c +else SAXPYKERNEL = ../mips/axpy.c DAXPYKERNEL = ../mips/axpy.c CAXPYKERNEL = ../mips/zaxpy.c ZAXPYKERNEL = ../mips/zaxpy.c +endif +ifdef HAVE_MSA +SCOPYKERNEL = ../mips/scopy_msa.c +DCOPYKERNEL = ../mips/dcopy_msa.c +CCOPYKERNEL = ../mips/ccopy_msa.c +ZCOPYKERNEL = ../mips/zcopy_msa.c +else SCOPYKERNEL = ../mips/copy.c DCOPYKERNEL = ../mips/copy.c CCOPYKERNEL = ../mips/zcopy.c ZCOPYKERNEL = ../mips/zcopy.c +endif ifdef HAVE_MSA SDOTKERNEL = ../mips/sdot_msa.c @@ -69,20 +83,41 @@ DNRM2KERNEL = ../mips/nrm2.c CNRM2KERNEL = ../mips/znrm2.c ZNRM2KERNEL = ../mips/znrm2.c +ifdef HAVE_MSA +SROTKERNEL = ../mips/srot_msa.c +DROTKERNEL = ../mips/drot_msa.c +CROTKERNEL = ../mips/crot_msa.c +ZROTKERNEL = ../mips/zrot_msa.c +else SROTKERNEL = ../mips/rot.c DROTKERNEL = ../mips/rot.c CROTKERNEL = ../mips/zrot.c ZROTKERNEL = ../mips/zrot.c +endif +ifdef HAVE_MSA +SSCALKERNEL = ../mips/sscal_msa.c +DSCALKERNEL = ../mips/dscal_msa.c +CSCALKERNEL = ../mips/cscal_msa.c +ZSCALKERNEL = ../mips/zscal_msa.c +else SSCALKERNEL = ../mips/scal.c DSCALKERNEL = ../mips/scal.c CSCALKERNEL = ../mips/zscal.c ZSCALKERNEL = ../mips/zscal.c +endif +ifdef HAVE_MSA +SSWAPKERNEL = ../mips/sswap_msa.c +DSWAPKERNEL = ../mips/dswap_msa.c +CSWAPKERNEL = ../mips/cswap_msa.c +ZSWAPKERNEL = ../mips/zswap_msa.c +else SSWAPKERNEL = ../mips/swap.c DSWAPKERNEL = ../mips/swap.c CSWAPKERNEL = ../mips/zswap.c ZSWAPKERNEL = ../mips/zswap.c +endif ifdef HAVE_MSA SGEMVNKERNEL = ../mips/sgemv_n_msa.c diff --git a/kernel/mips/casum_msa.c b/kernel/mips/casum_msa.c index 454573d56d..6509cb2fcc 100644 --- a/kernel/mips/casum_msa.c +++ b/kernel/mips/casum_msa.c @@ -36,40 +36,67 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) BLASLONG i, inc_x2; FLOAT sumf = 0.0; v4f32 src0, src1, src2, src3, src4, src5, src6, src7; - v4f32 sum_abs0, sum_abs1, sum_abs2, sum_abs3; - v4f32 zero_v = {0}; + v4f32 src8, src9, src10, src11, src12, src13, src14, src15; + v4f32 sum_abs0 = {0, 0, 0, 0}; + v4f32 sum_abs1 = {0, 0, 0, 0}; + v4f32 sum_abs2 = {0, 0, 0, 0}; + v4f32 sum_abs3 = {0, 0, 0, 0}; v4i32 and_vec = {0x7FFFFFFF, 0x7FFFFFFF, 0x7FFFFFFF, 0x7FFFFFFF}; if (n <= 0 || inc_x <= 0) return (sumf); if (1 == inc_x) { - if (n > 15) + if (n > 31) { - n -= 16; + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 128 + 32; LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 5) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + LD_SP8_INC(x, 4, src8, src9, src10, src11, src12, src13, src14, src15); - sum_abs0 = AND_VEC_W(src0); - sum_abs1 = AND_VEC_W(src1); - sum_abs2 = AND_VEC_W(src2); - sum_abs3 = AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - sum_abs2 += AND_VEC_W(src6); - sum_abs3 += AND_VEC_W(src7); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - sum_abs2 = zero_v; - sum_abs3 = zero_v; - } + sum_abs0 += AND_VEC_W(src0); + sum_abs1 += AND_VEC_W(src1); + sum_abs2 += AND_VEC_W(src2); + sum_abs3 += AND_VEC_W(src3); + sum_abs0 += AND_VEC_W(src4); + sum_abs1 += AND_VEC_W(src5); + sum_abs2 += AND_VEC_W(src6); + sum_abs3 += AND_VEC_W(src7); + + LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); + } - for (i = (n >> 4); i--;) - { - LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + LD_SP8_INC(x, 4, src8, src9, src10, src11, src12, src13, src14, src15); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -79,13 +106,21 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); sum_abs3 += AND_VEC_W(src7); + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); } - if (n & 15) + if (n & 31) { - if ((n & 8) && (n & 4) && (n & 2)) + if (n & 16) { - LD_SP7_INC(x, 4, src0, src1, src2, src3, src4, src5, src6); + LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -94,65 +129,10 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs0 += AND_VEC_W(src4); sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if ((n & 8) && (n & 4)) - { - LD_SP6_INC(x, 4, src0, src1, src2, src3, src4, src5); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if ((n & 8) && (n & 2)) - { - LD_SP5_INC(x, 4, src0, src1, src2, src3, src4); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; + sum_abs3 += AND_VEC_W(src7); } - else if ((n & 4) && (n & 2)) - { - LD_SP3_INC(x, 4, src0, src1, src2); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if (n & 8) + if (n & 8) { LD_SP4_INC(x, 4, src0, src1, src2, src3); @@ -160,97 +140,70 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_W(src1); sum_abs2 += AND_VEC_W(src2); sum_abs3 += AND_VEC_W(src3); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } - else if (n & 4) + + if (n & 4) { LD_SP2_INC(x, 4, src0, src1); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } - else if (n & 2) + + if (n & 2) { src0 = LD_SP(x); x += 4; sum_abs0 += AND_VEC_W(src0); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else - { - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } if (n & 1) { - sumf += fabsf(*(x + 0)); + sumf += fabsf(*x); sumf += fabsf(*(x + 1)); } } - else - { - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - sumf = sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + + sumf += sum_abs0[0]; + sumf += sum_abs0[1]; + sumf += sum_abs0[2]; + sumf += sum_abs0[3]; } else { inc_x2 = 2 * inc_x; - if (n > 8) + if (n > 16) { - n -= 8; - LD_SP8_INC(x, inc_x2, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 4) - 1; i--;) + { + LD_SP8_INC(x, inc_x2, src8, src9, src10, src11, src12, src13, src14, src15); - sum_abs0 = AND_VEC_W(src0); - sum_abs1 = AND_VEC_W(src1); - sum_abs2 = AND_VEC_W(src2); - sum_abs3 = AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - sum_abs2 += AND_VEC_W(src6); - sum_abs3 += AND_VEC_W(src7); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - sum_abs2 = zero_v; - sum_abs3 = zero_v; - } + sum_abs0 += AND_VEC_W(src0); + sum_abs1 += AND_VEC_W(src1); + sum_abs2 += AND_VEC_W(src2); + sum_abs3 += AND_VEC_W(src3); + sum_abs0 += AND_VEC_W(src4); + sum_abs1 += AND_VEC_W(src5); + sum_abs2 += AND_VEC_W(src6); + sum_abs3 += AND_VEC_W(src7); + + LD_SP8_INC(x, inc_x2, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); + } - for (i = (n >> 3); i--;) - { - LD_SP8_INC(x, inc_x2, src0, src1, src2, src3, src4, src5, src6, src7); + LD_SP8_INC(x, inc_x2, src8, src9, src10, src11, src12, src13, src14, src15); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -260,13 +213,21 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); sum_abs3 += AND_VEC_W(src7); + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); } - if (n & 7) + if (n & 15) { - if ((n & 4) && (n & 2) && (n & 1)) + if (n & 8) { - LD_SP7_INC(x, inc_x2, src0, src1, src2, src3, src4, src5, src6); + LD_SP8_INC(x, inc_x2, src0, src1, src2, src3, src4, src5, src6, src7); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -275,37 +236,10 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs0 += AND_VEC_W(src4); sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); + sum_abs3 += AND_VEC_W(src7); } - else if ((n & 4) && (n & 2)) - { - LD_SP6_INC(x, inc_x2, src0, src1, src2, src3, src4, src5); - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - } - else if ((n & 4) && (n & 1)) - { - LD_SP5_INC(x, inc_x2, src0, src1, src2, src3, src4); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - } - else if ((n & 2) && (n & 1)) - { - LD_SP3_INC(x, inc_x2, src0, src1, src2); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - } - else if (n & 4) + if (n & 4) { LD_SP4_INC(x, inc_x2, src0, src1, src2, src3); @@ -314,22 +248,24 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs2 += AND_VEC_W(src2); sum_abs3 += AND_VEC_W(src3); } - else if (n & 2) + + if (n & 2) { LD_SP2_INC(x, inc_x2, src0, src1); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); } - else if (n & 1) + + if (n & 1) { - src0 = LD_SP(x); x += inc_x2; + src0 = LD_SP(x); sum_abs0 += AND_VEC_W(src0); } } - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; sumf = sum_abs0[0] + sum_abs0[1]; } diff --git a/kernel/mips/caxpy_msa.c b/kernel/mips/caxpy_msa.c new file mode 100644 index 0000000000..75b835c59f --- /dev/null +++ b/kernel/mips/caxpy_msa.c @@ -0,0 +1,471 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +#if !defined(CONJ) + #define OP0 += + #define OP1 -= + #define OP2 += +#else + #define OP0 -= + #define OP1 += + #define OP2 -= +#endif + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, + FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i, inc_x2, inc_y2; + FLOAT *py; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7; + v4f32 y0, y1, y2, y3, y4, y5, y6, y7, dar_vec, dai_vec; + v4f32 x0r, x1r, x2r, x3r, x0i, x1i, x2i, x3i; + v4f32 y0r, y1r, y2r, y3r, y0i, y1i, y2i, y3i; + FLOAT xd0, xd1, xd2, xd3, xd4, xd5, xd6, xd7; + FLOAT yd0, yd1, yd2, yd3, yd4, yd5, yd6, yd7; + + if (n < 0) return(0); + if ((da_r == 0.0) && (da_i == 0.0)) return(0); + + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 64; + + dar_vec = COPY_FLOAT_TO_VECTOR(da_r); + dai_vec = COPY_FLOAT_TO_VECTOR(da_i); + + for (i = (n >> 4); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 32; + y_pref += 32; + + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + LD_SP8_INC(py, 4, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + PCKEVOD_W2_SP(x3, x2, x1r, x1i); + PCKEVOD_W2_SP(y3, y2, y1r, y1i); + PCKEVOD_W2_SP(x5, x4, x2r, x2i); + PCKEVOD_W2_SP(y5, y4, y2r, y2i); + PCKEVOD_W2_SP(x7, x6, x3r, x3i); + PCKEVOD_W2_SP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ILVRL_W2_SP(y1i, y1r, y2, y3); + ILVRL_W2_SP(y2i, y2r, y4, y5); + ILVRL_W2_SP(y3i, y3r, y6, y7); + ST_SP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 4); + } + + if (n & 15) + { + if (n & 8) + { + LD_SP4_INC(x, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + PCKEVOD_W2_SP(x3, x2, x1r, x1i); + PCKEVOD_W2_SP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ILVRL_W2_SP(y1i, y1r, y2, y3); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + + if (n & 4) + { + LD_SP2_INC(x, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ST_SP2_INC(y0, y1, y, 4); + } + + if (n & 2) + { + LD_GP4_INC(x, 1, xd0, xd1, xd2, xd3); + LD_GP4_INC(py, 1, yd0, yd1, yd2, yd3); + + FMADD2(xd0, xd2, da_r, yd0, yd2); + yd1 OP0 da_r * xd1; + yd3 OP0 da_r * xd3; + yd0 OP1 da_i * xd1; + yd2 OP1 da_i * xd3; + yd1 OP2 da_i * xd0; + yd3 OP2 da_i * xd2; + + ST_GP4_INC(yd0, yd1, yd2, yd3, y, 1); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + else if (1 == inc_y) + { + FLOAT *y_pref; + BLASLONG pref_offset; + v4f32 x8, x9, x10, x11, x12, x13, x14; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 64; + + inc_x2 = 2 * inc_x; + + dar_vec = COPY_FLOAT_TO_VECTOR(da_r); + dai_vec = COPY_FLOAT_TO_VECTOR(da_i); + + for (i = (n >> 4); i--;) + { + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + y_pref += 32; + + LD_SP8_INC(x, inc_x2, x0, x1, x2, x3, x4, x5, x6, x14); + LD_SP7_INC(x, inc_x2, x8, x9, x10, x11, x12, x13, x7); + PCKEV_D2_SP(x1, x0, x3, x2, x0, x1); + PCKEV_D2_SP(x5, x4, x14, x6, x2, x3); + PCKEV_D2_SP(x9, x8, x11, x10, x4, x5); + x6 = (v4f32) __msa_pckev_d((v2i64) x13, (v2i64) x12); + x7 = (v4f32) __msa_insert_w((v4i32) x7, 2, *((int *) x)); + x7 = (v4f32) __msa_insert_w((v4i32) x7, 3, *((int *) (x + 1))); + x += inc_x2; + + LD_SP8_INC(py, 4, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + PCKEVOD_W2_SP(x3, x2, x1r, x1i); + PCKEVOD_W2_SP(y3, y2, y1r, y1i); + PCKEVOD_W2_SP(x5, x4, x2r, x2i); + PCKEVOD_W2_SP(y5, y4, y2r, y2i); + PCKEVOD_W2_SP(x7, x6, x3r, x3i); + PCKEVOD_W2_SP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ILVRL_W2_SP(y1i, y1r, y2, y3); + ILVRL_W2_SP(y2i, y2r, y4, y5); + ILVRL_W2_SP(y3i, y3r, y6, y7); + + ST_SP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 4); + } + + if (n & 15) + { + if (n & 8) + { + LD_SP7_INC(x, inc_x2, x0, x1, x2, x6, x4, x5, x3); + PCKEV_D2_SP(x1, x0, x6, x2, x0, x1); + + x2 = (v4f32) __msa_pckev_d((v2i64) x5, (v2i64) x4); + x3 = (v4f32) __msa_insert_w((v4i32) x3, 2, *((int *) x)); + x3 = (v4f32) __msa_insert_w((v4i32) x3, 3, *((int *) (x + 1))); + x += inc_x2; + + LD_SP4_INC(py, 4, y0, y1, y2, y3); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + PCKEVOD_W2_SP(x3, x2, x1r, x1i); + PCKEVOD_W2_SP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ILVRL_W2_SP(y1i, y1r, y2, y3); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + + if (n & 4) + { + LD_SP3_INC(x, inc_x2, x0, x2, x1); + + x0 = (v4f32) __msa_pckev_d((v2i64) x2, (v2i64) x0); + x1 = (v4f32) __msa_insert_w((v4i32) x1, 2, *((int *) x)); + x1 = (v4f32) __msa_insert_w((v4i32) x1, 3, *((int *) (x + 1))); + x += inc_x2; + + LD_SP2_INC(py, 4, y0, y1); + PCKEVOD_W2_SP(x1, x0, x0r, x0i); + PCKEVOD_W2_SP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_W2_SP(y0i, y0r, y0, y1); + ST_SP2_INC(y0, y1, y, 4); + } + + if (n & 2) + { + xd0 = x[0]; + xd1 = x[1]; + x += inc_x2; + xd2 = x[0]; + xd3 = x[1]; + x += inc_x2; + + LD_GP4_INC(py, 1, yd0, yd1, yd2, yd3); + + FMADD2(xd0, xd2, da_r, yd0, yd2); + yd1 OP0 da_r * xd1; + yd3 OP0 da_r * xd3; + yd0 OP1 da_i * xd1; + yd2 OP1 da_i * xd3; + yd1 OP2 da_i * xd0; + yd3 OP2 da_i * xd2; + + ST_GP4_INC(yd0, yd1, yd2, yd3, y, 1); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + else + { + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + for (i = (n >> 2); i--;) + { + xd0 = x[0]; + xd1 = x[1]; + x += inc_x2; + xd2 = x[0]; + xd3 = x[1]; + x += inc_x2; + xd4 = x[0]; + xd5 = x[1]; + x += inc_x2; + xd6 = x[0]; + xd7 = x[1]; + x += inc_x2; + + yd0 = py[0]; + yd1 = py[1]; + py += inc_y2; + yd2 = py[0]; + yd3 = py[1]; + py += inc_y2; + yd4 = py[0]; + yd5 = py[1]; + py += inc_y2; + yd6 = py[0]; + yd7 = py[1]; + py += inc_y2; + + FMADD4(xd0, xd2, xd4, xd6, da_r, yd0, yd2, yd4, yd6); + yd1 OP0 da_r * xd1; + yd3 OP0 da_r * xd3; + yd5 OP0 da_r * xd5; + yd7 OP0 da_r * xd7; + yd0 OP1 da_i * xd1; + yd2 OP1 da_i * xd3; + yd4 OP1 da_i * xd5; + yd6 OP1 da_i * xd7; + yd1 OP2 da_i * xd0; + yd3 OP2 da_i * xd2; + yd5 OP2 da_i * xd4; + yd7 OP2 da_i * xd6; + + y[0] = yd0; + y[1] = yd1; + y += inc_y2; + y[0] = yd2; + y[1] = yd3; + y += inc_y2; + y[0] = yd4; + y[1] = yd5; + y += inc_y2; + y[0] = yd6; + y[1] = yd7; + y += inc_y2; + } + + if (n & 3) + { + if (n & 2) + { + xd0 = x[0]; + xd1 = x[1]; + x += inc_x2; + xd2 = x[0]; + xd3 = x[1]; + x += inc_x2; + + yd0 = py[0]; + yd1 = py[1]; + py += inc_y2; + yd2 = py[0]; + yd3 = py[1]; + py += inc_y2; + + FMADD2(xd0, xd2, da_r, yd0, yd2); + yd1 OP0 da_r * xd1; + yd3 OP0 da_r * xd3; + yd0 OP1 da_i * xd1; + yd2 OP1 da_i * xd3; + yd1 OP2 da_i * xd0; + yd3 OP2 da_i * xd2; + + y[0] = yd0; + y[1] = yd1; + y += inc_y2; + y[0] = yd2; + y[1] = yd3; + y += inc_y2; + } + + if (n & 1) + { + xd0 = x[0]; + xd1 = x[1]; + + yd0 = y[0]; + yd1 = y[1]; + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + y[0] = yd0; + y[1] = yd1; + } + } + } + + return (0); +} diff --git a/kernel/mips/ccopy_msa.c b/kernel/mips/ccopy_msa.c new file mode 100644 index 0000000000..cb851f761c --- /dev/null +++ b/kernel/mips/ccopy_msa.c @@ -0,0 +1,201 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + BLASLONG i, inc_x2, inc_y2; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + FLOAT f0, f1, f2, f3, f4, f5, f6, f7; + + if (n < 0) return (0); + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n > 31) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 128 + 32; + + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 5) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + x8 = LD_SP(x); x += 4; + ST_SP(x0, y); y += 4; + x9 = LD_SP(x); x += 4; + ST_SP(x1, y); y += 4; + x10 = LD_SP(x); x += 4; + ST_SP(x2, y); y += 4; + x11 = LD_SP(x); x += 4; + ST_SP(x3, y); y += 4; + x12 = LD_SP(x); x += 4; + ST_SP(x4, y); y += 4; + x13 = LD_SP(x); x += 4; + ST_SP(x5, y); y += 4; + x14 = LD_SP(x); x += 4; + ST_SP(x6, y); y += 4; + x15 = LD_SP(x); x += 4; + ST_SP(x7, y); y += 4; + x0 = LD_SP(x); x += 4; + ST_SP(x8, y); y += 4; + x1 = LD_SP(x); x += 4; + ST_SP(x9, y); y += 4; + x2 = LD_SP(x); x += 4; + ST_SP(x10, y); y += 4; + x3 = LD_SP(x); x += 4; + ST_SP(x11, y); y += 4; + x4 = LD_SP(x); x += 4; + ST_SP(x12, y); y += 4; + x5 = LD_SP(x); x += 4; + ST_SP(x13, y); y += 4; + x6 = LD_SP(x); x += 4; + ST_SP(x14, y); y += 4; + x7 = LD_SP(x); x += 4; + ST_SP(x15, y); y += 4; + } + + x8 = LD_SP(x); x += 4; + x9 = LD_SP(x); x += 4; + ST_SP(x0, y); y += 4; + x10 = LD_SP(x); x += 4; + ST_SP(x1, y); y += 4; + x11 = LD_SP(x); x += 4; + ST_SP(x2, y); y += 4; + x12 = LD_SP(x); x += 4; + ST_SP(x3, y); y += 4; + x13 = LD_SP(x); x += 4; + ST_SP(x4, y); y += 4; + x14 = LD_SP(x); x += 4; + ST_SP(x5, y); y += 4; + x15 = LD_SP(x); x += 4; + ST_SP(x6, y); y += 4; + ST_SP(x7, y); y += 4; + + ST_SP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, y, 4); + } + + if (n & 31) + { + if (n & 16) + { + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, y, 4); + } + + if (n & 8) + { + LD_SP4_INC(x, 4, x0, x1, x2, x3); + ST_SP4_INC(x0, x1, x2, x3, y, 4); + } + + if (n & 4) + { + LD_SP2_INC(x, 4, x0, x1); + ST_SP2_INC(x0, x1, y, 4); + } + + if (n & 2) + { + LD_GP4_INC(x, 1, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, y, 1); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + } + } + else + { + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + for (i = (n >> 2); i--;) + { + f0 = *x; + f1 = *(x+1); x += inc_x2; + f2 = *x; + f3 = *(x+1); x += inc_x2; + f4 = *x; + f5 = *(x+1); x += inc_x2; + f6 = *x; + f7 = *(x+1); x += inc_x2; + + *y = f0; + *(y+1) = f1; y += inc_y2; + *y = f2; + *(y+1) = f3; y += inc_y2; + *y = f4; + *(y+1) = f5; y += inc_y2; + *y = f6; + *(y+1) = f7; y += inc_y2; + } + + if (n & 2) + { + f0 = *x; + f1 = *(x+1); x += inc_x2; + f2 = *x; + f3 = *(x+1); x += inc_x2; + + *y = f0; + *(y+1) = f1; y += inc_y2; + *y = f2; + *(y+1) = f3; y += inc_y2; + } + + if (n & 1) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + } + + return (0); +} diff --git a/kernel/mips/cdot_msa.c b/kernel/mips/cdot_msa.c index bf9f6b7e2f..0999fa08dd 100644 --- a/kernel/mips/cdot_msa.c +++ b/kernel/mips/cdot_msa.c @@ -29,333 +29,330 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "macros_msa.h" #if !defined(CONJ) - #define OP2 += - #define OP3 - - #define OP4 + + #define OP1 -= + #define OP2 += + #define OP3 - + #define OP4 + #else - #define OP2 -= - #define OP3 + - #define OP4 - + #define OP1 += + #define OP2 -= + #define OP3 + + #define OP4 - #endif -#define DOT16_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); \ - \ - dot0 += (vx2r * vy2r); \ - dot0 OPR0## = (vx2i * vy2i); \ - dot1 OPR1## = (vx2i * vy2r); \ - dot1 += (vx2r * vy2i); \ - \ - dot0 += (vx3r * vy3r); \ - dot0 OPR0## = (vx3i * vy3i); \ - dot1 OPR1## = (vx3i * vy3r); \ - dot1 += (vx3r * vy3i); - -#define DOT12_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); \ - \ - dot0 += (vx2r * vy2r); \ - dot0 OPR0## = (vx2i * vy2i); \ - dot1 OPR1## = (vx2i * vy2r); \ - dot1 += (vx2r * vy2i); - -#define DOT8_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); - -#define DOT4_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); - -/* return float, x,y float */ -/* cdotc - CONJ */ -/* cdotu - !CONJ */ -#ifndef _MSC_VER -#include -FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#else OPENBLAS_COMPLEX_FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#endif { BLASLONG i = 0; FLOAT dot[2]; - BLASLONG inc_x2; - BLASLONG inc_y2; - FLOAT x0, x1, x2, x3, x4, x5, x6, x7; - FLOAT y0, y1, y2, y3, y4, y5, y6, y7; - v4f32 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7; - v4f32 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7; - v4f32 vx0r, vx0i, vx1r, vx1i, vx2r, vx2i, vx3r, vx3i; - v4f32 vy0r, vy0i, vy1r, vy1i, vy2r, vy2i, vy3r, vy3i; + BLASLONG inc_x2, inc_y2; + FLOAT x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7, vx8, vx9, vx10, vx11; + v4f32 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7, vy8, vy9, vy10, vy11; + v4f32 vx0r, vx0i, vx1r, vx1i, vx2r, vx2i, vx3r, vx3i; + v4f32 vy0r, vy0i, vy1r, vy1i, vy2r, vy2i, vy3r, vy3i; v4f32 dot0 = {0, 0, 0, 0}; v4f32 dot1 = {0, 0, 0, 0}; - openblas_complex_float result; + v4f32 dot2 = {0, 0, 0, 0}; + v4f32 dot3 = {0, 0, 0, 0}; + v4f32 dot4 = {0, 0, 0, 0}; + v4f32 dot5 = {0, 0, 0, 0}; + v4f32 dot6 = {0, 0, 0, 0}; + v4f32 dot7 = {0, 0, 0, 0}; + OPENBLAS_COMPLEX_FLOAT result; dot[0] = 0.0; dot[1] = 0.0; - __real__(result) = 0.0; - __imag__(result) = 0.0; + CREAL(result) = 0.0; + CIMAG(result) = 0.0; - if ( n < 1 ) return(result); + if (n < 1) return (result); if ((1 == inc_x) && (1 == inc_y)) { - for (i = (n >> 4); i--;) + if (n > 15) { - LD_SP8_INC(x, 4, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); - LD_SP8_INC(y, 4, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); - - PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); - PCKEVOD_W2_SP(vx3, vx2, vx1r, vx1i); - PCKEVOD_W2_SP(vx5, vx4, vx2r, vx2i); - PCKEVOD_W2_SP(vx7, vx6, vx3r, vx3i); - - PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); - PCKEVOD_W2_SP(vy3, vy2, vy1r, vy1i); - PCKEVOD_W2_SP(vy5, vy4, vy2r, vy2i); - PCKEVOD_W2_SP(vy7, vy6, vy3r, vy3i); - - #if !defined(CONJ) - DOT16_KERNEL(-, +); - #else - DOT16_KERNEL(+, -); - #endif - } + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; - if (n & 15) - { - if ((n & 8) && (n & 4)) + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) { - LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); - LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); - LD_SP2_INC(x, 4, vx4, vx5); - LD_SP2_INC(y, 4, vy4, vy5); - - PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); - PCKEVOD_W2_SP(vx3, vx2, vx1r, vx1i); - PCKEVOD_W2_SP(vx5, vx4, vx2r, vx2i); - - PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); - PCKEVOD_W2_SP(vy3, vy2, vy1r, vy1i); - PCKEVOD_W2_SP(vy5, vy4, vy2r, vy2i); - - #if !defined(CONJ) - DOT12_KERNEL(-, +); - #else - DOT12_KERNEL(+, -); - #endif + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); } - else if (n & 8) + x_pref = x + pref_offset + 64 + 16; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) { - LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); - LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 64 + 16; - PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); - PCKEVOD_W2_SP(vx3, vx2, vx1r, vx1i); + LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); + LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); - PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); - PCKEVOD_W2_SP(vy3, vy2, vy1r, vy1i); + PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); + PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); - #if !defined(CONJ) - DOT8_KERNEL(-, +); - #else - DOT8_KERNEL(+, -); - #endif - } - else if (n & 4) + for (i = (n >> 4) - 1; i--;) { - LD_SP2_INC(x, 4, vx0, vx1); - LD_SP2_INC(y, 4, vy0, vy1); - PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); - PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); - - #if !defined(CONJ) - DOT4_KERNEL(-, +); - #else - DOT4_KERNEL(+, -); - #endif + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 32; + y_pref += 32; + + vx4 = LD_SP(x); x += 4; + vx1r = (v4f32) __msa_pckev_w((v4i32) vx3, (v4i32) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_SP(x); x += 4; + vx1i = (v4f32) __msa_pckod_w((v4i32) vx3, (v4i32) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_SP(y); y += 4; + vy1r = (v4f32) __msa_pckev_w((v4i32) vy3, (v4i32) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_SP(y); y += 4; + vy1i = (v4f32) __msa_pckod_w((v4i32) vy3, (v4i32) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_SP(x); x += 4; + vx7 = LD_SP(x); x += 4; + vy6 = LD_SP(y); y += 4; + vy7 = LD_SP(y); y += 4; + vx8 = LD_SP(x); x += 4; + dot0 OP1 (vx0i * vy0i); + vx9 = LD_SP(x); x += 4; + vx2r = (v4f32) __msa_pckev_w((v4i32) vx5, (v4i32) vx4); + dot1 += (vx0r * vy0i); + vy8 = LD_SP(y); y += 4; + vx2i = (v4f32) __msa_pckod_w((v4i32) vx5, (v4i32) vx4); + dot2 OP1 (vx1i * vy1i); + vy9 = LD_SP(y); y += 4; + vy2r = (v4f32) __msa_pckev_w((v4i32) vy5, (v4i32) vy4); + dot3 += (vx1r * vy1i); + vx10 = LD_SP(x); x += 4; + vy2i = (v4f32) __msa_pckod_w((v4i32) vy5, (v4i32) vy4); + vx11 = LD_SP(x); x += 4; + vx3r = (v4f32) __msa_pckev_w((v4i32) vx7, (v4i32) vx6); + dot4 += (vx2r * vy2r); + vy10 = LD_SP(y); y += 4; + vx3i = (v4f32) __msa_pckod_w((v4i32) vx7, (v4i32) vx6); + dot5 OP2 (vx2i * vy2r); + vy11 = LD_SP(y); y += 4; + vy3r = (v4f32) __msa_pckev_w((v4i32) vy7, (v4i32) vy6); + vy3i = (v4f32) __msa_pckod_w((v4i32) vy7, (v4i32) vy6); + dot6 += (vx3r * vy3r); + vx0r = (v4f32) __msa_pckev_w((v4i32) vx9, (v4i32) vx8); + dot7 OP2 (vx3i * vy3r); + vx0i = (v4f32) __msa_pckod_w((v4i32) vx9, (v4i32) vx8); + vy0r = (v4f32) __msa_pckev_w((v4i32) vy9, (v4i32) vy8); + vx2 = vx10; + vy0i = (v4f32) __msa_pckod_w((v4i32) vy9, (v4i32) vy8); + vx3 = vx11; + dot4 OP1 (vx2i * vy2i); + vy2 = vy10; + dot5 += (vx2r * vy2i); + vy3 = vy11; + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); } - if ((n & 2) && (n & 1)) - { - LD_GP6_INC(x, 1, x0, x1, x2, x3, x4, x5); - LD_GP6_INC(y, 1, y0, y1, y2, y3, y4, y5); + vx4 = LD_SP(x); x += 4; + vx1r = (v4f32) __msa_pckev_w((v4i32) vx3, (v4i32) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_SP(x); x += 4; + vx1i = (v4f32) __msa_pckod_w((v4i32) vx3, (v4i32) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_SP(y); y += 4; + vy1r = (v4f32) __msa_pckev_w((v4i32) vy3, (v4i32) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_SP(y); y += 4; + vy1i = (v4f32) __msa_pckod_w((v4i32) vy3, (v4i32) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_SP(x); x += 4; + vx7 = LD_SP(x); x += 4; + vy6 = LD_SP(y); y += 4; + vy7 = LD_SP(y); y += 4; + dot0 OP1 (vx0i * vy0i); + vx2r = (v4f32) __msa_pckev_w((v4i32) vx5, (v4i32) vx4); + dot1 += (vx0r * vy0i); + vx2i = (v4f32) __msa_pckod_w((v4i32) vx5, (v4i32) vx4); + dot2 OP1 (vx1i * vy1i); + vy2r = (v4f32) __msa_pckev_w((v4i32) vy5, (v4i32) vy4); + dot3 += (vx1r * vy1i); + vy2i = (v4f32) __msa_pckod_w((v4i32) vy5, (v4i32) vy4); + vx3r = (v4f32) __msa_pckev_w((v4i32) vx7, (v4i32) vx6); + dot4 += (vx2r * vy2r); + vx3i = (v4f32) __msa_pckod_w((v4i32) vx7, (v4i32) vx6); + dot5 OP2 (vx2i * vy2r); + vy3r = (v4f32) __msa_pckev_w((v4i32) vy7, (v4i32) vy6); + vy3i = (v4f32) __msa_pckod_w((v4i32) vy7, (v4i32) vy6); + dot6 += (vx3r * vy3r); + dot7 OP2 (vx3i * vy3r); + dot4 OP1 (vx2i * vy2i); + dot5 += (vx2r * vy2i); + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); + } + + if (n & 15) + { + if (n & 8) + { + LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); + LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); + + PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); + PCKEVOD_W2_SP(vx3, vx2, vx1r, vx1i); + + PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); + PCKEVOD_W2_SP(vy3, vy2, vy1r, vy1i); - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); + dot0 += (vx0r * vy0r); + dot0 OP1 (vx0i * vy0i); + dot1 OP2 (vx0i * vy0r); + dot1 += (vx0r * vy0i); - dot[0] += ( x2 * y2 OP3 x3 * y3 ); - dot[1] OP2 ( x3 * y2 OP4 x2 * y3 ); + dot2 += (vx1r * vy1r); + dot2 OP1 (vx1i * vy1i); + dot3 OP2 (vx1i * vy1r); + dot3 += (vx1r * vy1i); + } - dot[0] += ( x4 * y4 OP3 x5 * y5 ); - dot[1] OP2 ( x5 * y4 OP4 x4 * y5 ); - } - else if (n & 2) - { + if (n & 4) + { + LD_SP2_INC(x, 4, vx0, vx1); + LD_SP2_INC(y, 4, vy0, vy1); + PCKEVOD_W2_SP(vx1, vx0, vx0r, vx0i); + PCKEVOD_W2_SP(vy1, vy0, vy0r, vy0i); + + dot0 += (vx0r * vy0r); + dot0 OP1 (vx0i * vy0i); + dot1 OP2 (vx0i * vy0r); + dot1 += (vx0r * vy0i); + } + + if (n & 2) + { LD_GP4_INC(x, 1, x0, x1, x2, x3); LD_GP4_INC(y, 1, y0, y1, y2, y3); - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); + dot[0] += (x0 * y0 OP3 x1 * y1); + dot[1] OP2 (x1 * y0 OP4 x0 * y1); - dot[0] += ( x2 * y2 OP3 x3 * y3 ); - dot[1] OP2 ( x3 * y2 OP4 x2 * y3 ); - } - else if (n & 1) - { + dot[0] += (x2 * y2 OP3 x3 * y3); + dot[1] OP2 (x3 * y2 OP4 x2 * y3); + } + + if (n & 1) + { LD_GP2_INC(x, 1, x0, x1); LD_GP2_INC(y, 1, y0, y1); - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); - } + dot[0] += (x0 * y0 OP3 x1 * y1); + dot[1] OP2 (x1 * y0 OP4 x0 * y1); + } + } + + dot0 += dot2 + dot4 + dot6; + dot1 += dot3 + dot5 + dot7; + + dot[0] += (dot0[0] + dot0[1] + dot0[2] + dot0[3]); + dot[1] += (dot1[0] + dot1[1] + dot1[2] + dot1[3]); + } + else + { + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + for (i = (n >> 2); i--;) + { + x0 = *x; + x1 = *(x + 1); + x += inc_x2; + x2 = *x; + x3 = *(x + 1); + x += inc_x2; + x4 = *x; + x5 = *(x + 1); + x += inc_x2; + x6 = *x; + x7 = *(x + 1); + x += inc_x2; + + y0 = *y; + y1 = *(y + 1); + y += inc_y2; + y2 = *y; + y3 = *(y + 1); + y += inc_y2; + y4 = *y; + y5 = *(y + 1); + y += inc_y2; + y6 = *y; + y7 = *(y + 1); + y += inc_y2; + + dot[0] += (x0 * y0 OP3 x1 * y1); + dot[1] OP2 (x1 * y0 OP4 x0 * y1); + + dot[0] += (x2 * y2 OP3 x3 * y3); + dot[1] OP2 (x3 * y2 OP4 x2 * y3); + + dot[0] += (x4 * y4 OP3 x5 * y5); + dot[1] OP2 (x5 * y4 OP4 x4 * y5); + + dot[0] += (x6 * y6 OP3 x7 * y7); + dot[1] OP2 (x7 * y6 OP4 x6 * y7); } - dot[0] += (dot0[0] + dot0[1] + dot0[2] + dot0[3]); - dot[1] += (dot1[0] + dot1[1] + dot1[2] + dot1[3]); - } - else - { - inc_x2 = 2 * inc_x; - inc_y2 = 2 * inc_y; - - for (i = (n >> 2); i--;) - { - x0 = *x; - x1 = *(x + 1); - x += inc_x2; - x2 = *x; - x3 = *(x + 1); - x += inc_x2; - x4 = *x; - x5 = *(x + 1); - x += inc_x2; - x6 = *x; - x7 = *(x + 1); - x += inc_x2; - - y0 = *y; - y1 = *(y + 1); - y += inc_y2; - y2 = *y; - y3 = *(y + 1); - y += inc_y2; - y4 = *y; - y5 = *(y + 1); - y += inc_y2; - y6 = *y; - y7 = *(y + 1); - y += inc_y2; - - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); - - dot[0] += ( x2 * y2 OP3 x3 * y3 ); - dot[1] OP2 ( x3 * y2 OP4 x2 * y3 ); - - dot[0] += ( x4 * y4 OP3 x5 * y5 ); - dot[1] OP2 ( x5 * y4 OP4 x4 * y5 ); - - dot[0] += ( x6 * y6 OP3 x7 * y7 ); - dot[1] OP2 ( x7 * y6 OP4 x6 * y7 ); - } - - if ((n & 2) && (n & 1)) - { - x0 = *x; - x1 = *(x + 1); - x += inc_x2; - x2 = *x; - x3 = *(x + 1); - x += inc_x2; - x4 = *x; - x5 = *(x + 1); - x += inc_x2; - - y0 = *y; - y1 = *(y + 1); - y += inc_y2; - y2 = *y; - y3 = *(y + 1); - y += inc_y2; - y4 = *y; - y5 = *(y + 1); - y += inc_y2; - - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); - - dot[0] += ( x2 * y2 OP3 x3 * y3 ); - dot[1] OP2 ( x3 * y2 OP4 x2 * y3 ); - - dot[0] += ( x4 * y4 OP3 x5 * y5 ); - dot[1] OP2 ( x5 * y4 OP4 x4 * y5 ); - } - else if (n & 2) - { - x0 = *x; - x1 = *(x + 1); - x += inc_x2; - x2 = *x; - x3 = *(x + 1); - x += inc_x2; - - y0 = *y; - y1 = *(y + 1); - y += inc_y2; - y2 = *y; - y3 = *(y + 1); - y += inc_y2; - - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); - - dot[0] += ( x2 * y2 OP3 x3 * y3 ); - dot[1] OP2 ( x3 * y2 OP4 x2 * y3 ); - } - else if (n & 1) - { - x0 = *x; - x1 = *(x + 1); - x += inc_x2; - - y0 = *y; - y1 = *(y + 1); - y += inc_y2; - - dot[0] += ( x0 * y0 OP3 x1 * y1 ); - dot[1] OP2 ( x1 * y0 OP4 x0 * y1 ); - } - } - - __real__(result) = dot[0]; - __imag__(result) = dot[1]; - - return(result); + if (n & 2) + { + x0 = *x; + x1 = *(x + 1); + x += inc_x2; + x2 = *x; + x3 = *(x + 1); + x += inc_x2; + + y0 = *y; + y1 = *(y + 1); + y += inc_y2; + y2 = *y; + y3 = *(y + 1); + y += inc_y2; + + dot[0] += (x0 * y0 OP3 x1 * y1); + dot[1] OP2 (x1 * y0 OP4 x0 * y1); + + dot[0] += (x2 * y2 OP3 x3 * y3); + dot[1] OP2 (x3 * y2 OP4 x2 * y3); + } + + if (n & 1) + { + x0 = *x; + x1 = *(x + 1); + x += inc_x2; + + y0 = *y; + y1 = *(y + 1); + y += inc_y2; + + dot[0] += (x0 * y0 OP3 x1 * y1); + dot[1] OP2 (x1 * y0 OP4 x0 * y1); + } + } + + CREAL(result) = dot[0]; + CIMAG(result) = dot[1]; + + return (result); } diff --git a/kernel/mips/cgemm_kernel_8x4_msa.c b/kernel/mips/cgemm_kernel_8x4_msa.c index cd1fa45b37..4b3637c7c5 100644 --- a/kernel/mips/cgemm_kernel_8x4_msa.c +++ b/kernel/mips/cgemm_kernel_8x4_msa.c @@ -1082,7 +1082,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, - FLOAT* A, FLOAT* B, FLOAT* C, BLASLONG ldc + FLOAT *A, FLOAT *B, FLOAT *C, BLASLONG ldc #ifdef TRMMKERNEL , BLASLONG offset #endif @@ -1092,18 +1092,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #if defined(TRMMKERNEL) BLASLONG off; #endif - FLOAT *pc0, *pc1, *pc2, *pc3; - FLOAT *pa0, *pb0; + FLOAT *pc0, *pc1, *pc2, *pc3, *pa0, *pb0; FLOAT res0, res1, res2, res3, res4, res5, res6, res7; FLOAT res8, res9, res10, res11, res12, res13, res14, res15; - FLOAT a0_r, a1_r; - FLOAT a0_i, a1_i; + FLOAT a0_r, a1_r, a0_i, a1_i, b0_i, b1_i, b2_i, b3_i; FLOAT b0_r, b1_r, b2_r, b3_r; - FLOAT b0_i, b1_i, b2_i, b3_i; v4f32 src_a0, src_a1, src_a2, src_a3, src_b0, src_b1; v4f32 src_a0r, src_a0i, src_a1r, src_a1i, src_br, src_bi; - v4f32 dst0, dst1, dst2, dst3; - v4f32 alpha_r, alpha_i; + v4f32 dst0, dst1, dst2, dst3, alpha_r, alpha_i; v4f32 res0_r, res0_i, res1_r, res1_i, res2_r, res2_i, res3_r, res3_i; v4f32 res4_r, res4_i, res5_r, res5_i, res6_r, res6_i, res7_r, res7_i; v4f32 dst0_r, dst0_i, dst1_r, dst1_i; @@ -1122,12 +1118,12 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, pc2 = pc1 + 2 * ldc; pc3 = pc2 + 2 * ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -1150,6 +1146,17 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, temp = k; #endif +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 32(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) CGEMM_KERNEL_8X4_MSA(, -, , +, +); #endif @@ -1165,6 +1172,17 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, for (l = (temp - 1); l--;) { +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 32(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) CGEMM_KERNEL_8X4_MSA(+, -, +, +,); #endif @@ -1340,6 +1358,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_2X4 #endif + pc0 += 4; + pc1 += 4; + pc2 += 4; + pc3 += 4; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1357,11 +1379,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 2; // number of values in A #endif #endif - - pc0 += 4; - pc1 += 4; - pc2 += 4; - pc3 += 4; } if (m & 1) @@ -1426,6 +1443,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_1X4 #endif + pc0 += 2; + pc1 += 2; + pc2 += 2; + pc3 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1443,21 +1464,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; - pc2 += 2; - pc3 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 4; // number of values in A #endif - l = k << 3; - B = B + l; - i = ldc << 3; - C = C + i; + B += (k << 3); + C += (ldc << 3); } if (n & 2) @@ -1465,12 +1479,12 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, pc0 = C; pc1 = pc0 + 2 * ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -1691,6 +1705,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_2X2 #endif + pc0 += 4; + pc1 += 4; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1708,9 +1724,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 2; // number of values in A #endif #endif - - pc0 += 4; - pc1 += 4; } if (m & 1) @@ -1775,6 +1788,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_1X2 #endif + pc0 += 2; + pc1 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1792,30 +1807,26 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 2; // number of values in A #endif - l = k << 2; - B = B + l; - i = ldc << 2; - C = C + i; + B += (k << 2); + C += (ldc << 2); } if (n & 1) { pc0 = C; - pa0 = A; #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -2036,6 +2047,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_2X1 #endif + pc0 += 4; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -2053,8 +2065,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 2; // number of values in A #endif #endif - - pc0 += 4; } if (m & 1) @@ -2119,6 +2129,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else CGEMM_SCALE_1X1 #endif + pc0 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -2136,18 +2147,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 1; // number of values in A #endif - l = k << 1; - B = B + l; - i = ldc << 1; - C = C + i; + B += (k << 1); + C += (ldc << 1); } return 0; diff --git a/kernel/mips/cgemv_n_msa.c b/kernel/mips/cgemv_n_msa.c index f1879ba003..a9db04aafa 100644 --- a/kernel/mips/cgemv_n_msa.c +++ b/kernel/mips/cgemv_n_msa.c @@ -376,128 +376,139 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *((int *)(y + 2 * inc_y2 + 1)) = __msa_copy_s_w((v4i32) y0i, 2); \ *((int *)(y + 3 * inc_y2 + 1)) = __msa_copy_s_w((v4i32) y0i, 3); \ -#define CGEMV_N_MSA() \ - for (j = (n >> 2); j--;) \ - { \ - CLOAD_X4_SCALE(); \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = (m >> 3); i--;) \ - { \ - CLOAD_Y8() \ - CGEMV_N_8x4(); \ - CSTORE_Y8(); \ - \ - k += 2 * 8; \ - y += inc_y2 * 8; \ - } \ - \ - if (m & 4) \ - { \ - CLOAD_Y4(); \ - CGEMV_N_4x4(); \ - CSTORE_Y4(); \ - \ - k += 2 * 4; \ - y += inc_y2 * 4; \ - } \ - \ - if (m & 3) \ - { \ - temp0_r = tp4r[0]; \ - temp1_r = tp4r[1]; \ - temp2_r = tp4r[2]; \ - temp3_r = tp4r[3]; \ - \ - temp0_i = tp4i[0]; \ - temp1_i = tp4i[1]; \ - temp2_i = tp4i[2]; \ - temp3_i = tp4i[3]; \ - \ - for (i = (m & 3); i--;) \ - { \ - CGEMV_N_1x4(); \ - \ - k += 2; \ - y += inc_y2; \ - } \ - } \ - \ - pa0 += 4 * lda2; \ - pa1 += 4 * lda2; \ - pa2 += 4 * lda2; \ - pa3 += 4 * lda2; \ - \ - x += 4 * inc_x2; \ - } \ - \ - if (n & 2) \ - { \ - CLOAD_X2_SCALE(); \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = (m >> 3); i--;) \ - { \ - CLOAD_Y8(); \ - CGEMV_N_8x2(); \ - CSTORE_Y8(); \ - \ - k += 2 * 8; \ - y += inc_y2 * 8; \ - } \ - \ - if (m & 4) \ - { \ - CLOAD_Y4(); \ - CGEMV_N_4x2(); \ - CSTORE_Y4(); \ - \ - k += 2 * 4; \ - y += inc_y2 * 4; \ - } \ - \ - for (i = (m & 3); i--;) \ - { \ - CGEMV_N_1x2(); \ - \ - k += 2; \ - y += inc_y2; \ - } \ - \ - pa0 += 2 * lda2; \ - pa1 += 2 * lda2; \ - \ - x += 2 * inc_x2; \ - } \ - \ - if (n & 1) \ - { \ - CLOAD_X1_SCALE(); \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = m; i--;) \ - { \ - CGEMV_N_1x1(); \ - \ - k += 2; \ - y += inc_y2; \ - } \ - \ - pa0 += lda2; \ - x += inc_x2; \ - } \ +#define CGEMV_N_MSA() \ + for (j = (n >> 2); j--;) \ + { \ + CLOAD_X4_SCALE(); \ + \ + k = 0; \ + k_pref = pref_offset; \ + y = y_org; \ + \ + for (i = (m >> 3); i--;) \ + { \ + PREFETCH(pa0 + k_pref + 16 + 0); \ + PREFETCH(pa0 + k_pref + 16 + 8); \ + PREFETCH(pa1 + k_pref + 16 + 0); \ + PREFETCH(pa1 + k_pref + 16 + 8); \ + PREFETCH(pa2 + k_pref + 16 + 0); \ + PREFETCH(pa2 + k_pref + 16 + 8); \ + PREFETCH(pa3 + k_pref + 16 + 0); \ + PREFETCH(pa3 + k_pref + 16 + 8); \ + \ + CLOAD_Y8() \ + CGEMV_N_8x4(); \ + CSTORE_Y8(); \ + \ + k += 2 * 8; \ + k_pref += 2 * 8; \ + y += inc_y2 * 8; \ + } \ + \ + if (m & 4) \ + { \ + CLOAD_Y4(); \ + CGEMV_N_4x4(); \ + CSTORE_Y4(); \ + \ + k += 2 * 4; \ + y += inc_y2 * 4; \ + } \ + \ + if (m & 3) \ + { \ + temp0_r = tp4r[0]; \ + temp1_r = tp4r[1]; \ + temp2_r = tp4r[2]; \ + temp3_r = tp4r[3]; \ + \ + temp0_i = tp4i[0]; \ + temp1_i = tp4i[1]; \ + temp2_i = tp4i[2]; \ + temp3_i = tp4i[3]; \ + \ + for (i = (m & 3); i--;) \ + { \ + CGEMV_N_1x4(); \ + \ + k += 2; \ + y += inc_y2; \ + } \ + } \ + \ + pa0 += 4 * lda2; \ + pa1 += 4 * lda2; \ + pa2 += 4 * lda2; \ + pa3 += 4 * lda2; \ + \ + x += 4 * inc_x2; \ + } \ + \ + if (n & 2) \ + { \ + CLOAD_X2_SCALE(); \ + \ + k = 0; \ + y = y_org; \ + \ + for (i = (m >> 3); i--;) \ + { \ + CLOAD_Y8(); \ + CGEMV_N_8x2(); \ + CSTORE_Y8(); \ + \ + k += 2 * 8; \ + y += inc_y2 * 8; \ + } \ + \ + if (m & 4) \ + { \ + CLOAD_Y4(); \ + CGEMV_N_4x2(); \ + CSTORE_Y4(); \ + \ + k += 2 * 4; \ + y += inc_y2 * 4; \ + } \ + \ + for (i = (m & 3); i--;) \ + { \ + CGEMV_N_1x2(); \ + \ + k += 2; \ + y += inc_y2; \ + } \ + \ + pa0 += 2 * lda2; \ + pa1 += 2 * lda2; \ + \ + x += 2 * inc_x2; \ + } \ + \ + if (n & 1) \ + { \ + CLOAD_X1_SCALE(); \ + \ + k = 0; \ + y = y_org; \ + \ + for (i = m; i--;) \ + { \ + CGEMV_N_1x1(); \ + \ + k += 2; \ + y += inc_y2; \ + } \ + \ + pa0 += lda2; \ + x += inc_x2; \ + } \ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha_r, FLOAT alpha_i, FLOAT *A, BLASLONG lda2, FLOAT *x, BLASLONG inc_x2, FLOAT *y, BLASLONG inc_y2, FLOAT *buffer) { - BLASLONG i, j, k; + BLASLONG i, j, k, k_pref, pref_offset; FLOAT *y_org = y; FLOAT *pa0, *pa1, *pa2, *pa3; FLOAT temp_r, temp_i, res0, res1, temp0_r; @@ -513,6 +524,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha_r, FLOAT alpha_i, inc_x2 = 2 * inc_x2; inc_y2 = 2 * inc_y2; + pref_offset = (uintptr_t)A & (L1_DATA_LINESIZE - 1); + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + pa0 = A; pa1 = A + lda2; pa2 = A + 2 * lda2; diff --git a/kernel/mips/cgemv_t_msa.c b/kernel/mips/cgemv_t_msa.c index b9620bfb90..584e3de75c 100644 --- a/kernel/mips/cgemv_t_msa.c +++ b/kernel/mips/cgemv_t_msa.c @@ -364,14 +364,25 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tp0i = tp1i = tp2i = tp3i = zero; \ \ k = 0; \ + k_pref = pref_offset; \ x = srcx_org; \ \ for (i = (m >> 3); i--;) \ { \ + PREFETCH(pa0 + k_pref + 16 + 0); \ + PREFETCH(pa0 + k_pref + 16 + 8); \ + PREFETCH(pa1 + k_pref + 16 + 0); \ + PREFETCH(pa1 + k_pref + 16 + 8); \ + PREFETCH(pa2 + k_pref + 16 + 0); \ + PREFETCH(pa2 + k_pref + 16 + 8); \ + PREFETCH(pa3 + k_pref + 16 + 0); \ + PREFETCH(pa3 + k_pref + 16 + 8); \ + \ CLOAD_X8() \ CGEMV_T_8x4(); \ \ k += 2 * 8; \ + k_pref += 2 * 8; \ x += inc_x2 * 8; \ } \ \ @@ -531,7 +542,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alphar, FLOAT alphai, FLOAT *A, BLASLONG lda, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *buffer) { - BLASLONG i, j, k; + BLASLONG i, j, k, k_pref, pref_offset; FLOAT *pa0, *pa1, *pa2, *pa3; FLOAT *srcx_org = x; FLOAT temp0r, temp0i, temp2r, temp2i, temp1r, temp1i, temp3r, temp3i; @@ -546,6 +557,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alphar, FLOAT alphai, lda2 = 2 * lda; + pref_offset = (uintptr_t)A & (L1_DATA_LINESIZE - 1); + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + pa0 = A; pa1 = A + lda2; pa2 = A + 2 * lda2; diff --git a/kernel/mips/crot_msa.c b/kernel/mips/crot_msa.c new file mode 100644 index 0000000000..5273e38a37 --- /dev/null +++ b/kernel/mips/crot_msa.c @@ -0,0 +1,1072 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, + FLOAT c, FLOAT s) +{ + BLASLONG i, j; + FLOAT *px, *py; + FLOAT tp0, tp1, tp2, tp3, tp4, tp5, tp6, tp7; + FLOAT fx0, fx1, fx2, fx3, fy0, fy1, fy2, fy3; + BLASLONG inc_x2, inc_y2; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 out0, out1, out2, out3, out4, out5, out6, out7; + v4f32 out8, out9, out10, out11, out12, out13, out14, out15, c0, s0; + + if (n <= 0) return (0); + + px = x; + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + if ((0 == c) && (0 == s)) + { + v4f32 zero = __msa_cast_to_vector_float(0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 0, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 1, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 2, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 3, 0.0); + + /* process 2 elements */ + for (j = (n >> 1); j--;) + { + ST_SP(zero, px); + ST_SP(zero, py); + + px += 4; + py += 4; + } + if (n & 1) + { + px[0] = 0; + px[1] = 0; + py[0] = 0; + py[1] = 0; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + x0 = LD_SP(px); px += 4; + x1 = LD_SP(px); px += 4; + x2 = LD_SP(px); px += 4; + x3 = LD_SP(px); px += 4; + y0 = LD_SP(py); py += 4; + y1 = LD_SP(py); py += 4; + y2 = LD_SP(py); py += 4; + y3 = LD_SP(py); py += 4; + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + out0 = x0 + y0; + x4 = LD_SP(px); px += 4; + out1 = y0 - x0; + x5 = LD_SP(px); px += 4; + out2 = x1 + y1; + x6 = LD_SP(px); px += 4; + out3 = y1 - x1; + x7 = LD_SP(px); px += 4; + out4 = x2 + y2; + y4 = LD_SP(py); py += 4; + out5 = y2 - x2; + y5 = LD_SP(py); py += 4; + out6 = x3 + y3; + y6 = LD_SP(py); py += 4; + out7 = y3 - x3; + y7 = LD_SP(py); py += 4; + + ST_SP(out0, x); x += 4; + out8 = x4 + y4; + ST_SP(out1, y); y += 4; + out9 = y4 - x4; + ST_SP(out2, x); x += 4; + out10 = x5 + y5; + ST_SP(out3, y); y += 4; + out11 = y5 - x5; + ST_SP(out4, x); x += 4; + out12 = x6 + y6; + ST_SP(out5, y); y += 4; + out13 = y6 - x6; + ST_SP(out6, x); x += 4; + out14 = x7 + y7; + ST_SP(out7, y); y += 4; + out15 = y7 - x7; + + x0 = LD_SP(px); px += 4; + ST_SP(out8, x); x += 4; + x1 = LD_SP(px); px += 4; + ST_SP(out10, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(out12, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(out14, x); x += 4; + + y0 = LD_SP(py); py += 4; + ST_SP(out9, y); y += 4; + y1 = LD_SP(py); py += 4; + ST_SP(out11, y); y += 4; + y2 = LD_SP(py); py += 4; + ST_SP(out13, y); y += 4; + y3 = LD_SP(py); py += 4; + ST_SP(out15, y); y += 4; + } + + x4 = LD_SP(px); px += 4; + x5 = LD_SP(px); px += 4; + x6 = LD_SP(px); px += 4; + x7 = LD_SP(px); px += 4; + y4 = LD_SP(py); py += 4; + y5 = LD_SP(py); py += 4; + y6 = LD_SP(py); py += 4; + y7 = LD_SP(py); py += 4; + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + out8 = x4 + y4; + out9 = y4 - x4; + out10 = x5 + y5; + out11 = y5 - x5; + out12 = x6 + y6; + out13 = y6 - x6; + out14 = x7 + y7; + out15 = y7 - x7; + + ST_SP8_INC(out0, out2, out4, out6, out8, out10, out12, out14, x, 4); + ST_SP8_INC(out1, out3, out5, out7, out9, out11, out13, out15, y, 4); + } + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 2) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + out0 = x0 + y0; + out1 = y0 - x0; + + ST_SP(out0, x); + ST_SP(out1, y); + x += 4; + y += 4; + } + if (n & 1) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + } + else if (0 == s) + { + + c0 = COPY_FLOAT_TO_VECTOR(c); + + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + y0 = LD_SP(py); py += 4; + x0 *= c0; + y1 = LD_SP(py); py += 4; + x1 *= c0; + y2 = LD_SP(py); py += 4; + x2 *= c0; + y3 = LD_SP(py); py += 4; + x3 *= c0; + y4 = LD_SP(py); py += 4; + x4 *= c0; + y5 = LD_SP(py); py += 4; + x5 *= c0; + y6 = LD_SP(py); py += 4; + x6 *= c0; + y7 = LD_SP(py); py += 4; + x7 *= c0; + + ST_SP(x0, x); x += 4; + y0 *= c0; + ST_SP(x1, x); x += 4; + y1 *= c0; + ST_SP(x2, x); x += 4; + y2 *= c0; + ST_SP(x3, x); x += 4; + y3 *= c0; + ST_SP(x4, x); x += 4; + y4 *= c0; + ST_SP(x5, x); x += 4; + y5 *= c0; + ST_SP(x6, x); x += 4; + y6 *= c0; + ST_SP(x7, x); x += 4; + y7 *= c0; + + x0 = LD_SP(px); px += 4; + ST_SP(y0, y); y += 4; + x1 = LD_SP(px); px += 4; + ST_SP(y1, y); y += 4; + x2 = LD_SP(px); px += 4; + ST_SP(y2, y); y += 4; + x3 = LD_SP(px); px += 4; + ST_SP(y3, y); y += 4; + x4 = LD_SP(px); px += 4; + ST_SP(y4, y); y += 4; + x5 = LD_SP(px); px += 4; + ST_SP(y5, y); y += 4; + x6 = LD_SP(px); px += 4; + ST_SP(y6, y); y += 4; + x7 = LD_SP(px); px += 4; + ST_SP(y7, y); y += 4; + } + + LD_SP8_INC(py, 4, y0, y1, y2, y3, y4, y5, y6, y7); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + x2 *= c0; + y2 *= c0; + x3 *= c0; + y3 *= c0; + x4 *= c0; + y4 *= c0; + x5 *= c0; + y5 *= c0; + x6 *= c0; + y6 *= c0; + x7 *= c0; + y7 *= c0; + + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 4); + ST_SP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 4); + } + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + x2 *= c0; + y2 *= c0; + x3 *= c0; + y3 *= c0; + + ST_SP4_INC(x0, x1, x2, x3, x, 4); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + + ST_SP2_INC(x0, x1, x, 4); + ST_SP2_INC(y0, y1, y, 4); + } + if (n & 2) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + x0 *= c0; + y0 *= c0; + + ST_SP(x0, x); + ST_SP(y0, y); + x += 4; + y += 4; + } + if (n & 1) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = (c * fx0); + tp1 = (c * fy0); + tp2 = (c * fx1); + tp3 = (c * fy1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + } + else if (0 == c) + { + s0 = COPY_FLOAT_TO_VECTOR(s); + + /* process 16 floats */ + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + x4 = LD_SP(px); px += 4; + out0 = s0 * y0; + x5 = LD_SP(px); px += 4; + out2 = s0 * y1; + x6 = LD_SP(px); px += 4; + out4 = s0 * y2; + x7 = LD_SP(px); px += 4; + out6 = s0 * y3; + y4 = LD_SP(py); py += 4; + out1 = -(s0 * x0); + y5 = LD_SP(py); py += 4; + out3 = -(s0 * x1); + y6 = LD_SP(py); py += 4; + out5 = -(s0 * x2); + y7 = LD_SP(py); py += 4; + out7 = -(s0 * x3); + + ST_SP(out0, x); x += 4; + out0 = s0 * y4; + ST_SP(out2, x); x += 4; + out2 = s0 * y5; + ST_SP(out4, x); x += 4; + out4 = s0 * y6; + ST_SP(out6, x); x += 4; + out6 = s0 * y7; + ST_SP(out1, y); y += 4; + out1 = -(s0 * x4); + ST_SP(out3, y); y += 4; + out3 = -(s0 * x5); + ST_SP(out5, y); y += 4; + out5 = -(s0 * x6); + ST_SP(out7, y); y += 4; + out7 = -(s0 * x7); + + x0 = LD_SP(px); px += 4; + ST_SP(out0, x); x += 4; + x1 = LD_SP(px); px += 4; + ST_SP(out2, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(out4, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(out6, x); x += 4; + y0 = LD_SP(py); py += 4; + ST_SP(out1, y); y += 4; + y1 = LD_SP(py); py += 4; + ST_SP(out3, y); y += 4; + y2 = LD_SP(py); py += 4; + ST_SP(out5, y); y += 4; + y3 = LD_SP(py); py += 4; + ST_SP(out7, y); y += 4; + } + + out0 = s0 * y0; + out2 = s0 * y1; + out4 = s0 * y2; + out6 = s0 * y3; + out1 = -(s0 * x0); + out3 = -(s0 * x1); + out5 = -(s0 * x2); + out7 = -(s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + + LD_SP4_INC(px, 4, x4, x5, x6, x7); + LD_SP4_INC(py, 4, y4, y5, y6, y7); + + out0 = s0 * y4; + out2 = s0 * y5; + out4 = s0 * y6; + out6 = s0 * y7; + out1 = -(s0 * x4); + out3 = -(s0 * x5); + out5 = -(s0 * x6); + out7 = -(s0 * x7); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + out4 = s0 * y2; + out5 = - (s0 * x2); + out6 = s0 * y3; + out7 = - (s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 2) + { + x0 = LD_SP(px); px += 4; + y0 = LD_SP(py); py += 4; + + out0 = s0 * y0; + out1 = - (s0 * x0); + + ST_SP(out0, x); x += 4; + ST_SP(out1, y); y += 4; + } + if (n & 1) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = s * fy0; + tp1 = - (s * fx0); + tp2 = s * fy1; + tp3 = - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + } + else + { + c0 = COPY_FLOAT_TO_VECTOR(c); + s0 = COPY_FLOAT_TO_VECTOR(s); + + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + x4 = LD_SP(px); px += 4; + out0 = c0 * x0; + x5 = LD_SP(px); px += 4; + out1 = c0 * y0; + x6 = LD_SP(px); px += 4; + out2 = c0 * x1; + x7 = LD_SP(px); px += 4; + out3 = c0 * y1; + y4 = LD_SP(py); py += 4; + out4 = c0 * x2; + y5 = LD_SP(py); py += 4; + out5 = c0 * y2; + y6 = LD_SP(py); py += 4; + out6 = c0 * x3; + y7 = LD_SP(py); py += 4; + out7 = c0 * y3; + + out0 += s0 * y0; + out1 -= s0 * x0; + out2 += s0 * y1; + out3 -= s0 * x1; + out4 += s0 * y2; + out5 -= s0 * x2; + out6 += s0 * y3; + out7 -= s0 * x3; + + ST_SP(out0, x); x += 4; + out8 = c0 * x4; + ST_SP(out2, x); x += 4; + out9 = c0 * y4; + ST_SP(out4, x); x += 4; + out10 = c0 * x5; + ST_SP(out6, x); x += 4; + out11 = c0 * y5; + ST_SP(out1, y); y += 4; + out12 = c0 * x6; + ST_SP(out3, y); y += 4; + out13 = c0 * y6; + ST_SP(out5, y); y += 4; + out14 = c0 * x7; + ST_SP(out7, y); y += 4; + out15 = c0 * y7; + + x0 = LD_SP(px); px += 4; + out8 += s0 * y4; + x1 = LD_SP(px); px += 4; + out9 -= s0 * x4; + x2 = LD_SP(px); px += 4; + out10 += s0 * y5; + x3 = LD_SP(px); px += 4; + out11 -= s0 * x5; + y0 = LD_SP(py); py += 4; + out12 += s0 * y6; + y1 = LD_SP(py); py += 4; + out13 -= s0 * x6; + y2 = LD_SP(py); py += 4; + out14 += s0 * y7; + y3 = LD_SP(py); py += 4; + out15 -= s0 * x7; + + ST_SP(out8, x); x += 4; + ST_SP(out10, x); x += 4; + ST_SP(out12, x); x += 4; + ST_SP(out14, x); x += 4; + ST_SP(out9, y); y += 4; + ST_SP(out11, y); y += 4; + ST_SP(out13, y); y += 4; + ST_SP(out15, y); y += 4; + } + + out0 = c0 * x0; + out0 += s0 * y0; + out1 = c0 * y0; + out1 -= s0 * x0; + out2 = c0 * x1; + out2 += s0 * y1; + out3 = c0 * y1; + out3 -= s0 * x1; + out4 = c0 * x2; + out4 += s0 * y2; + out5 = c0 * y2; + out5 -= s0 * x2; + out6 = c0 * x3; + out6 += s0 * y3; + out7 = c0 * y3; + out7 -= s0 * x3; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + + LD_SP4_INC(px, 4, x4, x5, x6, x7); + LD_SP4_INC(py, 4, y4, y5, y6, y7); + + out8 = c0 * x4; + out8 += s0 * y4; + out9 = c0 * y4; + out9 -= s0 * x4; + out10 = c0 * x5; + out10 += s0 * y5; + out11 = c0 * y5; + out11 -= s0 * x5; + out12 = c0 * x6; + out12 += s0 * y6; + out13 = c0 * y6; + out13 -= s0 * x6; + out14 = c0 * x7; + out14 += s0 * y7; + out15 = c0 * y7; + out15 -= s0 * x7; + + ST_SP4_INC(out8, out10, out12, out14, x, 4); + ST_SP4_INC(out9, out11, out13, out15, y, 4); + } + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + out4 = (c0 * x2) + (s0 * y2); + out5 = (c0 * y2) - (s0 * x2); + out6 = (c0 * x3) + (s0 * y3); + out7 = (c0 * y3) - (s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 2) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + + ST_SP(out0, x); + ST_SP(out1, y); + x += 4; + y += 4; + } + if (n & 1) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = (c * fx0) + (s * fy0); + tp1 = (c * fy0) - (s * fx0); + tp2 = (c * fx1) + (s * fy1); + tp3 = (c * fy1) - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + } + } + else + { + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + if ((0 == c) && (0 == s)) + { + for (i = n; i--;) + { + *x = 0; + *(x + 1) = 0; + *y = 0; + *(y + 1) = 0; + + x += inc_x2; + y += inc_y2; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 1) + { + fx0 = *px; + fx1 = *(px+1); px += inc_x2; + fx2 = *px; + fx3 = *(px+1); px += inc_x2; + + fy0 = *py; + fy1 = *(py+1); py += inc_y2; + fy2 = *py; + fy3 = *(py+1); py += inc_y2; + + for (i = (n >> 1) - 1; i--;) + { + tp0 = fx0 + fy0; + tp1 = fx1 + fy1; + tp2 = fy0 - fx0; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fx3 + fy3; + tp6 = fy2 - fx2; + tp7 = fy3 - fx3; + + fx0 = *px; + *x = tp0; + fx1 = *(px+1); px += inc_x2; + *(x+1) = tp1; x += inc_x2; + fx2 = *px; + *x = tp4; + fx3 = *(px+1); px += inc_x2; + *(x+1) = tp5; x += inc_x2; + + fy0 = *py; + *y = tp2; + fy1 = *(py+1); py += inc_y2; + *(y+1) = tp3; y += inc_y2; + fy2 = *py; + *y = tp6; + fy3 = *(py+1); py += inc_y2; + *(y+1) = tp7; y += inc_y2; + } + + tp0 = fx0 + fy0; + tp1 = fx1 + fy1; + tp2 = fy0 - fx0; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fx3 + fy3; + tp6 = fy2 - fx2; + tp7 = fy3 - fx3; + + *x = tp0; + *(x+1) = tp1; x += inc_x2; + *x = tp4; + *(x+1) = tp5; x += inc_x2; + + *y = tp2; + *(y+1) = tp3; y += inc_y2; + *y = tp6; + *(y+1) = tp7; y += inc_y2; + } + if (n & 1) + { + fx0 = *px; + fx1 = *(px+1); + + fy0 = *py; + fy1 = *(py+1); + + tp0 = fx0 + fy0; + tp1 = fx1 + fy1; + tp2 = fy0 - fx0; + tp3 = fy1 - fx1; + + *x = tp0; + *(x+1) = tp1; + + *y = tp2; + *(y+1) = tp3; + } + } + else if (0 == s) + { + if (n >> 1) + { + fx0 = *px; + fx1 = *(px+1); px += inc_x2; + fx2 = *px; + fx3 = *(px+1); px += inc_x2; + + fy0 = *py; + fy1 = *(py+1); py += inc_y2; + fy2 = *py; + fy3 = *(py+1); py += inc_y2; + + for (i = (n >> 1) - 1; i--;) + { + tp0 = c * fx0; + tp1 = c * fx1; + tp2 = c * fx2; + tp3 = c * fx3; + tp4 = c * fy0; + tp5 = c * fy1; + tp6 = c * fy2; + tp7 = c * fy3; + + fx0 = *px; + *x = tp0; + fx1 = *(px+1); px += inc_x2; + *(x+1) = tp1; x += inc_x2; + fx2 = *px; + *x = tp2; + fx3 = *(px+1); px += inc_x2; + *(x+1) = tp3; x += inc_x2; + fy0 = *py; + *y = tp4; + fy1 = *(py+1); py += inc_y2; + *(y+1) = tp5; y += inc_y2; + fy2 = *py; + *y = tp6; + fy3 = *(py+1); py += inc_y2; + *(y+1) = tp7; y += inc_y2; + } + + tp0 = c * fx0; + tp1 = c * fx1; + tp2 = c * fx2; + tp3 = c * fx3; + tp4 = c * fy0; + tp5 = c * fy1; + tp6 = c * fy2; + tp7 = c * fy3; + + *x = tp0; + *(x+1) = tp1; x += inc_x2; + *x = tp2; + *(x+1) = tp3; x += inc_x2; + + *y = tp4; + *(y+1) = tp5; y += inc_y2; + *y = tp6; + *(y+1) = tp7; y += inc_y2; + } + if (n & 1) + { + fx0 = *px; + fx1 = *(px+1); + + fy0 = *py; + fy1 = *(py+1); + + tp0 = c * fx0; + tp1 = c * fx1; + tp2 = c * fy0; + tp3 = c * fy1; + + *x = tp0; + *(x+1) = tp1; + + *y = tp2; + *(y+1) = tp3; + } + } + else + { + if (n >> 1) + { + fx0 = *px; + fx1 = *(px+1); px += inc_x2; + fx2 = *px; + fx3 = *(px+1); px += inc_x2; + fy0 = *py; + fy1 = *(py+1); py += inc_y2; + fy2 = *py; + fy3 = *(py+1); py += inc_y2; + + for (i = (n >> 1) - 1; i--;) + { + tp0 = c * fx0 + s * fy0; + tp1 = c * fx1 + s * fy1; + tp2 = c * fy0 - s * fx0; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fx3 + s * fy3; + tp6 = c * fy2 - s * fx2; + tp7 = c * fy3 - s * fx3; + + fx0 = *px; + *x = tp0; + fx1 = *(px+1); px += inc_x2; + *(x+1) = tp1; x += inc_x2; + fx2 = *px; + *x = tp4; + fx3 = *(px+1); px += inc_x2; + *(x+1) = tp5; x += inc_x2; + fy0 = *py; + *y = tp2; + fy1 = *(py+1); py += inc_y2; + *(y+1) = tp3; y += inc_y2; + fy2 = *py; + *y = tp6; + fy3 = *(py+1); py += inc_y2; + *(y+1) = tp7; y += inc_y2; + } + + tp0 = c * fx0 + s * fy0; + tp1 = c * fx1 + s * fy1; + tp2 = c * fy0 - s * fx0; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fx3 + s * fy3; + tp6 = c * fy2 - s * fx2; + tp7 = c * fy3 - s * fx3; + + *x = tp0; + *(x+1) = tp1; x += inc_x2; + *x = tp4; + *(x+1) = tp5; x += inc_x2; + *y = tp2; + *(y+1) = tp3; y += inc_y2; + *y = tp6; + *(y+1) = tp7; y += inc_y2; + } + if (n & 1) + { + fx0 = *px; + fx1 = *(px+1); + + fy0 = *py; + fy1 = *(py+1); + + tp0 = c * fx0 + s * fy0; + tp1 = c * fx1 + s * fy1; + tp2 = c * fy0 - s * fx0; + tp3 = c * fy1 - s * fx1; + + *x = tp0; + *(x+1) = tp1; + + *y = tp2; + *(y+1) = tp3; + } + } + } + + return 0; +} diff --git a/kernel/mips/cscal_msa.c b/kernel/mips/cscal_msa.c new file mode 100644 index 0000000000..11a1450cf9 --- /dev/null +++ b/kernel/mips/cscal_msa.c @@ -0,0 +1,1012 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +/* This will shuffle the elements in 'in' vector as (mask needed :: 10 11 00 01) + 0 1 2 3 => 1 0 3 2 */ +#define SHF_177 177 + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, + FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i, inc_x2; + FLOAT *px; + FLOAT tp0, tp1, tp2, tp3, f0, f1, f2, f3; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + v4f32 d0, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15; + v4f32 da_i_vec, da_i_vec_neg, da_r_vec; + + px = x; + + if (1 == inc_x) + { + if ((0.0 == da_r) && (0.0 == da_i)) + { + v4f32 zero_v = __msa_cast_to_vector_float(0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 0, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 1, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 2, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 3, 0.0); + + for (i = (n >> 5); i--;) + { + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + } + + if (n & 31) + { + if (n & 16) + { + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + } + + if (n & 8) + { + ST_SP4_INC(zero_v, zero_v, zero_v, zero_v, x, 4); + } + + if (n & 4) + { + ST_SP2_INC(zero_v, zero_v, x, 4); + } + + if (n & 2) + { + ST_SP(zero_v, x); x += 4; + } + + if (n & 1) + { + *x = 0; x += 1; + *x = 0; + } + } + } + else if (0.0 == da_r) + { + da_i_vec = COPY_FLOAT_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v4f32) __msa_ilvev_w((v4i32) da_i_vec_neg, (v4i32) da_i_vec); + + if (n > 31) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 32; + + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 5)- 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + x8 = LD_SP(px); px += 4; + x0 *= da_i_vec; + x9 = LD_SP(px); px += 4; + x1 *= da_i_vec; + x10 = LD_SP(px); px += 4; + x2 *= da_i_vec; + x11 = LD_SP(px); px += 4; + x3 *= da_i_vec; + x12 = LD_SP(px); px += 4; + x4 *= da_i_vec; + x13 = LD_SP(px); px += 4; + x5 *= da_i_vec; + x0 = (v4f32) __msa_shf_w((v4i32) x0, SHF_177); + x14 = LD_SP(px); px += 4; + x6 *= da_i_vec; + x1 = (v4f32) __msa_shf_w((v4i32) x1, SHF_177); + x15 = LD_SP(px); px += 4; + x7 *= da_i_vec; + x2 = (v4f32) __msa_shf_w((v4i32) x2, SHF_177); + x8 *= da_i_vec; + x3 = (v4f32) __msa_shf_w((v4i32) x3, SHF_177); + ST_SP(x0, x); x += 4; + x9 *= da_i_vec; + x4 = (v4f32) __msa_shf_w((v4i32) x4, SHF_177); + ST_SP(x1, x); x += 4; + x10 *= da_i_vec; + x5 = (v4f32) __msa_shf_w((v4i32) x5, SHF_177); + ST_SP(x2, x); x += 4; + x11 *= da_i_vec; + x6 = (v4f32) __msa_shf_w((v4i32) x6, SHF_177); + ST_SP(x3, x); x += 4; + x12 *= da_i_vec; + x7 = (v4f32) __msa_shf_w((v4i32) x7, SHF_177); + ST_SP(x4, x); x += 4; + x13 *= da_i_vec; + x8 = (v4f32) __msa_shf_w((v4i32) x8, SHF_177); + ST_SP(x5, x); x += 4; + x14 *= da_i_vec; + x9 = (v4f32) __msa_shf_w((v4i32) x9, SHF_177); + ST_SP(x6, x); x += 4; + x15 *= da_i_vec; + x10 = (v4f32) __msa_shf_w((v4i32) x10, SHF_177); + ST_SP(x7, x); x += 4; + x11 = (v4f32) __msa_shf_w((v4i32) x11, SHF_177); + ST_SP(x8, x); x += 4; + x0 = LD_SP(px); px += 4; + x12 = (v4f32) __msa_shf_w((v4i32) x12, SHF_177); + ST_SP(x9, x); x += 4; + x1 = LD_SP(px); px += 4; + x13 = (v4f32) __msa_shf_w((v4i32) x13, SHF_177); + ST_SP(x10, x); x += 4; + x2 = LD_SP(px); px += 4; + x14 = (v4f32) __msa_shf_w((v4i32) x14, SHF_177); + ST_SP(x11, x); x += 4; + x3 = LD_SP(px); px += 4; + x15 = (v4f32) __msa_shf_w((v4i32) x15, SHF_177); + ST_SP(x12, x); x += 4; + x4 = LD_SP(px); px += 4; + ST_SP(x13, x); x += 4; + x5 = LD_SP(px); px += 4; + ST_SP(x14, x); x += 4; + x6 = LD_SP(px); px += 4; + ST_SP(x15, x); x += 4; + x7 = LD_SP(px); px += 4; + } + + LD_SP8_INC(px, 4, x8, x9, x10, x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + x8, x9, x10, x11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + x12, x13, x14, x15); + SHF_W4_SP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_177); + SHF_W4_SP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_177); + SHF_W4_SP(x8, x9, x10, x11, x8, x9, x10, x11, SHF_177); + SHF_W4_SP(x12, x13, x14, x15, x12, x13, x14, x15, SHF_177); + ST_SP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, 4); + } + + if (n & 31) + { + if (n & 16) + { + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + SHF_W4_SP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_177); + SHF_W4_SP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_177); + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 4); + } + + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + SHF_W4_SP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_177); + ST_SP4_INC(x0, x1, x2, x3, x, 4); + } + + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, x0, x1); + SHF_W2_SP(x0, x1, x0, x1, SHF_177); + ST_SP2_INC(x0, x1, x, 4); + } + + if (n & 2) + { + LD_GP4_INC(px, 1, f0, f1, f2, f3); + MUL4(f0, da_i, f1, -da_i, f2, da_i, f3, -da_i, + f0, f1, f2, f3); + ST_GP4_INC(f1, f0, f3, f2, x, 1); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_i, f1, -da_i, f0, f1); + ST_GP2_INC(f1, f0, x, 1); + } + } + } + else if (0.0 == da_i) + { + da_r_vec = COPY_FLOAT_TO_VECTOR(da_r); + + if (n > 31) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 32; + + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 5)- 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + x8 = LD_SP(px); px += 4; + x0 *= da_r_vec; + x9 = LD_SP(px); px += 4; + x1 *= da_r_vec; + x10 = LD_SP(px); px += 4; + x2 *= da_r_vec; + x11 = LD_SP(px); px += 4; + x3 *= da_r_vec; + x12 = LD_SP(px); px += 4; + x4 *= da_r_vec; + x13 = LD_SP(px); px += 4; + x5 *= da_r_vec; + ST_SP(x0, x); x += 4; + x14 = LD_SP(px); px += 4; + x6 *= da_r_vec; + ST_SP(x1, x); x += 4; + x15 = LD_SP(px); px += 4; + x7 *= da_r_vec; + ST_SP(x2, x); x += 4; + x8 *= da_r_vec; + ST_SP(x3, x); x += 4; + x9 *= da_r_vec; + ST_SP(x4, x); x += 4; + x10 *= da_r_vec; + ST_SP(x5, x); x += 4; + x11 *= da_r_vec; + ST_SP(x6, x); x += 4; + x12 *= da_r_vec; + ST_SP(x7, x); x += 4; + x13 *= da_r_vec; + ST_SP(x8, x); x += 4; + x0 = LD_SP(px); px += 4; + x14 *= da_r_vec; + ST_SP(x9, x); x += 4; + x1 = LD_SP(px); px += 4; + x15 *= da_r_vec; + ST_SP(x10, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(x11, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(x12, x); x += 4; + x4 = LD_SP(px); px += 4; + ST_SP(x13, x); x += 4; + x5 = LD_SP(px); px += 4; + ST_SP(x14, x); x += 4; + x6 = LD_SP(px); px += 4; + ST_SP(x15, x); x += 4; + x7 = LD_SP(px); px += 4; + } + + LD_SP8_INC(px, 4, x8, x9, x10, x11, x12, x13, x14, x15); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + MUL4(x8, da_r_vec, x9, da_r_vec, x10, da_r_vec, x11, da_r_vec, + x8, x9, x10, x11); + MUL4(x12, da_r_vec, x13, da_r_vec, x14, da_r_vec, x15, da_r_vec, + x12, x13, x14, x15); + ST_SP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, 4); + } + + if (n & 31) + { + if (n & 16) + { + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 4); + } + + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + ST_SP4_INC(x0, x1, x2, x3, x, 4); + } + + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + MUL2(x0, da_r_vec, x1, da_r_vec, x0, x1); + ST_SP2_INC(x0, x1, x, 4); + } + + if (n & 2) + { + LD_GP4_INC(px, 1, f0, f1, f2, f3); + MUL4(f0, da_r, f1, da_r, f2, da_r, f3, da_r, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, x, 1); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_r, f1, da_r, f0, f1); + ST_GP2_INC(f0, f1, x, 1); + } + } + } + else + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64; + + da_i_vec = COPY_FLOAT_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v4f32) __msa_ilvev_w((v4i32) da_i_vec_neg, (v4i32) da_i_vec); + + da_r_vec = COPY_FLOAT_TO_VECTOR(da_r); + + for (i = (n >> 5); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + LD_SP16_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, + x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + d8, d9, d10, d11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + d12, d13, d14, d15); + SHF_W4_SP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_177); + SHF_W4_SP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_177); + SHF_W4_SP(d8, d9, d10, d11, d8, d9, d10, d11, SHF_177); + SHF_W4_SP(d12, d13, d14, d15, d12, d13, d14, d15, SHF_177); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + FMADD4(x8, x9, x10, x11, da_r_vec, d8, d9, d10, d11); + FMADD4(x12, x13, x14, x15, da_r_vec, d12, d13, d14, d15); + ST_SP16_INC(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, + d12, d13, d14, d15, x, 4); + } + + if (n & 31) + { + if (n & 16) + { + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + SHF_W4_SP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_177); + SHF_W4_SP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_177); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + ST_SP8_INC(d0, d1, d2, d3, d4, d5, d6, d7, x, 4); + } + + if (n & 8) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + SHF_W4_SP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_177); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + ST_SP4_INC(d0, d1, d2, d3, x, 4); + } + + if (n & 4) + { + LD_SP2_INC(px, 4, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, d0, d1); + SHF_W2_SP(d0, d1, d0, d1, SHF_177); + FMADD2(x0, x1, da_r_vec, d0, d1); + ST_SP2_INC(d0, d1, x, 4); + } + + if (n & 2) + { + LD_GP4_INC(px, 1, f0, f1, f2, f3); + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + tp2 = da_r * f2; + tp2 -= da_i * f3; + tp3 = da_r * f3; + tp3 += da_i * f2; + + ST_GP4_INC(tp0, tp1, tp2, tp3, x, 1); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + + ST_GP2_INC(tp0, tp1, x, 1); + } + } + } + } + else + { + inc_x2 = 2 * inc_x; + + if ((0.0 == da_r) && (0.0 == da_i)) + { + for (i = n; i--;) + { + *x = 0; + *(x + 1) = 0; + + x += inc_x2; + } + } + else if (0.0 == da_r) + { + da_i_vec = COPY_FLOAT_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v4f32) __msa_ilvev_w((v4i32) da_i_vec_neg, (v4i32) da_i_vec); + + for (i = (n >> 4); i--;) + { + LD_SP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + PCKEV_D4_SP(x9, x8, x11, x10, x13, x12, x15, x14, d4, d5, d6, d7); + MUL4(d0, da_i_vec, d1, da_i_vec, d2, da_i_vec, d3, da_i_vec, + d0, d1, d2, d3); + MUL4(d4, da_i_vec, d5, da_i_vec, d6, da_i_vec, d7, da_i_vec, + d4, d5, d6, d7); + + *x = d0[1]; + *(x + 1) = d0[0]; + x += inc_x2; + *x = d0[3]; + *(x + 1) = d0[2]; + x += inc_x2; + *x = d1[1]; + *(x + 1) = d1[0]; + x += inc_x2; + *x = d1[3]; + *(x + 1) = d1[2]; + x += inc_x2; + *x = d2[1]; + *(x + 1) = d2[0]; + x += inc_x2; + *x = d2[3]; + *(x + 1) = d2[2]; + x += inc_x2; + *x = d3[1]; + *(x + 1) = d3[0]; + x += inc_x2; + *x = d3[3]; + *(x + 1) = d3[2]; + x += inc_x2; + *x = d4[1]; + *(x + 1) = d4[0]; + x += inc_x2; + *x = d4[3]; + *(x + 1) = d4[2]; + x += inc_x2; + *x = d5[1]; + *(x + 1) = d5[0]; + x += inc_x2; + *x = d5[3]; + *(x + 1) = d5[2]; + x += inc_x2; + *x = d6[1]; + *(x + 1) = d6[0]; + x += inc_x2; + *x = d6[3]; + *(x + 1) = d6[2]; + x += inc_x2; + *x = d7[1]; + *(x + 1) = d7[0]; + x += inc_x2; + *x = d7[3]; + *(x + 1) = d7[2]; + x += inc_x2; + } + + if (n & 15) + { + if (n & 8) + { + LD_SP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + MUL4(d0, da_i_vec, d1, da_i_vec, d2, da_i_vec, d3, da_i_vec, + d0, d1, d2, d3); + + *x = d0[1]; + *(x + 1) = d0[0]; + x += inc_x2; + *x = d0[3]; + *(x + 1) = d0[2]; + x += inc_x2; + *x = d1[1]; + *(x + 1) = d1[0]; + x += inc_x2; + *x = d1[3]; + *(x + 1) = d1[2]; + x += inc_x2; + *x = d2[1]; + *(x + 1) = d2[0]; + x += inc_x2; + *x = d2[3]; + *(x + 1) = d2[2]; + x += inc_x2; + *x = d3[1]; + *(x + 1) = d3[0]; + x += inc_x2; + *x = d3[3]; + *(x + 1) = d3[2]; + x += inc_x2; + } + + if (n & 4) + { + LD_SP4_INC(px, inc_x2, x0, x1, x2, x3); + PCKEV_D2_SP(x1, x0, x3, x2, d0, d1); + MUL2(d0, da_i_vec, d1, da_i_vec, d0, d1); + + *x = d0[1]; + *(x + 1) = d0[0]; + x += inc_x2; + *x = d0[3]; + *(x + 1) = d0[2]; + x += inc_x2; + *x = d1[1]; + *(x + 1) = d1[0]; + x += inc_x2; + *x = d1[3]; + *(x + 1) = d1[2]; + x += inc_x2; + } + + if (n & 2) + { + f0 = *px; + f1 = *(px + 1); + px += inc_x2; + f2 = *px; + f3 = *(px + 1); + px += inc_x2; + + MUL4(f0, da_i, f1, -da_i, f2, da_i, f3, -da_i, f0, f1, f2, f3); + + *x = f1; + *(x + 1) = f0; + x += inc_x2; + *x = f3; + *(x + 1) = f2; + x += inc_x2; + } + + if (n & 1) + { + f0 = *x; + f1 = *(x + 1); + + MUL2(f0, da_i, f1, -da_i, f0, f1); + + *x = f1; + *(x + 1) = f0; + } + } + } + else if (0.0 == da_i) + { + da_r_vec = COPY_FLOAT_TO_VECTOR(da_r); + + for (i = (n >> 4); i--;) + { + LD_SP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + PCKEV_D4_SP(x9, x8, x11, x10, x13, x12, x15, x14, d4, d5, d6, d7); + MUL4(d0, da_r_vec, d1, da_r_vec, d2, da_r_vec, d3, da_r_vec, + d0, d1, d2, d3); + MUL4(d4, da_r_vec, d5, da_r_vec, d6, da_r_vec, d7, da_r_vec, + d4, d5, d6, d7); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + *x = d2[0]; + *(x + 1) = d2[1]; + x += inc_x2; + *x = d2[2]; + *(x + 1) = d2[3]; + x += inc_x2; + *x = d3[0]; + *(x + 1) = d3[1]; + x += inc_x2; + *x = d3[2]; + *(x + 1) = d3[3]; + x += inc_x2; + *x = d4[0]; + *(x + 1) = d4[1]; + x += inc_x2; + *x = d4[2]; + *(x + 1) = d4[3]; + x += inc_x2; + *x = d5[0]; + *(x + 1) = d5[1]; + x += inc_x2; + *x = d5[2]; + *(x + 1) = d5[3]; + x += inc_x2; + *x = d6[0]; + *(x + 1) = d6[1]; + x += inc_x2; + *x = d6[2]; + *(x + 1) = d6[3]; + x += inc_x2; + *x = d7[0]; + *(x + 1) = d7[1]; + x += inc_x2; + *x = d7[2]; + *(x + 1) = d7[3]; + x += inc_x2; + } + + if (n & 15) + { + if (n & 8) + { + LD_SP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + MUL4(d0, da_r_vec, d1, da_r_vec, d2, da_r_vec, d3, da_r_vec, + d0, d1, d2, d3); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + *x = d2[0]; + *(x + 1) = d2[1]; + x += inc_x2; + *x = d2[2]; + *(x + 1) = d2[3]; + x += inc_x2; + *x = d3[0]; + *(x + 1) = d3[1]; + x += inc_x2; + *x = d3[2]; + *(x + 1) = d3[3]; + x += inc_x2; + } + + if (n & 4) + { + LD_SP4_INC(px, inc_x2, x0, x1, x2, x3); + PCKEV_D2_SP(x1, x0, x3, x2, d0, d1); + MUL2(d0, da_r_vec, d1, da_r_vec, d0, d1); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + } + + if (n & 2) + { + f0 = *px; + f1 = *(px + 1); + px += inc_x2; + f2 = *px; + f3 = *(px + 1); + px += inc_x2; + + MUL4(f0, da_r, f1, da_r, f2, da_r, f3, da_r, f0, f1, f2, f3); + + *x = f0; + *(x + 1) = f1; + x += inc_x2; + *x = f2; + *(x + 1) = f3; + x += inc_x2; + } + + if (n & 1) + { + f0 = *x; + f1 = *(x + 1); + + MUL2(f0, da_r, f1, da_r, f0, f1); + + *x = f0; + *(x + 1) = f1; + } + } + } + else + { + da_i_vec = COPY_FLOAT_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v4f32) __msa_ilvev_w((v4i32) da_i_vec_neg, (v4i32) da_i_vec); + + da_r_vec = COPY_FLOAT_TO_VECTOR(da_r); + + for (i = (n >> 4); i--;) + { + LD_SP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + PCKEV_D4_SP(x9, x8, x11, x10, x13, x12, x15, x14, d4, d5, d6, d7); + MUL4(d0, da_i_vec, d1, da_i_vec, d2, da_i_vec, d3, da_i_vec, + x0, x1, x2, x3); + MUL4(d4, da_i_vec, d5, da_i_vec, d6, da_i_vec, d7, da_i_vec, + x4, x5, x6, x7); + MUL4(d0, da_r_vec, d1, da_r_vec, d2, da_r_vec, d3, da_r_vec, + d0, d1, d2, d3); + MUL4(d4, da_r_vec, d5, da_r_vec, d6, da_r_vec, d7, da_r_vec, + d4, d5, d6, d7); + SHF_W4_SP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_177); + SHF_W4_SP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_177); + ADD4(d0, x0, d1, x1, d2, x2, d3, x3, d0, d1, d2, d3); + ADD4(d4, x4, d5, x5, d6, x6, d7, x7, d4, d5, d6, d7); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + *x = d2[0]; + *(x + 1) = d2[1]; + x += inc_x2; + *x = d2[2]; + *(x + 1) = d2[3]; + x += inc_x2; + *x = d3[0]; + *(x + 1) = d3[1]; + x += inc_x2; + *x = d3[2]; + *(x + 1) = d3[3]; + x += inc_x2; + *x = d4[0]; + *(x + 1) = d4[1]; + x += inc_x2; + *x = d4[2]; + *(x + 1) = d4[3]; + x += inc_x2; + *x = d5[0]; + *(x + 1) = d5[1]; + x += inc_x2; + *x = d5[2]; + *(x + 1) = d5[3]; + x += inc_x2; + *x = d6[0]; + *(x + 1) = d6[1]; + x += inc_x2; + *x = d6[2]; + *(x + 1) = d6[3]; + x += inc_x2; + *x = d7[0]; + *(x + 1) = d7[1]; + x += inc_x2; + *x = d7[2]; + *(x + 1) = d7[3]; + x += inc_x2; + } + + if (n & 15) + { + if (n & 8) + { + LD_SP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + PCKEV_D4_SP(x1, x0, x3, x2, x5, x4, x7, x6, d0, d1, d2, d3); + MUL4(d0, da_i_vec, d1, da_i_vec, d2, da_i_vec, d3, da_i_vec, + x0, x1, x2, x3); + MUL4(d0, da_r_vec, d1, da_r_vec, d2, da_r_vec, d3, da_r_vec, + d0, d1, d2, d3); + SHF_W4_SP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_177); + ADD4(d0, x0, d1, x1, d2, x2, d3, x3, d0, d1, d2, d3); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + *x = d2[0]; + *(x + 1) = d2[1]; + x += inc_x2; + *x = d2[2]; + *(x + 1) = d2[3]; + x += inc_x2; + *x = d3[0]; + *(x + 1) = d3[1]; + x += inc_x2; + *x = d3[2]; + *(x + 1) = d3[3]; + x += inc_x2; + } + + if (n & 4) + { + LD_SP4_INC(px, inc_x2, x0, x1, x2, x3); + PCKEV_D2_SP(x1, x0, x3, x2, d0, d1); + MUL2(d0, da_i_vec, d1, da_i_vec, x0, x1); + MUL2(d0, da_r_vec, d1, da_r_vec, d0, d1); + SHF_W2_SP(x0, x1, x0, x1, SHF_177); + ADD2(d0, x0, d1, x1, d0, d1); + + *x = d0[0]; + *(x + 1) = d0[1]; + x += inc_x2; + *x = d0[2]; + *(x + 1) = d0[3]; + x += inc_x2; + *x = d1[0]; + *(x + 1) = d1[1]; + x += inc_x2; + *x = d1[2]; + *(x + 1) = d1[3]; + x += inc_x2; + } + + if (n & 2) + { + f0 = *px;; + f1 = *(px + 1); + px += inc_x2; + f2 = *px; + f3 = *(px + 1); + px += inc_x2; + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + tp2 = da_r * f2; + tp2 -= da_i * f3; + tp3 = da_r * f3; + tp3 += da_i * f2; + + *x = tp0; + *(x + 1) = tp1; + x += inc_x2; + *x = tp2; + *(x + 1) = tp3; + x += inc_x2; + } + + if (n & 1) + { + f0 = *px; px += 1; + f1 = *px; + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + + *x = tp0; x += 1; + *x = tp1; + } + } + } + } + + return (0); +} diff --git a/kernel/mips/cswap_msa.c b/kernel/mips/cswap_msa.c new file mode 100644 index 0000000000..632726a50b --- /dev/null +++ b/kernel/mips/cswap_msa.c @@ -0,0 +1,281 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT dummy3, + FLOAT dummy4, FLOAT *srcx, BLASLONG inc_x, FLOAT *srcy, + BLASLONG inc_y, FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i = 0, pref_offsetx, pref_offsety; + FLOAT *px, *py; + BLASLONG inc_x2, inc_y2; + FLOAT x0, x1, x2, x3, x4, x5, x6, x7; + FLOAT y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7; + v4f32 yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7; + + if (n < 0) return (0); + + pref_offsetx = (BLASLONG)srcx & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)srcy & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + px = srcx; + py = srcy; + + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n >> 4) + { + LD_SP8_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7); + + for (i = (n >> 4) - 1; i--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + yv0 = LD_SP(py); py += 4; + ST_SP(xv0, srcy); srcy += 4; + yv1 = LD_SP(py); py += 4; + ST_SP(xv1, srcy); srcy += 4; + yv2 = LD_SP(py); py += 4; + ST_SP(xv2, srcy); srcy += 4; + yv3 = LD_SP(py); py += 4; + ST_SP(xv3, srcy); srcy += 4; + yv4 = LD_SP(py); py += 4; + ST_SP(xv4, srcy); srcy += 4; + yv5 = LD_SP(py); py += 4; + ST_SP(xv5, srcy); srcy += 4; + yv6 = LD_SP(py); py += 4; + ST_SP(xv6, srcy); srcy += 4; + yv7 = LD_SP(py); py += 4; + ST_SP(xv7, srcy); srcy += 4; + + xv0 = LD_SP(px); px += 4; + ST_SP(yv0, srcx); srcx += 4; + xv1 = LD_SP(px); px += 4; + ST_SP(yv1, srcx); srcx += 4; + xv2 = LD_SP(px); px += 4; + ST_SP(yv2, srcx); srcx += 4; + xv3 = LD_SP(px); px += 4; + ST_SP(yv3, srcx); srcx += 4; + xv4 = LD_SP(px); px += 4; + ST_SP(yv4, srcx); srcx += 4; + xv5 = LD_SP(px); px += 4; + ST_SP(yv5, srcx); srcx += 4; + xv6 = LD_SP(px); px += 4; + ST_SP(yv6, srcx); srcx += 4; + xv7 = LD_SP(px); px += 4; + ST_SP(yv7, srcx); srcx += 4; + } + + LD_SP8_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7); + ST_SP8_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7, srcy, 4); + ST_SP8_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7, srcx, 4); + } + + if (n & 15) + { + if ((n & 8) && (n & 4) && (n & 2)) + { + LD_SP7_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5, xv6); + LD_SP7_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5, yv6); + ST_SP7_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, srcy, 4); + ST_SP7_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, srcx, 4); + } + else if ((n & 8) && (n & 4)) + { + LD_SP6_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5); + LD_SP6_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5); + ST_SP6_INC(xv0, xv1, xv2, xv3, xv4, xv5, srcy, 4); + ST_SP6_INC(yv0, yv1, yv2, yv3, yv4, yv5, srcx, 4); + } + else if ((n & 8) && (n & 2)) + { + LD_SP5_INC(px, 4, xv0, xv1, xv2, xv3, xv4); + LD_SP5_INC(py, 4, yv0, yv1, yv2, yv3, yv4); + ST_SP5_INC(xv0, xv1, xv2, xv3, xv4, srcy, 4); + ST_SP5_INC(yv0, yv1, yv2, yv3, yv4, srcx, 4); + } + else if ((n & 4) && (n & 2)) + { + LD_SP3_INC(px, 4, xv0, xv1, xv2); + LD_SP3_INC(py, 4, yv0, yv1, yv2); + ST_SP3_INC(xv0, xv1, xv2, srcy, 4); + ST_SP3_INC(yv0, yv1, yv2, srcx, 4); + } + else if (n & 8) + { + LD_SP4_INC(px, 4, xv0, xv1, xv2, xv3); + LD_SP4_INC(py, 4, yv0, yv1, yv2, yv3); + ST_SP4_INC(xv0, xv1, xv2, xv3, srcy, 4); + ST_SP4_INC(yv0, yv1, yv2, yv3, srcx, 4); + } + else if (n & 4) + { + LD_SP2_INC(px, 4, xv0, xv1); + LD_SP2_INC(py, 4, yv0, yv1); + ST_SP2_INC(xv0, xv1, srcy, 4); + ST_SP2_INC(yv0, yv1, srcx, 4); + } + else if (n & 2) + { + xv0 = LD_SP(px); + yv0 = LD_SP(py); + + px += 4; + py += 4; + + ST_SP(xv0, srcy); + ST_SP(yv0, srcx); + + srcx += 4; + srcy += 4; + } + + if (n & 1) + { + LD_GP2_INC(px, 1, x0, x1); + LD_GP2_INC(py, 1, y0, y1); + ST_GP2_INC(x0, x1, srcy, 1); + ST_GP2_INC(y0, y1, srcx, 1); + } + } + } + else + { + for (i = (n >> 2); i--;) + { + x0 = srcx[0 * inc_x2]; + x1 = srcx[0 * inc_x2 + 1]; + x2 = srcx[1 * inc_x2]; + x3 = srcx[1 * inc_x2 + 1]; + x4 = srcx[2 * inc_x2]; + x5 = srcx[2 * inc_x2 + 1]; + x6 = srcx[3 * inc_x2]; + x7 = srcx[3 * inc_x2 + 1]; + + y0 = srcy[0 * inc_y2]; + y1 = srcy[0 * inc_y2 + 1]; + y2 = srcy[1 * inc_y2]; + y3 = srcy[1 * inc_y2 + 1]; + y4 = srcy[2 * inc_y2]; + y5 = srcy[2 * inc_y2 + 1]; + y6 = srcy[3 * inc_y2]; + y7 = srcy[3 * inc_y2 + 1]; + + srcx[0 * inc_x2] = y0; + srcx[0 * inc_x2 + 1] = y1; + srcx[1 * inc_x2] = y2; + srcx[1 * inc_x2 + 1] = y3; + srcx[2 * inc_x2] = y4; + srcx[2 * inc_x2 + 1] = y5; + srcx[3 * inc_x2] = y6; + srcx[3 * inc_x2 + 1] = y7; + + srcy[0 * inc_y2] = x0; + srcy[0 * inc_y2 + 1] = x1; + srcy[1 * inc_y2] = x2; + srcy[1 * inc_y2 + 1] = x3; + srcy[2 * inc_y2] = x4; + srcy[2 * inc_y2 + 1] = x5; + srcy[3 * inc_y2] = x6; + srcy[3 * inc_y2 + 1] = x7; + + srcx += 4 * inc_x2; + srcy += 4 * inc_y2; + } + + if (n & 2) + { + x0 = srcx[0 * inc_x2]; + x1 = srcx[0 * inc_x2 + 1]; + x2 = srcx[1 * inc_x2]; + x3 = srcx[1 * inc_x2 + 1]; + + y0 = srcy[0 * inc_y2]; + y1 = srcy[0 * inc_y2 + 1]; + y2 = srcy[1 * inc_y2]; + y3 = srcy[1 * inc_y2 + 1]; + + srcx[0 * inc_x2] = y0; + srcx[0 * inc_x2 + 1] = y1; + srcx[1 * inc_x2] = y2; + srcx[1 * inc_x2 + 1] = y3; + + srcy[0 * inc_y2] = x0; + srcy[0 * inc_y2 + 1] = x1; + srcy[1 * inc_y2] = x2; + srcy[1 * inc_y2 + 1] = x3; + + srcx += 2 * inc_x2; + srcy += 2 * inc_y2; + } + + if (n & 1) + { + x0 = srcx[0 * inc_x2]; + x1 = srcx[0 * inc_x2 + 1]; + + y0 = srcy[0 * inc_y2]; + y1 = srcy[0 * inc_y2 + 1]; + + srcx[0 * inc_x2] = y0; + srcx[0 * inc_x2 + 1] = y1; + + srcy[0 * inc_y2] = x0; + srcy[0 * inc_y2 + 1] = x1; + + srcx += inc_x2; + srcy += inc_y2; + } + } + + return (0); +} diff --git a/kernel/mips/dasum_msa.c b/kernel/mips/dasum_msa.c index a3641cd50c..2cb37fcced 100644 --- a/kernel/mips/dasum_msa.c +++ b/kernel/mips/dasum_msa.c @@ -36,40 +36,67 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) BLASLONG i; FLOAT sumf = 0.0; v2f64 src0, src1, src2, src3, src4, src5, src6, src7; - v2f64 sum_abs0, sum_abs1, sum_abs2, sum_abs3; - v2f64 zero_v = {0}; + v2f64 src8, src9, src10, src11, src12, src13, src14, src15; + v2f64 sum_abs0 = {0, 0}; + v2f64 sum_abs1 = {0, 0}; + v2f64 sum_abs2 = {0, 0}; + v2f64 sum_abs3 = {0, 0}; v2i64 and_vec = {0x7FFFFFFFFFFFFFFF, 0x7FFFFFFFFFFFFFFF}; if (n <= 0 || inc_x <= 0) return (sumf); if (1 == inc_x) { - if (n > 15) + if (n > 31) { - n -= 16; + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 16; LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 5) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + LD_DP8_INC(x, 2, src8, src9, src10, src11, src12, src13, src14, src15); - sum_abs0 = AND_VEC_D(src0); - sum_abs1 = AND_VEC_D(src1); - sum_abs2 = AND_VEC_D(src2); - sum_abs3 = AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - sum_abs1 += AND_VEC_D(src5); - sum_abs2 += AND_VEC_D(src6); - sum_abs3 += AND_VEC_D(src7); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - sum_abs2 = zero_v; - sum_abs3 = zero_v; - } + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + + LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } - for (i = (n >> 4); i--;) - { - LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + LD_DP8_INC(x, 2, src8, src9, src10, src11, src12, src13, src14, src15); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); @@ -79,13 +106,21 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_D(src5); sum_abs2 += AND_VEC_D(src6); sum_abs3 += AND_VEC_D(src7); + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); } - if (n & 15) + if (n & 31) { - if ((n & 8) && (n & 4) && (n & 2)) + if (n & 16) { - LD_DP7_INC(x, 2, src0, src1, src2, src3, src4, src5, src6); + LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); @@ -94,37 +129,10 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs0 += AND_VEC_D(src4); sum_abs1 += AND_VEC_D(src5); sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); } - else if ((n & 8) && (n & 4)) - { - LD_DP6_INC(x, 2, src0, src1, src2, src3, src4, src5); - - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - sum_abs3 += AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - sum_abs1 += AND_VEC_D(src5); - } - else if ((n & 8) && (n & 2)) - { - LD_DP5_INC(x, 2, src0, src1, src2, src3, src4); - - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - sum_abs3 += AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - } - else if ((n & 4) && (n & 2)) - { - LD_DP3_INC(x, 2, src0, src1, src2); - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - } - else if (n & 8) + if (n & 8) { LD_DP4_INC(x, 2, src0, src1, src2, src3); @@ -133,64 +141,63 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs2 += AND_VEC_D(src2); sum_abs3 += AND_VEC_D(src3); } - else if (n & 4) + + if (n & 4) { LD_DP2_INC(x, 2, src0, src1); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); } - else if (n & 2) + + if (n & 2) { src0 = LD_DP(x); x += 2; sum_abs0 += AND_VEC_D(src0); } - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf = sum_abs0[0] + sum_abs0[1]; - if (n & 1) { sumf += fabs(*x); } } - else - { - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - sumf = sum_abs0[0] + sum_abs0[1]; - } + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + + sumf += sum_abs0[0] + sum_abs0[1]; } else { - if (n > 8) + if (n > 16) { - n -= 8; - LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 4) - 1; i--;) + { + LD_DP8_INC(x, inc_x, src8, src9, src10, src11, src12, src13, src14, src15); - sum_abs0 = AND_VEC_D(src0); - sum_abs1 = AND_VEC_D(src1); - sum_abs2 = AND_VEC_D(src2); - sum_abs3 = AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - sum_abs1 += AND_VEC_D(src5); - sum_abs2 += AND_VEC_D(src6); - sum_abs3 += AND_VEC_D(src7); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - sum_abs2 = zero_v; - sum_abs3 = zero_v; - } + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + + LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } - for (i = (n >> 3); i--;) - { - LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + LD_DP8_INC(x, inc_x, src8, src9, src10, src11, src12, src13, src14, src15); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); @@ -200,13 +207,21 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_D(src5); sum_abs2 += AND_VEC_D(src6); sum_abs3 += AND_VEC_D(src7); + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); } - if (n & 7) + if (n & 15) { - if ((n & 4) && (n & 2) && (n & 1)) + if (n & 8) { - LD_DP7_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6); + LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); @@ -215,37 +230,10 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs0 += AND_VEC_D(src4); sum_abs1 += AND_VEC_D(src5); sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); } - else if ((n & 4) && (n & 2)) - { - LD_DP6_INC(x, inc_x, src0, src1, src2, src3, src4, src5); - - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - sum_abs3 += AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - sum_abs1 += AND_VEC_D(src5); - } - else if ((n & 4) && (n & 1)) - { - LD_DP5_INC(x, inc_x, src0, src1, src2, src3, src4); - - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - sum_abs3 += AND_VEC_D(src3); - sum_abs0 += AND_VEC_D(src4); - } - else if ((n & 2) && (n & 1)) - { - LD_DP3_INC(x, inc_x, src0, src1, src2); - sum_abs0 += AND_VEC_D(src0); - sum_abs1 += AND_VEC_D(src1); - sum_abs2 += AND_VEC_D(src2); - } - else if (n & 4) + if (n & 4) { LD_DP4_INC(x, inc_x, src0, src1, src2, src3); @@ -254,14 +242,16 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs2 += AND_VEC_D(src2); sum_abs3 += AND_VEC_D(src3); } - else if (n & 2) + + if (n & 2) { LD_DP2_INC(x, inc_x, src0, src1); sum_abs0 += AND_VEC_D(src0); sum_abs1 += AND_VEC_D(src1); } - else if (n & 1) + + if (n & 1) { src0 = LD_DP(x); @@ -269,7 +259,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) } } - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; sumf = sum_abs0[0]; } diff --git a/kernel/mips/daxpy_msa.c b/kernel/mips/daxpy_msa.c new file mode 100644 index 0000000000..789b78c22f --- /dev/null +++ b/kernel/mips/daxpy_msa.c @@ -0,0 +1,246 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +#if !defined(CONJ) + #define OP0 += + #define OP1 -= + #define OP2 += +#else + #define OP0 -= + #define OP1 += + #define OP2 -= +#endif + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, + BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i; + FLOAT *py; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v2f64 da_vec, zero_v = {0}; + + if ((n < 0) || (da == 0.0)) return(0); + + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32; + + da_vec = COPY_DOUBLE_TO_VECTOR(da); + + for (i = (n >> 4); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 16; + y_pref += 16; + + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + FMADD4(x4, x5, x6, x7, da_vec, y4, y5, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP4_INC(x, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, 2); + } + + if (n & 4) + { + LD_DP2_INC(x, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + FMADD2(x0, x1, da_vec, y0, y1); + ST_DP2_INC(y0, y1, y, 2); + } + + if (n & 2) + { + x0 = LD_DP(x); x += 2; + y0 = LD_DP(py); py += 2; + y0 += da_vec * x0; + ST_DP(y0, y); y += 2; + } + + if (n & 1) + { + y[0] += da * x[0]; + } + } + } + else if (1 == inc_y) + { + FLOAT *y_pref; + BLASLONG pref_offset; + v2f64 x8, x9, x10, x11, x12, x13, x14; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32; + + da_vec = COPY_DOUBLE_TO_VECTOR(da); + + for (i = (n >> 4); i--;) + { + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + y_pref += 16; + + LD_DP8_INC(x, inc_x, x0, x1, x2, x3, x4, x5, x6, x14); + LD_DP7_INC(x, inc_x, x8, x9, x10, x11, x12, x13, x7); + + PCKEV_D2_SD(x1, x0, x3, x2, x0, x1); + PCKEV_D2_SD(x5, x4, x14, x6, x2, x3); + PCKEV_D2_SD(x9, x8, x11, x10, x4, x5); + x6 = (v2f64) __msa_pckev_d((v2i64) x13, (v2i64) x12); + x7 = (v2f64) __msa_insert_d((v2i64) x7, 1, *((BLASLONG *) x)); + x += inc_x; + + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + FMADD4(x4, x5, x6, x7, da_vec, y4, y5, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP7_INC(x, inc_x, x0, x1, x2, x6, x4, x5, x3); + + PCKEV_D2_SD(x1, x0, x6, x2, x0, x1); + x2 = (v2f64) __msa_pckev_d((v2i64) x5, (v2i64) x4); + x3 = (v2f64) __msa_insert_d((v2i64) x3, 1, *((BLASLONG *) x)); + x += inc_x; + + LD_DP4_INC(py, 2, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, 2); + } + + if (n & 4) + { + LD_DP3_INC(x, inc_x, x0, x2, x1); + + x0 = (v2f64) __msa_pckev_d((v2i64) x2, (v2i64) x0); + x1 = (v2f64) __msa_insert_d((v2i64) x1, 1, *((BLASLONG *) x)); + x += inc_x; + + LD_DP2_INC(py, 2, y0, y1); + FMADD2(x0, x1, da_vec, y0, y1); + ST_DP2_INC(y0, y1, y, 2); + } + + if (n & 2) + { + x0 = (v2f64) __msa_insert_d((v2i64) zero_v, 0, *((BLASLONG *) x)); + x += inc_x; + x0 = (v2f64) __msa_insert_d((v2i64) x0, 1, *((BLASLONG *) x)); + x += inc_x; + + y0 = LD_DP(py); py += 2; + y0 += da_vec * x0; + ST_DP(y0, y); y += 2; + } + + if (n & 1) + { + y[0] += da * x[0]; + } + } + } + else + { + FLOAT x0, x1, x2, x3, y0, y1, y2, y3; + + for (i = (n >> 2); i--;) + { + LD_GP4_INC(x, inc_x, x0, x1, x2, x3); + LD_GP4_INC(py, inc_y, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da, y0, y1, y2, y3); + ST_GP4_INC(y0, y1, y2, y3, y, inc_y); + } + + if (n & 3) + { + if (n & 2) + { + LD_GP2_INC(x, inc_x, x0, x1); + LD_GP2_INC(py, inc_y, y0, y1); + FMADD2(x0, x1, da, y0, y1); + ST_GP2_INC(y0, y1, y, inc_y); + } + + if (n & 1) + { + *y += da * *x; + } + } + } + + return (0); +} diff --git a/kernel/mips/dcopy_msa.c b/kernel/mips/dcopy_msa.c new file mode 100644 index 0000000000..e73bf34eef --- /dev/null +++ b/kernel/mips/dcopy_msa.c @@ -0,0 +1,180 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + BLASLONG i; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + FLOAT f0, f1, f2, f3, f4, f5, f6, f7; + + if (n < 0) return (0); + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n > 31) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 16; + + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 5) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + x8 = LD_DP(x); x += 2; + ST_DP(x0, y); y += 2; + x9 = LD_DP(x); x += 2; + ST_DP(x1, y); y += 2; + x10 = LD_DP(x); x += 2; + ST_DP(x2, y); y += 2; + x11 = LD_DP(x); x += 2; + ST_DP(x3, y); y += 2; + x12 = LD_DP(x); x += 2; + ST_DP(x4, y); y += 2; + x13 = LD_DP(x); x += 2; + ST_DP(x5, y); y += 2; + x14 = LD_DP(x); x += 2; + ST_DP(x6, y); y += 2; + x15 = LD_DP(x); x += 2; + ST_DP(x7, y); y += 2; + x0 = LD_DP(x); x += 2; + ST_DP(x8, y); y += 2; + x1 = LD_DP(x); x += 2; + ST_DP(x9, y); y += 2; + x2 = LD_DP(x); x += 2; + ST_DP(x10, y); y += 2; + x3 = LD_DP(x); x += 2; + ST_DP(x11, y); y += 2; + x4 = LD_DP(x); x += 2; + ST_DP(x12, y); y += 2; + x5 = LD_DP(x); x += 2; + ST_DP(x13, y); y += 2; + x6 = LD_DP(x); x += 2; + ST_DP(x14, y); y += 2; + x7 = LD_DP(x); x += 2; + ST_DP(x15, y); y += 2; + } + + x8 = LD_DP(x); x += 2; + x9 = LD_DP(x); x += 2; + ST_DP(x0, y); y += 2; + x10 = LD_DP(x); x += 2; + ST_DP(x1, y); y += 2; + x11 = LD_DP(x); x += 2; + ST_DP(x2, y); y += 2; + x12 = LD_DP(x); x += 2; + ST_DP(x3, y); y += 2; + x13 = LD_DP(x); x += 2; + ST_DP(x4, y); y += 2; + x14 = LD_DP(x); x += 2; + ST_DP(x5, y); y += 2; + x15 = LD_DP(x); x += 2; + ST_DP(x6, y); y += 2; + ST_DP(x7, y); y += 2; + + ST_DP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, y, 2); + } + + if (n & 31) + { + if (n & 16) + { + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, y, 2); + } + + if (n & 8) + { + LD_DP4_INC(x, 2, x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, y, 2); + } + + if (n & 4) + { + LD_GP4_INC(x, 1, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, y, 1); + } + + if (n & 2) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + + if (n & 1) + { + *y = *x; + } + } + } + else + { + for (i = (n >> 3); i--;) + { + LD_GP8_INC(x, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + ST_GP8_INC(f0, f1, f2, f3, f4, f5, f6, f7, y, inc_y); + } + + if (n & 4) + { + LD_GP4_INC(x, inc_x, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, y, inc_y); + } + + if (n & 2) + { + LD_GP2_INC(x, inc_x, f0, f1); + ST_GP2_INC(f0, f1, y, inc_y); + } + + if (n & 1) + { + *y = *x; + } + } + + return (0); +} diff --git a/kernel/mips/ddot_msa.c b/kernel/mips/ddot_msa.c index b56e101358..9136e21150 100644 --- a/kernel/mips/ddot_msa.c +++ b/kernel/mips/ddot_msa.c @@ -28,105 +28,90 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -/* return float, x,y float */ -#if defined(DSDOT) -double CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#else FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#endif { BLASLONG i = 0; - double dot = 0.0; + FLOAT dot = 0.0; FLOAT x0, x1, x2, x3, y0, y1, y2, y3; v2f64 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7; v2f64 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7; v2f64 dot0 = {0, 0}; + v2f64 dot1 = {0, 0}; + v2f64 dot2 = {0, 0}; + v2f64 dot3 = {0, 0}; - if (n < 0) return (dot); + if (n < 1) return (dot); if ((1 == inc_x) && (1 == inc_y)) { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32; + for (i = (n >> 4); i--;) { - LD_DP8_INC(x, 2, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); - LD_DP8_INC(y, 2, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); + LD_DP8_INC(x, 2, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); + LD_DP8_INC(y, 2, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); + + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 16; + y_pref += 16; dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); + dot1 += (vy1 * vx1); + dot2 += (vy2 * vx2); + dot3 += (vy3 * vx3); dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); - dot0 += (vy6 * vx6); - dot0 += (vy7 * vx7); + dot1 += (vy5 * vx5); + dot2 += (vy6 * vx6); + dot3 += (vy7 * vx7); } if (n & 15) { - if ((n & 8) && (n & 4) && (n & 2)) - { - LD_DP7_INC(x, 2, vx0, vx1, vx2, vx3, vx4, vx5, vx6); - LD_DP7_INC(y, 2, vy0, vy1, vy2, vy3, vy4, vy5, vy6); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); - dot0 += (vy6 * vx6); - } - else if ((n & 8) && (n & 4)) - { - LD_DP6_INC(x, 2, vx0, vx1, vx2, vx3, vx4, vx5); - LD_DP6_INC(y, 2, vy0, vy1, vy2, vy3, vy4, vy5); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); - } - else if ((n & 8) && (n & 2)) - { - LD_DP5_INC(x, 2, vx0, vx1, vx2, vx3, vx4); - LD_DP5_INC(y, 2, vy0, vy1, vy2, vy3, vy4); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - } - else if ((n & 4) && (n & 2)) - { - LD_DP3_INC(x, 2, vx0, vx1, vx2); - LD_DP3_INC(y, 2, vy0, vy1, vy2); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - } - else if (n & 8) + if (n & 8) { - LD_DP4_INC(x, 2, vx0, vx1, vx2, vx3); - LD_DP4_INC(y, 2, vy0, vy1, vy2, vy3); + LD_DP4_INC(x, 2, vx0, vx1, vx2, vx3); + LD_DP4_INC(y, 2, vy0, vy1, vy2, vy3); dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); + dot1 += (vy1 * vx1); + dot2 += (vy2 * vx2); + dot3 += (vy3 * vx3); } - else if (n & 4) + + if (n & 4) { - LD_DP2_INC(x, 2, vx0, vx1); - LD_DP2_INC(y, 2, vy0, vy1); + LD_DP2_INC(x, 2, vx0, vx1); + LD_DP2_INC(y, 2, vy0, vy1); dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); + dot1 += (vy1 * vx1); } - else if (n & 2) + + if (n & 2) { vx0 = LD_DP(x); x += 2; vy0 = LD_DP(y); y += 2; @@ -143,6 +128,8 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) } } + dot0 += dot1 + dot2 + dot3; + dot += dot0[0]; dot += dot0[1]; } @@ -159,16 +146,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot += (y3 * x3); } - if ((n & 2) && (n & 1)) - { - LD_GP3_INC(x, inc_x, x0, x1, x2); - LD_GP3_INC(y, inc_y, y0, y1, y2); - - dot += (y0 * x0); - dot += (y1 * x1); - dot += (y2 * x2); - } - else if (n & 2) + if (n & 2) { LD_GP2_INC(x, inc_x, x0, x1); LD_GP2_INC(y, inc_y, y0, y1); @@ -176,7 +154,8 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot += (y0 * x0); dot += (y1 * x1); } - else if (n & 1) + + if (n & 1) { x0 = *x; y0 = *y; diff --git a/kernel/mips/dgemm_kernel_8x4_msa.c b/kernel/mips/dgemm_kernel_8x4_msa.c index 9286e74694..40f7000145 100644 --- a/kernel/mips/dgemm_kernel_8x4_msa.c +++ b/kernel/mips/dgemm_kernel_8x4_msa.c @@ -28,20 +28,19 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, - FLOAT *C, BLASLONG ldc +static void __attribute__ ((noinline)) +dgemmkernel_8x4_core_msa(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, + FLOAT *A, FLOAT *B, FLOAT *C, BLASLONG ldc #ifdef TRMMKERNEL , BLASLONG offset #endif - ) + ) { BLASLONG i, j, l, temp; #if defined(TRMMKERNEL) BLASLONG off; #endif FLOAT *pc0, *pc1, *pc2, *pc3, *pa0, *pb0; - FLOAT tmp0, tmp1, tmp2, tmp3; - FLOAT a0, b0, b1, b2, b3; v2f64 v_alpha = {alpha, alpha}; v2f64 src_a0, src_a1, src_a2, src_a3, src_b, src_b0, src_b1; v2f64 dst0, dst1, dst2, dst3, dst4, dst5, dst6, dst7; @@ -59,12 +58,12 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc2 = pc1 + ldc; pc3 = pc2 + ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -82,11 +81,26 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 4; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 128(%[pa0]) \n\t" + "pref 0, 160(%[pa0]) \n\t" + "pref 0, 32(%[pb0]) \n\t" + "pref 0, 64(%[pb0]) \n\t" + "pref 0, 96(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + LD_DP4_INC(pa0, 2, src_a0, src_a1, src_a2, src_a3); LD_DP2_INC(pb0, 2, src_b0, src_b1); @@ -116,6 +130,17 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, for (l = ((temp - 1) >> 1); l--;) { +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 128(%[pa0]) \n\t" + "pref 0, 160(%[pa0]) \n\t" + "pref 0, 192(%[pa0]) \n\t" + "pref 0, 224(%[pa0]) \n\t" + + : + : [pa0] "r" (pa0) + ); +#endif LD_DP4_INC(pa0, 2, src_a0, src_a1, src_a2, src_a3); LD_DP2_INC(pb0, 2, src_b0, src_b1); @@ -144,6 +169,15 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, res15 += src_a3 * src_b; LD_DP4_INC(pa0, 2, src_a0, src_a1, src_a2, src_a3); +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pb0]) \n\t" + "pref 0, 96(%[pb0]) \n\t" + + : + : [pb0] "r" (pb0) + ); +#endif LD_DP2_INC(pb0, 2, src_b0, src_b1); src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); @@ -201,6 +235,19 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, res15 += src_a3 * src_b; } +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pc0]) \n\t" + "pref 0, 64(%[pc1]) \n\t" + "pref 0, 64(%[pc2]) \n\t" + "pref 0, 64(%[pc3]) \n\t" + + : + : [pc0] "r" (pc0), [pc1] "r" (pc1), + [pc2] "r" (pc2), [pc3] "r" (pc3) + ); +#endif + #if defined(TRMMKERNEL) dst0 = res0 * v_alpha; dst1 = res1 * v_alpha; @@ -248,7 +295,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, dst6 += res14 * v_alpha; dst7 += res15 * v_alpha; #endif - ST_DP4_INC(dst0, dst1, dst2, dst3, pc2, 2); ST_DP4_INC(dst4, dst5, dst6, dst7, pc3, 2); @@ -267,8 +313,103 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 8; // number of values in A #endif +#endif // #if defined(TRMMKERNEL) + } + +#if defined(TRMMKERNEL) && !defined(LEFT) + off += 4; // number of values in A +#endif + + B += (k << 2); + C += (ldc << 2); + } +} + +static void __attribute__ ((noinline)) +dgemmkernel_7x4_core_msa(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, + FLOAT *A, FLOAT *B, FLOAT *C, BLASLONG ldc +#ifdef TRMMKERNEL + , BLASLONG offset +#endif + ) +{ + BLASLONG j, l, temp; +#if defined(TRMMKERNEL) + BLASLONG off; +#endif + FLOAT *pc0, *pc1, *pc2, *pc3, *pa0, *pb0; + FLOAT tmp0, tmp1, tmp2, tmp3; + FLOAT a0, b0, b1, b2, b3; + v2f64 v_alpha = {alpha, alpha}; + v2f64 src_a0, src_a1, src_b, src_b0, src_b1; + v2f64 dst0, dst1, dst2, dst3, dst4, dst5, dst6, dst7; + v2f64 res0, res1, res2, res3, res4, res5, res6, res7; + +#if defined(TRMMKERNEL) && !defined(LEFT) + off = -offset; +#endif + + for (j = (n >> 2); j--;) + { +#if defined(TRMMKERNEL) + pc0 = C; + pc1 = pc0 + ldc; + pc2 = pc1 + ldc; + pc3 = pc2 + ldc; + + pa0 = A; + +#if defined(LEFT) + off = offset; +#endif + + for (l = (m >> 3); l--;) + { +#if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + pb0 = B; +#else + pa0 += off * 8; + pb0 = B + off * 4; +#endif + +#if (defined(LEFT) && !defined(TRANSA)) || (!defined(LEFT) && defined(TRANSA)) + temp = k - off; +#elif defined(LEFT) + temp = off + 8; // number of values in A +#else + temp = off + 4; // number of values in B +#endif + + pc0 += 8; + pc1 += 8; + pc2 += 8; + pc3 += 8; + pa0 += 8 * temp; + pb0 += 4 * temp; + +#if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + temp = k - off; +#ifdef LEFT + temp -= 8; // number of values in A +#else + temp -= 4; // number of values in B +#endif + pa0 += temp * 8; + pb0 += temp * 4; +#endif + +#ifdef LEFT + off += 8; // number of values in A #endif } +#else // #if !defined(TRMMKERNEL) + pc0 = C + 8 * (m >> 3); + pc1 = pc0 + ldc; + pc2 = pc1 + ldc; + pc3 = pc2 + ldc; + + pa0 = A + k * 8 * (m >> 3); +#endif if (m & 4) { @@ -287,7 +428,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 4; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -418,7 +559,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 4; // number of values in A #endif -#endif +#endif // #if defined(TRMMKERNEL) } if (m & 2) @@ -438,7 +579,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 4; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -534,6 +675,11 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, ST_DP(dst2, pc2); ST_DP(dst3, pc3); + pc0 += 2; + pc1 += 2; + pc2 += 2; + pc3 += 2; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -549,11 +695,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 2; // number of values in A #endif -#endif - pc0 += 2; - pc1 += 2; - pc2 += 2; - pc3 += 2; +#endif // #if defined(TRMMKERNEL) } if (m & 1) @@ -573,7 +715,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 4; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -664,6 +806,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc2[0] += tmp2; pc3[0] += tmp3; #endif + pc0 += 1; + pc1 += 1; + pc2 += 1; + pc3 += 1; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -680,35 +826,53 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 1; // number of values in A #endif -#endif - - pc0 += 1; - pc1 += 1; - pc2 += 1; - pc3 += 1; +#endif // #if defined(TRMMKERNEL) } #if defined(TRMMKERNEL) && !defined(LEFT) off += 4; // number of values in A #endif - l = (k << 2); - B = B + l; - i = (ldc << 2); - C = C + i; + B += (k << 2); + C += (ldc << 2); } +} + +static void __attribute__ ((noinline)) +dgemmkernel_8x4_non_core_msa(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, + FLOAT *A, FLOAT *B, FLOAT *C, BLASLONG ldc +#ifdef TRMMKERNEL + , BLASLONG offset +#endif + ) +{ + BLASLONG i, l, temp; +#if defined(TRMMKERNEL) + BLASLONG off; +#endif + FLOAT *pc0, *pc1, *pa0, *pb0; + FLOAT tmp0, tmp1; + FLOAT a0, b0, b1; + v2f64 v_alpha = {alpha, alpha}; + v2f64 src_a0, src_a1, src_a2, src_a3, src_b, src_b0; + v2f64 dst0, dst1, dst2, dst3, dst4, dst5, dst6, dst7; + v2f64 res0, res1, res2, res3, res4, res5, res6, res7; + +#if defined(TRMMKERNEL) && !defined(LEFT) + off = -offset + (4 * (n >> 2)); +#endif if (n & 2) { pc0 = C; pc1 = pc0 + ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -726,12 +890,11 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 2; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif - LD_DP4_INC(pa0, 2, src_a0, src_a1, src_a2, src_a3); src_b0 = LD_DP(pb0); pb0 += 2; @@ -842,7 +1005,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 8; // number of values in A #endif -#endif +#endif // #if defined(TRMMKERNEL) } if (m & 4) @@ -862,7 +1025,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 2; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -953,7 +1116,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 4; // number of values in A #endif -#endif +#endif // #if defined(TRMMKERNEL) } if (m & 2) @@ -973,7 +1136,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 2; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1041,6 +1204,9 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, ST_DP(dst0, pc0); ST_DP(dst1, pc1); + pc0 += 2; + pc1 += 2; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -1056,9 +1222,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 2; // number of values in A #endif -#endif - pc0 += 2; - pc1 += 2; +#endif // #if defined(TRMMKERNEL) } if (m & 1) @@ -1078,7 +1242,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 2; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1139,6 +1303,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc0[0] += tmp0; pc1[0] += tmp1; #endif + pc0 += 1; + pc1 += 1; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1155,31 +1321,27 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 1; // number of values in A #endif -#endif - - pc0 += 1; - pc1 += 1; +#endif // #if defined(TRMMKERNEL) } #if defined(TRMMKERNEL) && !defined(LEFT) off += 2; // number of values in A #endif - l = (k << 1); - B = B + l; - i = (ldc << 1); - C = C + i; + B += (k << 1); + C += (ldc << 1); } if (n & 1) { pc0 = C; - pa0 = A; #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -1197,7 +1359,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 1; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1282,7 +1444,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 8; // number of values in A #endif -#endif +#endif // #if defined(TRMMKERNEL) } if (m & 4) @@ -1302,7 +1464,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 1; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1375,7 +1537,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 4; // number of values in A #endif -#endif +#endif // #if defined(TRMMKERNEL) } if (m & 2) @@ -1395,7 +1557,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 1; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1451,6 +1613,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #endif ST_DP(dst0, pc0); + pc0 += 2; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -1466,8 +1630,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #ifdef LEFT off += 2; // number of values in A #endif -#endif - pc0 += 2; +#endif // #if defined(TRMMKERNEL) } if (m & 1) @@ -1487,7 +1650,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else temp = off + 1; // number of values in B #endif -#else +#else // #if !defined(TRMMKERNEL) pb0 = B; temp = k; #endif @@ -1531,35 +1694,44 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else pc0[0] += alpha * tmp0; #endif + } + } +} -#if defined(TRMMKERNEL) -#if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) - temp = k - off; -#ifdef LEFT - temp -= 1; // number of values in A -#else - temp -= 1; // number of values in B +int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, + FLOAT *C, BLASLONG ldc +#ifdef TRMMKERNEL + , BLASLONG offset #endif - pa0 += temp * 1; - pb0 += temp * 1; + ) +{ + if (n >> 2) + { + if (m >> 3) +#ifdef TRMMKERNEL + dgemmkernel_8x4_core_msa(m, n, k, alpha, A, B, C, ldc, offset); +#else + dgemmkernel_8x4_core_msa(m, n, k, alpha, A, B, C, ldc); #endif -#ifdef LEFT - off += 1; // number of values in A -#endif + if (m & 7) +#ifdef TRMMKERNEL + dgemmkernel_7x4_core_msa(m, n, k, alpha, A, B, C, ldc, offset); +#else + dgemmkernel_7x4_core_msa(m, n, k, alpha, A, B, C, ldc); #endif + } - pc0 += 1; - } + if (n & 3) + { + B = B + (k << 2) * (n >> 2); + C = C + (ldc << 2) * (n >> 2); -#if defined(TRMMKERNEL) && !defined(LEFT) - off += 1; // number of values in A +#ifdef TRMMKERNEL + dgemmkernel_8x4_non_core_msa(m, n, k, alpha, A, B, C, ldc, offset); +#else + dgemmkernel_8x4_non_core_msa(m, n, k, alpha, A, B, C, ldc); #endif - - l = (k << 0); - B = B + l; - i = (ldc << 0); - C = C + i; } return 0; diff --git a/kernel/mips/drot_msa.c b/kernel/mips/drot_msa.c new file mode 100644 index 0000000000..2fb9392b97 --- /dev/null +++ b/kernel/mips/drot_msa.c @@ -0,0 +1,1055 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, + FLOAT c, FLOAT s) +{ + BLASLONG i, j; + FLOAT *px, *py; + FLOAT tp0, tp1, tp2, tp3, tp4, tp5, tp6, tp7; + FLOAT fx0, fx1, fx2, fx3, fy0, fy1, fy2, fy3; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v2f64 out0, out1, out2, out3, out4, out5, out6, out7; + v2f64 out8, out9, out10, out11, out12, out13, out14, out15, c0, s0; + + if (n <= 0) return (0); + + px = x; + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + if ((0 == c) && (0 == s)) + { + v2f64 zero = {0, 0}; + zero = (v2f64) __msa_insert_d((v2i64) zero, 0, 0.0); + zero = (v2f64) __msa_insert_d((v2i64) zero, 1, 0.0); + + /* process 4 floats */ + for (j = (n >> 2); j--;) + { + ST_DP(zero, px); + ST_DP(zero, py); + px += 2; + py += 2; + ST_DP(zero, px); + ST_DP(zero, py); + px += 2; + py += 2; + } + if (n & 2) + { + ST_DP(zero, px); + ST_DP(zero, py); + px += 2; + py += 2; + } + if (n & 1) + { + px[0] = 0; + py[0] = 0; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + x0 = LD_DP(px); px += 2; + x1 = LD_DP(px); px += 2; + x2 = LD_DP(px); px += 2; + x3 = LD_DP(px); px += 2; + y0 = LD_DP(py); py += 2; + y1 = LD_DP(py); py += 2; + y2 = LD_DP(py); py += 2; + y3 = LD_DP(py); py += 2; + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + out0 = x0 + y0; + x4 = LD_DP(px); px += 2; + out1 = y0 - x0; + x5 = LD_DP(px); px += 2; + out2 = x1 + y1; + x6 = LD_DP(px); px += 2; + out3 = y1 - x1; + x7 = LD_DP(px); px += 2; + out4 = x2 + y2; + y4 = LD_DP(py); py += 2; + out5 = y2 - x2; + y5 = LD_DP(py); py += 2; + out6 = x3 + y3; + y6 = LD_DP(py); py += 2; + out7 = y3 - x3; + y7 = LD_DP(py); py += 2; + + ST_DP(out0, x); x += 2; + out8 = x4 + y4; + ST_DP(out1, y); y += 2; + out9 = y4 - x4; + ST_DP(out2, x); x += 2; + out10 = x5 + y5; + ST_DP(out3, y); y += 2; + out11 = y5 - x5; + ST_DP(out4, x); x += 2; + out12 = x6 + y6; + ST_DP(out5, y); y += 2; + out13 = y6 - x6; + ST_DP(out6, x); x += 2; + out14 = x7 + y7; + ST_DP(out7, y); y += 2; + out15 = y7 - x7; + + x0 = LD_DP(px); px += 2; + ST_DP(out8, x); x += 2; + x1 = LD_DP(px); px += 2; + ST_DP(out10, x); x += 2; + x2 = LD_DP(px); px += 2; + ST_DP(out12, x); x += 2; + x3 = LD_DP(px); px += 2; + ST_DP(out14, x); x += 2; + + y0 = LD_DP(py); py += 2; + ST_DP(out9, y); y += 2; + y1 = LD_DP(py); py += 2; + ST_DP(out11, y); y += 2; + y2 = LD_DP(py); py += 2; + ST_DP(out13, y); y += 2; + y3 = LD_DP(py); py += 2; + ST_DP(out15, y); y += 2; + } + + x4 = LD_DP(px); px += 2; + x5 = LD_DP(px); px += 2; + x6 = LD_DP(px); px += 2; + x7 = LD_DP(px); px += 2; + y4 = LD_DP(py); py += 2; + y5 = LD_DP(py); py += 2; + y6 = LD_DP(py); py += 2; + y7 = LD_DP(py); py += 2; + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + out8 = x4 + y4; + out9 = y4 - x4; + out10 = x5 + y5; + out11 = y5 - x5; + out12 = x6 + y6; + out13 = y6 - x6; + out14 = x7 + y7; + out15 = y7 - x7; + + ST_DP8_INC(out0, out2, out4, out6, out8, out10, out12, out14, x, 2); + ST_DP8_INC(out1, out3, out5, out7, out9, out11, out13, out15, y, 2); + } + if (n & 8) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + if (n & 4) + { + LD_DP2_INC(px, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + + ST_DP2_INC(out0, out2, x, 2); + ST_DP2_INC(out1, out3, y, 2); + } + if (n & 2) + { + x0 = LD_DP(px); + y0 = LD_DP(py); + px += 2; + py += 2; + + out0 = x0 + y0; + out1 = y0 - x0; + + ST_DP(out0, x); + ST_DP(out1, y); + x += 2; + y += 2; + } + if (n & 1) + { + tp0 = *x + *y; + *y = *y - *x; + *x = tp0; + } + } + else if (0 == s) + { + c0 = COPY_DOUBLE_TO_VECTOR(c); + + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + y0 = LD_DP(py); py += 2; + x0 *= c0; + y1 = LD_DP(py); py += 2; + x1 *= c0; + y2 = LD_DP(py); py += 2; + x2 *= c0; + y3 = LD_DP(py); py += 2; + x3 *= c0; + y4 = LD_DP(py); py += 2; + x4 *= c0; + y5 = LD_DP(py); py += 2; + x5 *= c0; + y6 = LD_DP(py); py += 2; + x6 *= c0; + y7 = LD_DP(py); py += 2; + x7 *= c0; + + ST_DP(x0, x); x += 2; + y0 *= c0; + ST_DP(x1, x); x += 2; + y1 *= c0; + ST_DP(x2, x); x += 2; + y2 *= c0; + ST_DP(x3, x); x += 2; + y3 *= c0; + ST_DP(x4, x); x += 2; + y4 *= c0; + ST_DP(x5, x); x += 2; + y5 *= c0; + ST_DP(x6, x); x += 2; + y6 *= c0; + ST_DP(x7, x); x += 2; + y7 *= c0; + + x0 = LD_DP(px); px += 2; + ST_DP(y0, y); y += 2; + x1 = LD_DP(px); px += 2; + ST_DP(y1, y); y += 2; + x2 = LD_DP(px); px += 2; + ST_DP(y2, y); y += 2; + x3 = LD_DP(px); px += 2; + ST_DP(y3, y); y += 2; + x4 = LD_DP(px); px += 2; + ST_DP(y4, y); y += 2; + x5 = LD_DP(px); px += 2; + ST_DP(y5, y); y += 2; + x6 = LD_DP(px); px += 2; + ST_DP(y6, y); y += 2; + x7 = LD_DP(px); px += 2; + ST_DP(y7, y); y += 2; + } + + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + x2 *= c0; + y2 *= c0; + x3 *= c0; + y3 *= c0; + x4 *= c0; + y4 *= c0; + x5 *= c0; + y5 *= c0; + x6 *= c0; + y6 *= c0; + x7 *= c0; + y7 *= c0; + + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 2); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 2); + } + if (n & 8) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + out0 = c0 * x0; + out1 = c0 * y0; + out2 = c0 * x1; + out3 = c0 * y1; + out4 = c0 * x2; + out5 = c0 * y2; + out6 = c0 * x3; + out7 = c0 * y3; + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + if (n & 4) + { + LD_DP2_INC(px, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + + out0 = c0 * x0; + out1 = c0 * y0; + out2 = c0 * x1; + out3 = c0 * y1; + + ST_DP2_INC(out0, out2, x, 2); + ST_DP2_INC(out1, out3, y, 2); + } + if (n & 2) + { + x0 = LD_DP(px); + y0 = LD_DP(py); + px += 2; + py += 2; + + out0 = c0 * x0; + out1 = c0 * y0; + + ST_DP(out0, x); + ST_DP(out1, y); + x += 2; + y += 2; + } + if (n & 1) + { + *x *= c; + *y *= c; + } + } + else if (0 == c) + { + s0 = COPY_DOUBLE_TO_VECTOR(s); + + /* process 16 floats */ + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + x4 = LD_DP(px); px += 2; + out0 = s0 * y0; + x5 = LD_DP(px); px += 2; + out2 = s0 * y1; + x6 = LD_DP(px); px += 2; + out4 = s0 * y2; + x7 = LD_DP(px); px += 2; + out6 = s0 * y3; + y4 = LD_DP(py); py += 2; + out1 = -(s0 * x0); + y5 = LD_DP(py); py += 2; + out3 = -(s0 * x1); + y6 = LD_DP(py); py += 2; + out5 = -(s0 * x2); + y7 = LD_DP(py); py += 2; + out7 = -(s0 * x3); + + ST_DP(out0, x); x += 2; + out0 = s0 * y4; + ST_DP(out2, x); x += 2; + out2 = s0 * y5; + ST_DP(out4, x); x += 2; + out4 = s0 * y6; + ST_DP(out6, x); x += 2; + out6 = s0 * y7; + ST_DP(out1, y); y += 2; + out1 = -(s0 * x4); + ST_DP(out3, y); y += 2; + out3 = -(s0 * x5); + ST_DP(out5, y); y += 2; + out5 = -(s0 * x6); + ST_DP(out7, y); y += 2; + out7 = -(s0 * x7); + + x0 = LD_DP(px); px += 2; + ST_DP(out0, x); x += 2; + x1 = LD_DP(px); px += 2; + ST_DP(out2, x); x += 2; + x2 = LD_DP(px); px += 2; + ST_DP(out4, x); x += 2; + x3 = LD_DP(px); px += 2; + ST_DP(out6, x); x += 2; + y0 = LD_DP(py); py += 2; + ST_DP(out1, y); y += 2; + y1 = LD_DP(py); py += 2; + ST_DP(out3, y); y += 2; + y2 = LD_DP(py); py += 2; + ST_DP(out5, y); y += 2; + y3 = LD_DP(py); py += 2; + ST_DP(out7, y); y += 2; + } + + out0 = s0 * y0; + out2 = s0 * y1; + out4 = s0 * y2; + out6 = s0 * y3; + out1 = -(s0 * x0); + out3 = -(s0 * x1); + out5 = -(s0 * x2); + out7 = -(s0 * x3); + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + + LD_DP4_INC(px, 2, x4, x5, x6, x7); + LD_DP4_INC(py, 2, y4, y5, y6, y7); + + out0 = s0 * y4; + out2 = s0 * y5; + out4 = s0 * y6; + out6 = s0 * y7; + out1 = -(s0 * x4); + out3 = -(s0 * x5); + out5 = -(s0 * x6); + out7 = -(s0 * x7); + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + if (n & 8) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + out4 = s0 * y2; + out5 = - (s0 * x2); + out6 = s0 * y3; + out7 = - (s0 * x3); + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + if (n & 4) + { + LD_DP2_INC(px, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + + ST_DP2_INC(out0, out2, x, 2); + ST_DP2_INC(out1, out3, y, 2); + } + if (n & 2) + { + x0 = LD_DP(px); px += 2; + y0 = LD_DP(py); py += 2; + + out0 = s0 * y0; + out1 = - (s0 * x0); + + ST_DP(out0, x); x += 2; + ST_DP(out1, y); y += 2; + } + if (n & 1) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = s * fy0; + tp1 = - (s * fx0); + tp2 = s * fy1; + tp3 = - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + } + else + { + c0 = COPY_DOUBLE_TO_VECTOR(c); + s0 = COPY_DOUBLE_TO_VECTOR(s); + + /* process 14 doubles */ + if (n >> 4) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + for (j = (n >> 4) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + x4 = LD_DP(px); px += 2; + out0 = c0 * x0; + x5 = LD_DP(px); px += 2; + out2 = c0 * x1; + x6 = LD_DP(px); px += 2; + out4 = c0 * x2; + x7 = LD_DP(px); px += 2; + out6 = c0 * x3; + y4 = LD_DP(py); py += 2; + out1 = c0 * y0; + y5 = LD_DP(py); py += 2; + out3 = c0 * y1; + y6 = LD_DP(py); py += 2; + out5 = c0 * y2; + y7 = LD_DP(py); py += 2; + out7 = c0 * y3; + + out0 += s0 * y0; + out2 += s0 * y1; + out4 += s0 * y2; + out6 += s0 * y3; + out1 -= s0 * x0; + out3 -= s0 * x1; + out5 -= s0 * x2; + out7 -= s0 * x3; + + ST_DP(out0, x); x += 2; + out0 = c0 * x4; + ST_DP(out2, x); x += 2; + out2 = c0 * x5; + ST_DP(out4, x); x += 2; + out4 = c0 * x6; + ST_DP(out6, x); x += 2; + out6 = c0 * x7; + ST_DP(out1, y); y += 2; + out1 = c0 * y4; + ST_DP(out3, y); y += 2; + out3 = c0 * y5; + ST_DP(out5, y); y += 2; + out5 = c0 * y6; + ST_DP(out7, y); y += 2; + out7 = c0 * y7; + + x0 = LD_DP(px); px += 2; + out0 += s0 * y4; + x1 = LD_DP(px); px += 2; + out2 += s0 * y5; + x2 = LD_DP(px); px += 2; + out4 += s0 * y6; + x3 = LD_DP(px); px += 2; + out6 += s0 * y7; + y0 = LD_DP(py); py += 2; + out1 -= s0 * x4; + y1 = LD_DP(py); py += 2; + out3 -= s0 * x5; + y2 = LD_DP(py); py += 2; + out5 -= s0 * x6; + y3 = LD_DP(py); py += 2; + out7 -= s0 * x7; + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + + out0 = c0 * x0; + out0 += s0 * y0; + out1 = c0 * y0; + out1 -= s0 * x0; + out2 = c0 * x1; + out2 += s0 * y1; + out3 = c0 * y1; + out3 -= s0 * x1; + out4 = c0 * x2; + out4 += s0 * y2; + out5 = c0 * y2; + out5 -= s0 * x2; + out6 = c0 * x3; + out6 += s0 * y3; + out7 = c0 * y3; + out7 -= s0 * x3; + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + + LD_DP4_INC(px, 2, x4, x5, x6, x7); + LD_DP4_INC(py, 2, y4, y5, y6, y7); + + out8 = c0 * x4; + out8 += s0 * y4; + out9 = c0 * y4; + out9 -= s0 * x4; + out10 = c0 * x5; + out10 += s0 * y5; + out11 = c0 * y5; + out11 -= s0 * x5; + out12 = c0 * x6; + out12 += s0 * y6; + out13 = c0 * y6; + out13 -= s0 * x6; + out14 = c0 * x7; + out14 += s0 * y7; + out15 = c0 * y7; + out15 -= s0 * x7; + + ST_DP4_INC(out8, out10, out12, out14, x, 2); + ST_DP4_INC(out9, out11, out13, out15, y, 2); + } + if (n & 8) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + out4 = (c0 * x2) + (s0 * y2); + out5 = (c0 * y2) - (s0 * x2); + out6 = (c0 * x3) + (s0 * y3); + out7 = (c0 * y3) - (s0 * x3); + + ST_DP4_INC(out0, out2, out4, out6, x, 2); + ST_DP4_INC(out1, out3, out5, out7, y, 2); + } + if (n & 4) + { + LD_DP2_INC(px, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + + ST_DP2_INC(out0, out2, x, 2); + ST_DP2_INC(out1, out3, y, 2); + } + if (n & 2) + { + x0 = LD_DP(px); + y0 = LD_DP(py); + px += 2; + py += 2; + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + + ST_DP(out0, x); + ST_DP(out1, y); + x += 2; + y += 2; + } + if (n & 1) + { + tp0 = c * *x + s * *y; + *y = c * *y - s * *x; + *x = tp0; + } + } + } + else + { + if ((0 == c) && (0 == s)) + { + for (i = n; i--;) + { + *x = 0; + *y = 0; + + x += inc_x; + y += inc_y; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) -1; i--;) + { + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fy2 - fx2; + tp6 = fx3 + fy3; + tp7 = fy3 - fx3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fy2 - fx2; + tp6 = fx3 + fy3; + tp7 = fy3 - fx3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + + *x = tp0; + *y = tp1; + } + } + else if (0 == s) + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) - 1; i--;) + { + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + tp4 = c * fx2; + tp5 = c * fy2; + tp6 = c * fx3; + tp7 = c * fy3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + tp4 = c * fx2; + tp5 = c * fy2; + tp6 = c * fx3; + tp7 = c * fy3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = c * fx0; + tp1 = c * fy0; + + *x = tp0; + *y = tp1; + } + } + else + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) - 1; i--;) + { + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + tp2 = c * fx1 + s * fy1; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fy2 - s * fx2; + tp6 = c * fx3 + s * fy3; + tp7 = c * fy3 - s * fx3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + tp2 = c * fx1 + s * fy1; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fy2 - s * fx2; + tp6 = c * fx3 + s * fy3; + tp7 = c * fy3 - s * fx3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = (c * fx0) + (s * fy0); + tp1 = (c * fy0) - (s * fx0); + tp2 = (c * fx1) + (s * fy1); + tp3 = (c * fy1) - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = (c * fx0) + (s * fy0); + tp1 = (c * fy0) - (s * fx0); + + *x = tp0; + *y = tp1; + } + } + } + + return 0; +} diff --git a/kernel/mips/dscal_msa.c b/kernel/mips/dscal_msa.c new file mode 100644 index 0000000000..6ce0375ab3 --- /dev/null +++ b/kernel/mips/dscal_msa.c @@ -0,0 +1,368 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, + BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i; + FLOAT *px; + FLOAT f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + v2f64 da_vec; + + px = x; + + if (1 == inc_x) + { + if (0.0 == da) + { + v2f64 zero_v = __msa_cast_to_vector_double(0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 0, 0.0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 1, 0.0); + + for (i = (n >> 5); i--;) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + } + + if (n & 31) + { + if (n & 16) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + } + + if (n & 8) + { + ST_DP4_INC(zero_v, zero_v, zero_v, zero_v, x, 2); + } + + if (n & 4) + { + ST_DP2_INC(zero_v, zero_v, x, 2); + } + + if (n & 2) + { + *x = 0; x += 1; + *x = 0; x += 1; + } + + if (n & 1) + { + *x = 0; + } + } + } + else + { + da_vec = COPY_DOUBLE_TO_VECTOR(da); + + if (n > 31) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32 + 16; + + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = 0; i < (n >> 5) - 1; i++) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + x8 = LD_DP(px); px += 2; + x0 *= da_vec; + x9 = LD_DP(px); px += 2; + x1 *= da_vec; + x10 = LD_DP(px); px += 2; + x2 *= da_vec; + x11 = LD_DP(px); px += 2; + x3 *= da_vec; + x12 = LD_DP(px); px += 2; + x4 *= da_vec; + x13 = LD_DP(px); px += 2; + x5 *= da_vec; + x14 = LD_DP(px); px += 2; + x6 *= da_vec; + x15 = LD_DP(px); px += 2; + x7 *= da_vec; + x8 *= da_vec; + ST_DP(x0, x); x += 2; + x9 *= da_vec; + ST_DP(x1, x); x += 2; + x10 *= da_vec; + ST_DP(x2, x); x += 2; + x11 *= da_vec; + ST_DP(x3, x); x += 2; + x12 *= da_vec; + ST_DP(x4, x); x += 2; + x13 *= da_vec; + ST_DP(x5, x); x += 2; + x14 *= da_vec; + ST_DP(x6, x); x += 2; + x15 *= da_vec; + ST_DP(x7, x); x += 2; + ST_DP(x8, x); x += 2; + x0 = LD_DP(px); px += 2; + ST_DP(x9, x); x += 2; + x1 = LD_DP(px); px += 2; + ST_DP(x10, x); x += 2; + x2 = LD_DP(px); px += 2; + ST_DP(x11, x); x += 2; + x3 = LD_DP(px); px += 2; + ST_DP(x12, x); x += 2; + x4 = LD_DP(px); px += 2; + ST_DP(x13, x); x += 2; + x5 = LD_DP(px); px += 2; + ST_DP(x14, x); x += 2; + x6 = LD_DP(px); px += 2; + ST_DP(x15, x); x += 2; + x7 = LD_DP(px); px += 2; + } + + x8 = LD_DP(px); px += 2; + x0 *= da_vec; + x9 = LD_DP(px); px += 2; + x1 *= da_vec; + x10 = LD_DP(px); px += 2; + x2 *= da_vec; + x11 = LD_DP(px); px += 2; + x3 *= da_vec; + x12 = LD_DP(px); px += 2; + x4 *= da_vec; + x13 = LD_DP(px); px += 2; + x5 *= da_vec; + x14 = LD_DP(px); px += 2; + x6 *= da_vec; + x15 = LD_DP(px); px += 2; + x7 *= da_vec; + x8 *= da_vec; + ST_DP(x0, x); x += 2; + x9 *= da_vec; + ST_DP(x1, x); x += 2; + x10 *= da_vec; + ST_DP(x2, x); x += 2; + x11 *= da_vec; + ST_DP(x3, x); x += 2; + x12 *= da_vec; + ST_DP(x4, x); x += 2; + x13 *= da_vec; + ST_DP(x5, x); x += 2; + x15 *= da_vec; + ST_DP(x6, x); x += 2; + x14 *= da_vec; + ST_DP(x7, x); x += 2; + + ST_DP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, x, 2); + } + + if (n & 31) + { + if (n & 16) + { + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_vec, x1, da_vec, x2, da_vec, x3, da_vec, x0, x1, x2, x3); + MUL4(x4, da_vec, x5, da_vec, x6, da_vec, x7, da_vec, x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 2); + } + + if (n & 8) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + MUL4(x0, da_vec, x1, da_vec, x2, da_vec, x3, da_vec, x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, x, 2); + } + + if (n & 4) + { + LD_DP2_INC(px, 2, x0, x1); + MUL2(x0, da_vec, x1, da_vec, x0, x1); + ST_DP2_INC(x0, x1, x, 2); + } + + if (n & 2) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da, f1, da, f0, f1); + ST_GP2_INC(f0, f1, x, 1); + } + + if (n & 1) + { + *x *= da; + } + } + } + } + else + { + if (da == 0.0) + { + for (i = n; i--;) + { + *x = 0.0; + + x += inc_x; + } + } + else + { + if (n > 15) + { + LD_GP8_INC(px, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + for (i = 0; i < (n >> 4) - 1; i++) + { + LD_GP8_INC(px, inc_x, f8, f9, f10, f11, f12, f13, f14, f15); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + + f4 *= da; + f5 *= da; + *x = f0; x += inc_x; + f6 *= da; + *x = f1; x += inc_x; + f7 *= da; + *x = f2; x += inc_x; + f8 *= da; + *x = f3; x += inc_x; + f9 *= da; + *x = f4; x += inc_x; + f10 *= da; + *x = f5; x += inc_x; + f11 *= da; + *x = f6; x += inc_x; + f12 *= da; + *x = f7; x += inc_x; + f13 *= da; + *x = f8; x += inc_x; + f14 *= da; + *x = f9; x += inc_x; + f15 *= da; + *x = f10; x += inc_x; + *x = f11; x += inc_x; + f0 = *px; px += inc_x; + *x = f12; x += inc_x; + f1 = *px; px += inc_x; + *x = f13; x += inc_x; + f2 = *px; px += inc_x; + *x = f14; x += inc_x; + f3 = *px; px += inc_x; + *x = f15; x += inc_x; + f4 = *px; px += inc_x; + f5 = *px; px += inc_x; + f6 = *px; px += inc_x; + f7 = *px; px += inc_x; + } + + LD_GP8_INC(px, inc_x, f8, f9, f10, f11, f12, f13, f14, f15); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + + f4 *= da; + f5 *= da; + *x = f0; x += inc_x; + f6 *= da; + *x = f1; x += inc_x; + f7 *= da; + *x = f2; x += inc_x; + f8 *= da; + *x = f3; x += inc_x; + f9 *= da; + *x = f4; x += inc_x; + f10 *= da; + *x = f5; x += inc_x; + f11 *= da; + *x = f6; x += inc_x; + f12 *= da; + *x = f7; x += inc_x; + f13 *= da; + *x = f8; x += inc_x; + f14 *= da; + *x = f9; x += inc_x; + f15 *= da; + *x = f10; x += inc_x; + *x = f11; x += inc_x; + *x = f12; x += inc_x; + *x = f13; x += inc_x; + *x = f14; x += inc_x; + *x = f15; x += inc_x; + } + + if (n & 15) + { + if (n & 8) + { + LD_GP8_INC(px, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + MUL4(f4, da, f5, da, f6, da, f7, da, f4, f5, f6, f7); + ST_GP8_INC(f0, f1, f2, f3, f4, f5, f6, f7, x, inc_x); + } + + if (n & 4) + { + LD_GP4_INC(px, inc_x, f0, f1, f2, f3); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, x, inc_x); + } + + if (n & 2) + { + LD_GP2_INC(px, inc_x, f0, f1); + MUL2(f0, da, f1, da, f0, f1); + ST_GP2_INC(f0, f1, x, inc_x); + } + + if (n & 1) + { + *x *= da; + } + } + } + } + + return 0; +} diff --git a/kernel/mips/dswap_msa.c b/kernel/mips/dswap_msa.c new file mode 100644 index 0000000000..7b1f024770 --- /dev/null +++ b/kernel/mips/dswap_msa.c @@ -0,0 +1,253 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT dummy3, + FLOAT *srcx, BLASLONG inc_x, FLOAT *srcy, BLASLONG inc_y, + FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i = 0, pref_offsetx, pref_offsety; + FLOAT *px, *py; + FLOAT x0, x1, x2, x3, x4, x5, x6, x7; + FLOAT y0, y1, y2, y3, y4, y5, y6, y7; + v2f64 xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7; + v2f64 yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7; + + if (n < 0) return (0); + + pref_offsetx = (BLASLONG)srcx & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)srcy & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + px = srcx; + py = srcy; + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n >> 4) + { + LD_DP8_INC(px, 2, xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7); + + for (i = (n >> 4) - 1; i--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + yv0 = LD_DP(py); py += 2; + ST_DP(xv0, srcy); srcy += 2; + yv1 = LD_DP(py); py += 2; + ST_DP(xv1, srcy); srcy += 2; + yv2 = LD_DP(py); py += 2; + ST_DP(xv2, srcy); srcy += 2; + yv3 = LD_DP(py); py += 2; + ST_DP(xv3, srcy); srcy += 2; + yv4 = LD_DP(py); py += 2; + ST_DP(xv4, srcy); srcy += 2; + yv5 = LD_DP(py); py += 2; + ST_DP(xv5, srcy); srcy += 2; + yv6 = LD_DP(py); py += 2; + ST_DP(xv6, srcy); srcy += 2; + yv7 = LD_DP(py); py += 2; + ST_DP(xv7, srcy); srcy += 2; + + xv0 = LD_DP(px); px += 2; + ST_DP(yv0, srcx); srcx += 2; + xv1 = LD_DP(px); px += 2; + ST_DP(yv1, srcx); srcx += 2; + xv2 = LD_DP(px); px += 2; + ST_DP(yv2, srcx); srcx += 2; + xv3 = LD_DP(px); px += 2; + ST_DP(yv3, srcx); srcx += 2; + xv4 = LD_DP(px); px += 2; + ST_DP(yv4, srcx); srcx += 2; + xv5 = LD_DP(px); px += 2; + ST_DP(yv5, srcx); srcx += 2; + xv6 = LD_DP(px); px += 2; + ST_DP(yv6, srcx); srcx += 2; + xv7 = LD_DP(px); px += 2; + ST_DP(yv7, srcx); srcx += 2; + } + + LD_DP8_INC(py, 2, yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7); + ST_DP8_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7, srcy, 2); + ST_DP8_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7, srcx, 2); + } + + if (n & 15) + { + if ((n & 8) && (n & 4) && (n & 2)) + { + LD_DP7_INC(px, 2, xv0, xv1, xv2, xv3, xv4, xv5, xv6); + LD_DP7_INC(py, 2, yv0, yv1, yv2, yv3, yv4, yv5, yv6); + ST_DP7_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, srcy, 2); + ST_DP7_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, srcx, 2); + } + else if ((n & 8) && (n & 4)) + { + LD_DP6_INC(px, 2, xv0, xv1, xv2, xv3, xv4, xv5); + LD_DP6_INC(py, 2, yv0, yv1, yv2, yv3, yv4, yv5); + ST_DP6_INC(xv0, xv1, xv2, xv3, xv4, xv5, srcy, 2); + ST_DP6_INC(yv0, yv1, yv2, yv3, yv4, yv5, srcx, 2); + } + else if ((n & 8) && (n & 2)) + { + LD_DP5_INC(px, 2, xv0, xv1, xv2, xv3, xv4); + LD_DP5_INC(py, 2, yv0, yv1, yv2, yv3, yv4); + ST_DP5_INC(xv0, xv1, xv2, xv3, xv4, srcy, 2); + ST_DP5_INC(yv0, yv1, yv2, yv3, yv4, srcx, 2); + } + else if ((n & 4) && (n & 2)) + { + LD_DP3_INC(px, 2, xv0, xv1, xv2); + LD_DP3_INC(py, 2, yv0, yv1, yv2); + ST_DP3_INC(xv0, xv1, xv2, srcy, 2); + ST_DP3_INC(yv0, yv1, yv2, srcx, 2); + } + else if (n & 8) + { + LD_DP4_INC(px, 2, xv0, xv1, xv2, xv3); + LD_DP4_INC(py, 2, yv0, yv1, yv2, yv3); + ST_DP4_INC(xv0, xv1, xv2, xv3, srcy, 2); + ST_DP4_INC(yv0, yv1, yv2, yv3, srcx, 2); + } + else if (n & 4) + { + LD_DP2_INC(px, 2, xv0, xv1); + LD_DP2_INC(py, 2, yv0, yv1); + ST_DP2_INC(xv0, xv1, srcy, 2); + ST_DP2_INC(yv0, yv1, srcx, 2); + } + else if (n & 2) + { + xv0 = LD_DP(px); + yv0 = LD_DP(py); + + px += 2; + py += 2; + + ST_DP(xv0, srcy); + ST_DP(yv0, srcx); + + srcx += 2; + srcy += 2; + } + + if (n & 1) + { + x0 = px[0]; + y0 = py[0]; + srcx[0] = y0; + srcy[0] = x0; + } + } + } + else + { + for (i = (n >> 3); i--;) + { + LD_GP8_INC(px, inc_x, x0, x1, x2, x3, x4, x5, x6, x7); + LD_GP8_INC(py, inc_y, y0, y1, y2, y3, y4, y5, y6, y7); + ST_GP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, srcy, inc_y); + ST_GP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, srcx, inc_x); + } + + if (n & 7) + { + if ((n & 4) && (n & 2) && (n & 1)) + { + LD_GP7_INC(px, inc_x, x0, x1, x2, x3, x4, x5, x6); + LD_GP7_INC(py, inc_y, y0, y1, y2, y3, y4, y5, y6); + ST_GP7_INC(x0, x1, x2, x3, x4, x5, x6, srcy, inc_y); + ST_GP7_INC(y0, y1, y2, y3, y4, y5, y6, srcx, inc_x); + } + else if ((n & 4) && (n & 2)) + { + LD_GP6_INC(px, inc_x, x0, x1, x2, x3, x4, x5); + LD_GP6_INC(py, inc_y, y0, y1, y2, y3, y4, y5); + ST_GP6_INC(x0, x1, x2, x3, x4, x5, srcy, inc_y); + ST_GP6_INC(y0, y1, y2, y3, y4, y5, srcx, inc_x); + } + else if ((n & 4) && (n & 1)) + { + LD_GP5_INC(px, inc_x, x0, x1, x2, x3, x4); + LD_GP5_INC(py, inc_y, y0, y1, y2, y3, y4); + ST_GP5_INC(x0, x1, x2, x3, x4, srcy, inc_y); + ST_GP5_INC(y0, y1, y2, y3, y4, srcx, inc_x); + } + else if ((n & 2) && (n & 1)) + { + LD_GP3_INC(px, inc_x, x0, x1, x2); + LD_GP3_INC(py, inc_y, y0, y1, y2); + ST_GP3_INC(x0, x1, x2, srcy, inc_y); + ST_GP3_INC(y0, y1, y2, srcx, inc_x); + } + else if (n & 4) + { + LD_GP4_INC(px, inc_x, x0, x1, x2, x3); + LD_GP4_INC(py, inc_y, y0, y1, y2, y3); + ST_GP4_INC(x0, x1, x2, x3, srcy, inc_y); + ST_GP4_INC(y0, y1, y2, y3, srcx, inc_x); + } + else if (n & 2) + { + LD_GP2_INC(px, inc_x, x0, x1); + LD_GP2_INC(py, inc_y, y0, y1); + ST_GP2_INC(x0, x1, srcy, inc_y); + ST_GP2_INC(y0, y1, srcx, inc_x); + } + else if (n & 1) + { + x0 = *srcx; + y0 = *srcy; + + *srcx = y0; + *srcy = x0; + } + } + } + + return (0); +} diff --git a/kernel/mips/dtrsm_kernel_LN_8x4_msa.c b/kernel/mips/dtrsm_kernel_LN_8x4_msa.c index dc21dab456..9fb5141cab 100644 --- a/kernel/mips/dtrsm_kernel_LN_8x4_msa.c +++ b/kernel/mips/dtrsm_kernel_LN_8x4_msa.c @@ -28,7 +28,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -static void dsolve_8x4_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) +static __attribute__ ((noinline)) +void dsolve_8x4_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { v2f64 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v2f64 res_c0, res_c1, res_c2, res_c3, res_c4, res_c5, res_c6, res_c7; @@ -44,6 +45,19 @@ static void dsolve_8x4_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO FLOAT *c_nxt2line = c + 2 * ldc; FLOAT *c_nxt3line = c + 3 * ldc; + PREF_OFFSET(a, -96); + PREF_OFFSET(a, -32); + PREF_OFFSET(a, -160); + PREF_OFFSET(a, -224); + PREF_OFFSET(a, -64); + PREF_OFFSET(a, -128); + PREF_OFFSET(a, -192); + PREF_OFFSET(a, -256); + PREF_OFFSET(a, -320); + PREF_OFFSET(a, -384); + PREF_OFFSET(a, -448); + PREF_OFFSET(a, -512); + LD_DP4(c, 2, src_c0, src_c1, src_c2, src_c3); LD_DP4(c_nxt1line, 2, src_c4, src_c5, src_c6, src_c7); LD_DP4(c_nxt2line, 2, src_c8, src_c9, src_c10, src_c11); @@ -51,20 +65,29 @@ static void dsolve_8x4_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO if (bk > 0) { - BLASLONG i; - FLOAT *pba = a, *pbb = b; - v2f64 src_b, src_b0, src_b1, src_b2, src_b3; + BLASLONG i, pref_offset; + FLOAT *pba = a, *pbb = b, *pa0_pref; + v2f64 src_b, src_b0, src_b1; - LD_DP4(pba, 2, src_a0, src_a1, src_a2, src_a3); - LD_DP2(pbb, 2, src_b0, src_b1); + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - for (i = (bk - 1); i--;) + if (pref_offset) { - pba += 8; - pbb += 4; + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - LD_DP4(pba, 2, src_a8, src_a9, src_a16, src_a17); - LD_DP2(pbb, 2, src_b2, src_b3); + pa0_pref = a + pref_offset; + + for (i = bk >> 1; i--;) + { + PREF_OFFSET(pa0_pref, 128); + PREF_OFFSET(pa0_pref, 160); + PREF_OFFSET(pa0_pref, 192); + PREF_OFFSET(pa0_pref, 224); + + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); src_c0 -= src_a0 * src_b; @@ -90,37 +113,65 @@ static void dsolve_8x4_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO src_c14 -= src_a2 * src_b; src_c15 -= src_a3 * src_b; - src_a0 = src_a8; - src_a1 = src_a9; - src_a2 = src_a16; - src_a3 = src_a17; - src_b0 = src_b2; - src_b1 = src_b3; + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + + pa0_pref += 16; } - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); - src_c0 -= src_a0 * src_b; - src_c1 -= src_a1 * src_b; - src_c2 -= src_a2 * src_b; - src_c3 -= src_a3 * src_b; + if (bk & 1) + { + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); - src_c4 -= src_a0 * src_b; - src_c5 -= src_a1 * src_b; - src_c6 -= src_a2 * src_b; - src_c7 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); - src_c8 -= src_a0 * src_b; - src_c9 -= src_a1 * src_b; - src_c10 -= src_a2 * src_b; - src_c11 -= src_a3 * src_b; - - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); - src_c12 -= src_a0 * src_b; - src_c13 -= src_a1 * src_b; - src_c14 -= src_a2 * src_b; - src_c15 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + } } a -= 64; @@ -1180,7 +1231,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, bb = b + 4 * kk; cc = c + (m - 1); - dsolve_1x4_ln_msa(aa, bb, cc, ldc, k - kk); + dsolve_1x4_ln_msa(aa, bb, cc, ldc, (k - kk)); kk -= 1; } @@ -1191,7 +1242,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, bb = b + 4 * kk; cc = c + ((m & -2) - 2); - dsolve_2x4_ln_msa(aa, bb, cc, ldc, k - kk); + dsolve_2x4_ln_msa(aa, bb, cc, ldc, (k - kk)); kk -= 2; } @@ -1202,7 +1253,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, bb = b + 4 * kk; cc = c + ((m & -4) - 4); - dsolve_4x4_ln_msa(aa, bb, cc, ldc, k - kk); + dsolve_4x4_ln_msa(aa, bb, cc, ldc, (k - kk)); kk -= 4; } @@ -1216,7 +1267,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, do { - dsolve_8x4_ln_msa(aa + 8 * kk, b + 4 * kk, cc, ldc, k - kk); + dsolve_8x4_ln_msa(aa + 8 * kk, b + 4 * kk, cc, ldc, (k - kk)); aa -= 8 * k; cc -= 8; @@ -1252,7 +1303,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, aa = a + ((m & -2) - 2) * k; cc = c + ((m & -2) - 2); - dsolve_2x2_ln_msa(aa + kk * 2, b + kk * 2, cc, ldc, k - kk); + dsolve_2x2_ln_msa(aa + kk * 2, b + kk * 2, cc, ldc, (k - kk)); kk -= 2; } @@ -1262,7 +1313,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, aa = a + ((m & -4) - 4) * k; cc = c + ((m & -4) - 4); - dsolve_4x2_ln_msa(aa + kk * 4, b + kk * 2, cc, ldc, k - kk); + dsolve_4x2_ln_msa(aa + kk * 4, b + kk * 2, cc, ldc, (k - kk)); kk -= 4; } @@ -1276,7 +1327,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, do { - dsolve_8x2_ln_msa(aa + kk * 8, b + kk * 2, cc, ldc, k - kk); + dsolve_8x2_ln_msa(aa + kk * 8, b + kk * 2, cc, ldc, (k - kk)); aa -= 8 * k; cc -= 8; @@ -1310,7 +1361,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, aa = a + ((m & -2) - 2) * k + kk * 2; cc = c + ((m & -2) - 2); - dsolve_2x1_ln_msa(aa, b + kk, cc, k - kk); + dsolve_2x1_ln_msa(aa, b + kk, cc, (k - kk)); kk -= 2; } @@ -1320,7 +1371,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, aa = a + ((m & -4) - 4) * k; cc = c + ((m & -4) - 4); - dsolve_4x1_ln_msa(aa + 4 * kk, b + kk, cc, k - kk); + dsolve_4x1_ln_msa(aa + 4 * kk, b + kk, cc, (k - kk)); kk -= 4; } @@ -1334,7 +1385,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, do { - dsolve_8x1_ln_msa(aa + 8 * kk, b + kk, cc, k - kk); + dsolve_8x1_ln_msa(aa + 8 * kk, b + kk, cc, (k - kk)); aa -= 8 * k; cc -= 8; diff --git a/kernel/mips/dtrsm_kernel_LT_8x4_msa.c b/kernel/mips/dtrsm_kernel_LT_8x4_msa.c index 897fd313b4..525fc8585b 100644 --- a/kernel/mips/dtrsm_kernel_LT_8x4_msa.c +++ b/kernel/mips/dtrsm_kernel_LT_8x4_msa.c @@ -28,7 +28,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -static void dsolve_8x4_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) +static __attribute__ ((noinline)) +void dsolve_8x4_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { v2f64 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v2f64 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; @@ -43,6 +44,21 @@ static void dsolve_8x4_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO FLOAT *c_nxt2line = c + 2 * ldc; FLOAT *c_nxt3line = c + 3 * ldc; + a += bk * 8; + PREF_OFFSET(a, 0); + PREF_OFFSET(a, 32); + PREF_OFFSET(a, 72); + PREF_OFFSET(a, 104); + PREF_OFFSET(a, 144); + PREF_OFFSET(a, 176); + PREF_OFFSET(a, 216); + PREF_OFFSET(a, 248); + PREF_OFFSET(a, 288); + PREF_OFFSET(a, 360); + PREF_OFFSET(a, 504); + PREF_OFFSET(a, 432); + a -= bk * 8; + LD_DP4(c, 2, src_c0, src_c1, src_c2, src_c3); LD_DP4(c_nxt1line, 2, src_c4, src_c5, src_c6, src_c7); LD_DP4(c_nxt2line, 2, src_c8, src_c9, src_c10, src_c11); @@ -50,19 +66,29 @@ static void dsolve_8x4_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO if (bk) { - BLASLONG i; - v2f64 src_b, src_b0, src_b1, src_b2, src_b3; + BLASLONG i, pref_offset; + FLOAT *pa0_pref; + v2f64 src_b, src_b0, src_b1; - LD_DP4(a, 2, src_a0, src_a1, src_a2, src_a3); - LD_DP2(b, 2, src_b0, src_b1); + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - for (i = (bk - 1); i--;) + if (pref_offset) { - a += 8; - b += 4; + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - LD_DP4(a, 2, src_a4, src_a5, src_a6, src_a7); - LD_DP2(b, 2, src_b2, src_b3); + pa0_pref = a + pref_offset; + + for (i = (bk >> 1); i--;) + { + PREF_OFFSET(pa0_pref, 128); + PREF_OFFSET(pa0_pref, 160); + PREF_OFFSET(pa0_pref, 192); + PREF_OFFSET(pa0_pref, 224); + + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); src_c0 -= src_a0 * src_b; @@ -88,40 +114,65 @@ static void dsolve_8x4_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO src_c14 -= src_a2 * src_b; src_c15 -= src_a3 * src_b; - src_a0 = src_a4; - src_a1 = src_a5; - src_a2 = src_a6; - src_a3 = src_a7; - src_b0 = src_b2; - src_b1 = src_b3; + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + + pa0_pref += 16; } - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); - src_c0 -= src_a0 * src_b; - src_c1 -= src_a1 * src_b; - src_c2 -= src_a2 * src_b; - src_c3 -= src_a3 * src_b; + if (bk & 1) + { + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); - src_c4 -= src_a0 * src_b; - src_c5 -= src_a1 * src_b; - src_c6 -= src_a2 * src_b; - src_c7 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); - src_c8 -= src_a0 * src_b; - src_c9 -= src_a1 * src_b; - src_c10 -= src_a2 * src_b; - src_c11 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); - src_c12 -= src_a0 * src_b; - src_c13 -= src_a1 * src_b; - src_c14 -= src_a2 * src_b; - src_c15 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; - a += 8; - b += 4; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + } } ILVRL_D2_DP(src_c4, src_c0, res_c0, res_c1); diff --git a/kernel/mips/dtrsm_kernel_RN_8x4_msa.c b/kernel/mips/dtrsm_kernel_RN_8x4_msa.c index 44313241e9..cb361c5112 100644 --- a/kernel/mips/dtrsm_kernel_RN_8x4_msa.c +++ b/kernel/mips/dtrsm_kernel_RN_8x4_msa.c @@ -28,7 +28,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -static void dsolve_8x4_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) +static __attribute__ ((noinline)) +void dsolve_8x4_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { v2f64 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v2f64 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; @@ -45,20 +46,29 @@ static void dsolve_8x4_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO if (bk) { - BLASLONG i; - v2f64 src_a0, src_a1, src_a2, src_a3, src_a4, src_a5, src_a6, src_a7; - v2f64 src_b; + BLASLONG i, pref_offset; + FLOAT *pa0_pref; + v2f64 src_a0, src_a1, src_a2, src_a3, src_b; - LD_DP4(a, 2, src_a0, src_a1, src_a2, src_a3); - LD_DP2(b, 2, src_b0, src_b1); + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - for (i = (bk - 1); i--;) + if (pref_offset) { - a += 8; - b += 4; + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - LD_DP4(a, 2, src_a4, src_a5, src_a6, src_a7); - LD_DP2(b, 2, src_b2, src_b3); + pa0_pref = a + pref_offset; + + for (i = (bk >> 1); i--;) + { + PREF_OFFSET(pa0_pref, 128); + PREF_OFFSET(pa0_pref, 160); + PREF_OFFSET(pa0_pref, 192); + PREF_OFFSET(pa0_pref, 224); + + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); src_c0 -= src_a0 * src_b; @@ -84,40 +94,65 @@ static void dsolve_8x4_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO src_c14 -= src_a2 * src_b; src_c15 -= src_a3 * src_b; - src_a0 = src_a4; - src_a1 = src_a5; - src_a2 = src_a6; - src_a3 = src_a7; - src_b0 = src_b2; - src_b1 = src_b3; + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + + pa0_pref += 16; } - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); - src_c0 -= src_a0 * src_b; - src_c1 -= src_a1 * src_b; - src_c2 -= src_a2 * src_b; - src_c3 -= src_a3 * src_b; + if (bk & 1) + { + LD_DP4_INC(a, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(b, 2, src_b0, src_b1); - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); - src_c4 -= src_a0 * src_b; - src_c5 -= src_a1 * src_b; - src_c6 -= src_a2 * src_b; - src_c7 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); - src_c8 -= src_a0 * src_b; - src_c9 -= src_a1 * src_b; - src_c10 -= src_a2 * src_b; - src_c11 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); - src_c12 -= src_a0 * src_b; - src_c13 -= src_a1 * src_b; - src_c14 -= src_a2 * src_b; - src_c15 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; - a += 8; - b += 4; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + } } src_b0 = LD_DP(b + 0); diff --git a/kernel/mips/dtrsm_kernel_RT_8x4_msa.c b/kernel/mips/dtrsm_kernel_RT_8x4_msa.c index 49274e5bc6..581a90f71b 100644 --- a/kernel/mips/dtrsm_kernel_RT_8x4_msa.c +++ b/kernel/mips/dtrsm_kernel_RT_8x4_msa.c @@ -28,7 +28,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -static void dsolve_8x4_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) +static __attribute__ ((noinline)) +void dsolve_8x4_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { v2f64 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v2f64 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; @@ -45,21 +46,29 @@ static void dsolve_8x4_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO if (bk > 0) { - BLASLONG i; - FLOAT *pba = a, *pbb = b; - v2f64 src_b, src_b0, src_b1, src_b2, src_b3; - v2f64 src_a0, src_a1, src_a2, src_a3, src_a4, src_a5, src_a6, src_a7; + BLASLONG i, pref_offset; + FLOAT *pba = a, *pbb = b, *pa0_pref; + v2f64 src_b, src_b0, src_b1, src_a0, src_a1, src_a2, src_a3; - LD_DP4(pba, 2, src_a0, src_a1, src_a2, src_a3); - LD_DP2(pbb, 2, src_b0, src_b1); + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - for (i = (bk - 1); i--;) + if (pref_offset) { - pba += 8; - pbb += 4; + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - LD_DP4(pba, 2, src_a4, src_a5, src_a6, src_a7); - LD_DP2(pbb, 2, src_b2, src_b3); + pa0_pref = a + pref_offset; + + for (i = (bk >> 1); i--;) + { + PREF_OFFSET(pa0_pref, 128); + PREF_OFFSET(pa0_pref, 160); + PREF_OFFSET(pa0_pref, 192); + PREF_OFFSET(pa0_pref, 224); + + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); src_c0 -= src_a0 * src_b; @@ -85,37 +94,65 @@ static void dsolve_8x4_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO src_c14 -= src_a2 * src_b; src_c15 -= src_a3 * src_b; - src_a0 = src_a4; - src_a1 = src_a5; - src_a2 = src_a6; - src_a3 = src_a7; - src_b0 = src_b2; - src_b1 = src_b3; + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + + pa0_pref += 16; } - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); - src_c0 -= src_a0 * src_b; - src_c1 -= src_a1 * src_b; - src_c2 -= src_a2 * src_b; - src_c3 -= src_a3 * src_b; + if (bk & 1) + { + LD_DP4_INC(pba, 2, src_a0, src_a1, src_a2, src_a3); + LD_DP2_INC(pbb, 2, src_b0, src_b1); - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); - src_c4 -= src_a0 * src_b; - src_c5 -= src_a1 * src_b; - src_c6 -= src_a2 * src_b; - src_c7 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b0, (v2i64) src_b0); + src_c0 -= src_a0 * src_b; + src_c1 -= src_a1 * src_b; + src_c2 -= src_a2 * src_b; + src_c3 -= src_a3 * src_b; - src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); - src_c8 -= src_a0 * src_b; - src_c9 -= src_a1 * src_b; - src_c10 -= src_a2 * src_b; - src_c11 -= src_a3 * src_b; - - src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); - src_c12 -= src_a0 * src_b; - src_c13 -= src_a1 * src_b; - src_c14 -= src_a2 * src_b; - src_c15 -= src_a3 * src_b; + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b0, (v2i64) src_b0); + src_c4 -= src_a0 * src_b; + src_c5 -= src_a1 * src_b; + src_c6 -= src_a2 * src_b; + src_c7 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvr_d((v2i64) src_b1, (v2i64) src_b1); + src_c8 -= src_a0 * src_b; + src_c9 -= src_a1 * src_b; + src_c10 -= src_a2 * src_b; + src_c11 -= src_a3 * src_b; + + src_b = (v2f64) __msa_ilvl_d((v2i64) src_b1, (v2i64) src_b1); + src_c12 -= src_a0 * src_b; + src_c13 -= src_a1 * src_b; + src_c14 -= src_a2 * src_b; + src_c15 -= src_a3 * src_b; + } } a -= 32; @@ -881,7 +918,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, for (i = (m >> 3); i--;) { - dsolve_8x1_rt_msa(aa + 8 * kk, bb, cc, k - kk); + dsolve_8x1_rt_msa(aa + 8 * kk, bb, cc, (k - kk)); aa += 8 * k; cc += 8; @@ -891,7 +928,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, { if (m & 4) { - dsolve_4x1_rt_msa(aa + 4 * kk, bb, cc, k - kk); + dsolve_4x1_rt_msa(aa + 4 * kk, bb, cc, (k - kk)); aa += 4 * k; cc += 4; @@ -899,7 +936,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 2) { - dsolve_2x1_rt_msa(aa + 2 * kk, bb, cc, k - kk); + dsolve_2x1_rt_msa(aa + 2 * kk, bb, cc, (k - kk)); aa += 2 * k; cc += 2; @@ -907,7 +944,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 1) { - dsolve_1x1_rt_msa(aa + kk, bb, cc, k - kk); + dsolve_1x1_rt_msa(aa + kk, bb, cc, (k - kk)); aa += k; cc += 1; @@ -928,7 +965,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, for (i = (m >> 3); i--;) { - dsolve_8x2_rt_msa(aa + 8 * kk, bb, cc, ldc, k - kk); + dsolve_8x2_rt_msa(aa + 8 * kk, bb, cc, ldc, (k - kk)); aa += 8 * k; cc += 8; @@ -938,7 +975,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, { if (m & 4) { - dsolve_4x2_rt_msa(aa + 4 * kk, bb, cc, ldc, k - kk); + dsolve_4x2_rt_msa(aa + 4 * kk, bb, cc, ldc, (k - kk)); aa += 4 * k; cc += 4; @@ -946,7 +983,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 2) { - dsolve_2x2_rt_msa(aa + 2 * kk, bb, cc, ldc, k - kk); + dsolve_2x2_rt_msa(aa + 2 * kk, bb, cc, ldc, (k - kk)); aa += 2 * k; cc += 2; @@ -954,7 +991,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 1) { - dsolve_1x2_rt_msa(aa + kk, bb, cc, ldc, k - kk); + dsolve_1x2_rt_msa(aa + kk, bb, cc, ldc, (k - kk)); aa += k; cc += 1; @@ -975,7 +1012,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, for (i = (m >> 3); i--;) { - dsolve_8x4_rt_msa(aa + kk * 8, bb, cc, ldc, k - kk); + dsolve_8x4_rt_msa(aa + kk * 8, bb, cc, ldc, (k - kk)); aa += 8 * k; cc += 8; @@ -985,7 +1022,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, { if (m & 4) { - dsolve_4x4_rt_msa(aa + kk * 4, bb, cc, ldc, k - kk); + dsolve_4x4_rt_msa(aa + kk * 4, bb, cc, ldc, (k - kk)); aa += 4 * k; cc += 4; @@ -993,7 +1030,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 2) { - dsolve_2x4_rt_msa(aa + kk * 2, bb, cc, ldc, k - kk); + dsolve_2x4_rt_msa(aa + kk * 2, bb, cc, ldc, (k - kk)); aa += 2 * k; cc += 2; @@ -1001,7 +1038,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT dummy1, FLOAT *a, FLOAT *b, if (m & 1) { - dsolve_1x4_rt_msa(aa + kk, bb, cc, ldc, k - kk); + dsolve_1x4_rt_msa(aa + kk, bb, cc, ldc, (k - kk)); aa += k; cc += 1; diff --git a/kernel/mips/macros_msa.h b/kernel/mips/macros_msa.h index dbc1853028..ee0dea0b7c 100644 --- a/kernel/mips/macros_msa.h +++ b/kernel/mips/macros_msa.h @@ -28,8 +28,28 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef __MACROS_MSA_H__ #define __MACROS_MSA_H__ +#include #include +#define ENABLE_PREFETCH + +#ifdef ENABLE_PREFETCH +inline static void prefetch_load_lf(unsigned char *src) +{ + __asm__ __volatile__("pref 0, 0(%[src]) \n\t" : : [src] "r" (src)); +} + +#define PREFETCH(PTR) prefetch_load_lf((unsigned char *)(PTR)); + +#define STRNG(X) #X +#define PREF_OFFSET(src_ptr, offset) \ + __asm__ __volatile__("pref 0, " STRNG(offset) "(%[src]) \n\t" : : [src] "r" (src_ptr)); + +#else +#define PREFETCH(PTR) +#define PREF_OFFSET(src_ptr, offset) +#endif + #define LD_W(RTYPE, psrc) *((RTYPE *)(psrc)) #define LD_SP(...) LD_W(v4f32, __VA_ARGS__) @@ -702,6 +722,31 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. MUL2(in4, in5, in6, in7, out2, out3); \ } +/* Description : Multiplication of pairs of vectors and added in output + Arguments : Inputs - in0, in1, vec, out0, out1 + Outputs - out0, out1 + Details : Each element from 'in0' is multiplied with elements from 'vec' + and the result is added to 'out0' +*/ +#define FMADD2(in0, in1, vec, inout0, inout1) \ +{ \ + inout0 += in0 * vec; \ + inout1 += in1 * vec; \ +} +#define FMADD3(in0, in1, in2, vec, \ + inout0, inout1, inout2) \ +{ \ + inout0 += in0 * vec; \ + inout1 += in1 * vec; \ + inout2 += in2 * vec; \ +} +#define FMADD4(in0, in1, in2, in3, vec, \ + inout0, inout1, inout2, inout3) \ +{ \ + FMADD2(in0, in1, vec, inout0, inout1); \ + FMADD2(in2, in3, vec, inout2, inout3); \ +} + /* Description : Addition of 2 pairs of variables Arguments : Inputs - in0, in1, in2, in3 Outputs - out0, out1 diff --git a/kernel/mips/sasum_msa.c b/kernel/mips/sasum_msa.c index e968f8307f..b38385d761 100644 --- a/kernel/mips/sasum_msa.c +++ b/kernel/mips/sasum_msa.c @@ -34,42 +34,70 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) { BLASLONG i = 0; - FLOAT data0, data1, data2, sumf = 0.0; + FLOAT data0, data1, sumf = 0.0; v4f32 src0, src1, src2, src3, src4, src5, src6, src7; - v4f32 sum_abs0, sum_abs1, sum_abs2, sum_abs3; - v4f32 zero_v = {0}; + v4f32 src8, src9, src10, src11, src12, src13, src14, src15; + v4f32 sum_abs0 = {0, 0, 0, 0}; + v4f32 sum_abs1 = {0, 0, 0, 0}; + v4f32 sum_abs2 = {0, 0, 0, 0}; + v4f32 sum_abs3 = {0, 0, 0, 0}; + v4f32 zero_v = {0, 0, 0, 0}; v4i32 and_vec = {0x7FFFFFFF, 0x7FFFFFFF, 0x7FFFFFFF, 0x7FFFFFFF}; if (n <= 0 || inc_x <= 0) return (sumf); if (1 == inc_x) { - if (n > 31) + if (n > 63) { - n -= 32; + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 128 + 32; LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = 0; i < (n >> 6) - 1; i++) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + LD_SP8_INC(x, 4, src8, src9, src10, src11, src12, src13, src14, src15); - sum_abs0 = AND_VEC_W(src0); - sum_abs1 = AND_VEC_W(src1); - sum_abs2 = AND_VEC_W(src2); - sum_abs3 = AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - sum_abs2 += AND_VEC_W(src6); - sum_abs3 += AND_VEC_W(src7); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - sum_abs2 = zero_v; - sum_abs3 = zero_v; - } + sum_abs0 += AND_VEC_W(src0); + sum_abs1 += AND_VEC_W(src1); + sum_abs2 += AND_VEC_W(src2); + sum_abs3 += AND_VEC_W(src3); + sum_abs0 += AND_VEC_W(src4); + sum_abs1 += AND_VEC_W(src5); + sum_abs2 += AND_VEC_W(src6); + sum_abs3 += AND_VEC_W(src7); + + LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); + } - for (i = 0; i < (n >> 5); i++) - { - LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); + LD_SP8_INC(x, 4, src8, src9, src10, src11, src12, src13, src14, src15); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -79,13 +107,21 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); sum_abs3 += AND_VEC_W(src7); + sum_abs0 += AND_VEC_W(src8); + sum_abs1 += AND_VEC_W(src9); + sum_abs2 += AND_VEC_W(src10); + sum_abs3 += AND_VEC_W(src11); + sum_abs0 += AND_VEC_W(src12); + sum_abs1 += AND_VEC_W(src13); + sum_abs2 += AND_VEC_W(src14); + sum_abs3 += AND_VEC_W(src15); } - if (n & 31) + if (n & 63) { - if ((n & 16) && (n & 8) && (n & 4)) + if (n & 32) { - LD_SP7_INC(x, 4, src0, src1, src2, src3, src4, src5, src6); + LD_SP8_INC(x, 4, src0, src1, src2, src3, src4, src5, src6, src7); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); @@ -94,65 +130,10 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs0 += AND_VEC_W(src4); sum_abs1 += AND_VEC_W(src5); sum_abs2 += AND_VEC_W(src6); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if ((n & 16) && (n & 8)) - { - LD_SP6_INC(x, 4, src0, src1, src2, src3, src4, src5); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - sum_abs1 += AND_VEC_W(src5); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; + sum_abs3 += AND_VEC_W(src7); } - else if ((n & 16) && (n & 4)) - { - LD_SP5_INC(x, 4, src0, src1, src2, src3, src4); - - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - sum_abs3 += AND_VEC_W(src3); - sum_abs0 += AND_VEC_W(src4); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if ((n & 8) && (n & 4)) - { - LD_SP3_INC(x, 4, src0, src1, src2); - sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src1); - sum_abs2 += AND_VEC_W(src2); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else if (n & 16) + if (n & 16) { LD_SP4_INC(x, 4, src0, src1, src2, src3); @@ -160,79 +141,47 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) sum_abs1 += AND_VEC_W(src1); sum_abs2 += AND_VEC_W(src2); sum_abs3 += AND_VEC_W(src3); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } - else if (n & 8) + + if (n & 8) { LD_SP2_INC(x, 4, src0, src1); sum_abs0 += AND_VEC_W(src0); sum_abs1 += AND_VEC_W(src1); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } - else if (n & 4) + + if (n & 4) { src0 = LD_SP(x); x += 4; sum_abs0 += AND_VEC_W(src0); - - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } - else - { - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; } if (n & 2) { - sumf += fabsf(*(x + 0)); + sumf += fabsf(*x); sumf += fabsf(*(x + 1)); x += 2; } if (n & 1) { - sumf += fabsf(*(x + 0)); + sumf += fabsf(*x); } } - else - { - sum_abs0 = sum_abs0 + sum_abs1 + sum_abs2 + sum_abs3; - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; - } + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + + sumf += sum_abs0[0]; + sumf += sum_abs0[1]; + sumf += sum_abs0[2]; + sumf += sum_abs0[3]; } else { - if (n > 8) + for (i = (n >> 4); i--;) { - n -= 8; - src0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); x += inc_x; src0 = (v4f32) __msa_insert_w((v4i32) src0, 1, *((int *) x)); @@ -241,92 +190,97 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) x += inc_x; src0 = (v4f32) __msa_insert_w((v4i32) src0, 3, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + src1 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 1, *((int *) x)); + src1 = (v4f32) __msa_insert_w((v4i32) src1, 1, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 2, *((int *) x)); + src1 = (v4f32) __msa_insert_w((v4i32) src1, 2, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 3, *((int *) x)); + src1 = (v4f32) __msa_insert_w((v4i32) src1, 3, *((int *) x)); x += inc_x; - - sum_abs0 = AND_VEC_W(src0); - sum_abs1 = AND_VEC_W(src4); - } - else - { - sum_abs0 = zero_v; - sum_abs1 = zero_v; - } - - for (i = (n >> 3); i--;) - { - src0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + src2 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 1, *((int *) x)); + src2 = (v4f32) __msa_insert_w((v4i32) src2, 1, *((int *) x)); x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 2, *((int *) x)); + src2 = (v4f32) __msa_insert_w((v4i32) src2, 2, *((int *) x)); x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 3, *((int *) x)); + src2 = (v4f32) __msa_insert_w((v4i32) src2, 3, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + src3 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 1, *((int *) x)); + src3 = (v4f32) __msa_insert_w((v4i32) src3, 1, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 2, *((int *) x)); + src3 = (v4f32) __msa_insert_w((v4i32) src3, 2, *((int *) x)); x += inc_x; - src4 = (v4f32) __msa_insert_w((v4i32) src4, 3, *((int *) x)); + src3 = (v4f32) __msa_insert_w((v4i32) src3, 3, *((int *) x)); x += inc_x; sum_abs0 += AND_VEC_W(src0); - sum_abs1 += AND_VEC_W(src4); + sum_abs1 += AND_VEC_W(src1); + sum_abs2 += AND_VEC_W(src2); + sum_abs3 += AND_VEC_W(src3); } - if (n & 4) + if (n & 15) { - src0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); - x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 1, *((int *) x)); - x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 2, *((int *) x)); - x += inc_x; - src0 = (v4f32) __msa_insert_w((v4i32) src0, 3, *((int *) x)); - x += inc_x; + if (n & 8) + { + src0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 1, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 2, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 3, *((int *) x)); + x += inc_x; + src1 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + src1 = (v4f32) __msa_insert_w((v4i32) src1, 1, *((int *) x)); + x += inc_x; + src1 = (v4f32) __msa_insert_w((v4i32) src1, 2, *((int *) x)); + x += inc_x; + src1 = (v4f32) __msa_insert_w((v4i32) src1, 3, *((int *) x)); + x += inc_x; - sum_abs0 += AND_VEC_W(src0); - } + sum_abs0 += AND_VEC_W(src0); + sum_abs1 += AND_VEC_W(src1); + } - sum_abs0 += sum_abs1; + if (n & 4) + { + src0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 1, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 2, *((int *) x)); + x += inc_x; + src0 = (v4f32) __msa_insert_w((v4i32) src0, 3, *((int *) x)); + x += inc_x; - sumf += sum_abs0[0]; - sumf += sum_abs0[1]; - sumf += sum_abs0[2]; - sumf += sum_abs0[3]; + sum_abs0 += AND_VEC_W(src0); + } - if ((n & 2) && (n & 1)) - { - data0 = fabsf(*x); x += inc_x; - data1 = fabsf(*x); x += inc_x; - data2 = fabsf(*x); + if (n & 2) + { + data0 = fabsf(*x); x += inc_x; + data1 = fabsf(*x); x += inc_x; - sumf += data0; - sumf += data1; - sumf += data2; - } - else if (n & 2) - { - data0 = fabsf(*x); x += inc_x; - data1 = fabsf(*x); + sumf += data0; + sumf += data1; + } - sumf += data0; - sumf += data1; + if (n & 1) + { + sumf += fabsf(*x); + } } - else if (n & 1) - { - data0 = fabsf(*x); - sumf += data0; - } + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + + sumf += sum_abs0[0]; + sumf += sum_abs0[1]; + sumf += sum_abs0[2]; + sumf += sum_abs0[3]; } return (sumf); diff --git a/kernel/mips/saxpy_msa.c b/kernel/mips/saxpy_msa.c new file mode 100644 index 0000000000..3238dbb2c3 --- /dev/null +++ b/kernel/mips/saxpy_msa.c @@ -0,0 +1,265 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +#if !defined(CONJ) + #define OP0 += + #define OP1 -= + #define OP2 += +#else + #define OP0 -= + #define OP1 += + #define OP2 -= +#endif + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, + BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i; + FLOAT *py; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 da_vec, zero_v = {0}; + + if ((n < 0) || (da == 0.0)) return(0); + + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 64; + + da_vec = COPY_FLOAT_TO_VECTOR(da); + + for (i = (n >> 5); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 32; + y_pref += 32; + + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + LD_SP8_INC(py, 4, y0, y1, y2, y3, y4, y5, y6, y7); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + FMADD4(x4, x5, x6, x7, da_vec, y4, y5, y6, y7); + ST_SP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 4); + } + + if (n & 31) + { + if (n & 16) + { + LD_SP4_INC(x, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + + if (n & 8) + { + LD_SP2_INC(x, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + FMADD2(x0, x1, da_vec, y0, y1); + ST_SP2_INC(y0, y1, y, 4); + } + + if (n & 4) + { + x0 = LD_SP(x); x += 4; + y0 = LD_SP(py); py += 4; + y0 += da_vec * x0; + ST_SP(y0, y); y += 4; + } + + if (n & 2) + { + FMADD2(x[0], x[1], da, y[0], y[1]); + x += 2; + y += 2; + } + + if (n & 1) + { + y[0] += da * x[0]; + } + } + } + else if (1 == inc_y) + { + da_vec = COPY_FLOAT_TO_VECTOR(da); + + for (i = (n >> 4); i--;) + { + x0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 1, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 2, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 3, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 1, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 2, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 3, *((int *) x)); + x += inc_x; + x2 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x2 = (v4f32) __msa_insert_w((v4i32) x2, 1, *((int *) x)); + x += inc_x; + x2 = (v4f32) __msa_insert_w((v4i32) x2, 2, *((int *) x)); + x += inc_x; + x2 = (v4f32) __msa_insert_w((v4i32) x2, 3, *((int *) x)); + x += inc_x; + x3 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x3 = (v4f32) __msa_insert_w((v4i32) x3, 1, *((int *) x)); + x += inc_x; + x3 = (v4f32) __msa_insert_w((v4i32) x3, 2, *((int *) x)); + x += inc_x; + x3 = (v4f32) __msa_insert_w((v4i32) x3, 3, *((int *) x)); + x += inc_x; + + LD_SP4_INC(py, 4, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da_vec, y0, y1, y2, y3); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + + if (n & 15) + { + if (n & 8) + { + x0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 1, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 2, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 3, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 1, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 2, *((int *) x)); + x += inc_x; + x1 = (v4f32) __msa_insert_w((v4i32) x1, 3, *((int *) x)); + x += inc_x; + + LD_SP2_INC(py, 4, y0, y1); + FMADD2(x0, x1, da_vec, y0, y1); + ST_SP2_INC(y0, y1, y, 4); + } + + if (n & 4) + { + x0 = (v4f32) __msa_insert_w((v4i32) zero_v, 0, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 1, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 2, *((int *) x)); + x += inc_x; + x0 = (v4f32) __msa_insert_w((v4i32) x0, 3, *((int *) x)); + x += inc_x; + + y0 = LD_SP(py); py += 4; + y0 += da_vec * x0; + ST_SP(y0, y); y += 4; + } + + if (n & 2) + { + FMADD2(x[0], x[inc_x], da, y[0], y[1]); + + x += 2 * inc_x; + y += 2; + } + + if (n & 1) + { + y[0] += da * x[0]; + } + } + } + else + { + FLOAT x0, x1, x2, x3, y0, y1, y2, y3; + + for (i = (n >> 2); i--;) + { + LD_GP4_INC(x, inc_x, x0, x1, x2, x3); + LD_GP4_INC(py, inc_y, y0, y1, y2, y3); + FMADD4(x0, x1, x2, x3, da, y0, y1, y2, y3); + ST_GP4_INC(y0, y1, y2, y3, y, inc_y); + } + + if (n & 3) + { + if (n & 2) + { + LD_GP2_INC(x, inc_x, x0, x1); + LD_GP2_INC(py, inc_y, y0, y1); + FMADD2(x0, x1, da, y0, y1); + ST_GP2_INC(y0, y1, y, inc_y); + } + + if (n & 1) + { + *y += da * *x; + } + } + } + + return (0); +} diff --git a/kernel/mips/scopy_msa.c b/kernel/mips/scopy_msa.c new file mode 100644 index 0000000000..0b459ecf14 --- /dev/null +++ b/kernel/mips/scopy_msa.c @@ -0,0 +1,186 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + BLASLONG i; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + FLOAT f0, f1, f2, f3, f4, f5, f6, f7; + + if (n < 0) return (0); + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n > 63) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 128 + 32; + + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 6) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + x8 = LD_SP(x); x += 4; + ST_SP(x0, y); y += 4; + x9 = LD_SP(x); x += 4; + ST_SP(x1, y); y += 4; + x10 = LD_SP(x); x += 4; + ST_SP(x2, y); y += 4; + x11 = LD_SP(x); x += 4; + ST_SP(x3, y); y += 4; + x12 = LD_SP(x); x += 4; + ST_SP(x4, y); y += 4; + x13 = LD_SP(x); x += 4; + ST_SP(x5, y); y += 4; + x14 = LD_SP(x); x += 4; + ST_SP(x6, y); y += 4; + x15 = LD_SP(x); x += 4; + ST_SP(x7, y); y += 4; + x0 = LD_SP(x); x += 4; + ST_SP(x8, y); y += 4; + x1 = LD_SP(x); x += 4; + ST_SP(x9, y); y += 4; + x2 = LD_SP(x); x += 4; + ST_SP(x10, y); y += 4; + x3 = LD_SP(x); x += 4; + ST_SP(x11, y); y += 4; + x4 = LD_SP(x); x += 4; + ST_SP(x12, y); y += 4; + x5 = LD_SP(x); x += 4; + ST_SP(x13, y); y += 4; + x6 = LD_SP(x); x += 4; + ST_SP(x14, y); y += 4; + x7 = LD_SP(x); x += 4; + ST_SP(x15, y); y += 4; + } + + x8 = LD_SP(x); x += 4; + x9 = LD_SP(x); x += 4; + ST_SP(x0, y); y += 4; + x10 = LD_SP(x); x += 4; + ST_SP(x1, y); y += 4; + x11 = LD_SP(x); x += 4; + ST_SP(x2, y); y += 4; + x12 = LD_SP(x); x += 4; + ST_SP(x3, y); y += 4; + x13 = LD_SP(x); x += 4; + ST_SP(x4, y); y += 4; + x14 = LD_SP(x); x += 4; + ST_SP(x5, y); y += 4; + x15 = LD_SP(x); x += 4; + ST_SP(x6, y); y += 4; + ST_SP(x7, y); y += 4; + + ST_SP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, y, 4); + } + + if (n & 63) + { + if (n & 32) + { + LD_SP8_INC(x, 4, x0, x1, x2, x3, x4, x5, x6, x7); + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, y, 4); + } + + if (n & 16) + { + LD_SP4_INC(x, 4, x0, x1, x2, x3); + ST_SP4_INC(x0, x1, x2, x3, y, 4); + } + + if (n & 8) + { + LD_SP2_INC(x, 4, x0, x1); + ST_SP2_INC(x0, x1, y, 4); + } + + if (n & 4) + { + LD_GP4_INC(x, 1, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, y, 1); + } + + if (n & 2) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + + if (n & 1) + { + *y = *x; + } + } + } + else + { + for (i = (n >> 3); i--;) + { + LD_GP8_INC(x, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + ST_GP8_INC(f0, f1, f2, f3, f4, f5, f6, f7, y, inc_y); + } + + if (n & 4) + { + LD_GP4_INC(x, inc_x, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, y, inc_y); + } + + if (n & 2) + { + LD_GP2_INC(x, inc_x, f0, f1); + ST_GP2_INC(f0, f1, y, inc_y); + } + + if (n & 1) + { + *y = *x; + } + } + + return (0); +} diff --git a/kernel/mips/sdot_msa.c b/kernel/mips/sdot_msa.c index 1997ec5a09..e02e10c610 100644 --- a/kernel/mips/sdot_msa.c +++ b/kernel/mips/sdot_msa.c @@ -28,7 +28,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" #include "macros_msa.h" -/* return float, x,y float */ #if defined(DSDOT) double CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) #else @@ -37,96 +36,86 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) { BLASLONG i = 0; double dot = 0.0; - float x0, x1, x2, x3, y0, y1, y2, y3; + FLOAT x0, x1, x2, x3, y0, y1, y2, y3; v4f32 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7; v4f32 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7; v4f32 dot0 = {0, 0, 0, 0}; + v4f32 dot1 = {0, 0, 0, 0}; + v4f32 dot2 = {0, 0, 0, 0}; + v4f32 dot3 = {0, 0, 0, 0}; - if (n < 0) return (dot); + if (n < 1) return (dot); if ((1 == inc_x) && (1 == inc_y)) { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 64; + for (i = (n >> 5); i--;) { - LD_SP8_INC(x, 4, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); - LD_SP8_INC(y, 4, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); + LD_SP8_INC(x, 4, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); + LD_SP8_INC(y, 4, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); + + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 32; + y_pref += 32; dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); + dot1 += (vy1 * vx1); + dot2 += (vy2 * vx2); + dot3 += (vy3 * vx3); dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); - dot0 += (vy6 * vx6); - dot0 += (vy7 * vx7); + dot1 += (vy5 * vx5); + dot2 += (vy6 * vx6); + dot3 += (vy7 * vx7); } if (n & 31) { - if ((n & 16) && (n & 8) && (n & 4)) - { - LD_SP7_INC(x, 4, vx0, vx1, vx2, vx3, vx4, vx5, vx6); - LD_SP7_INC(y, 4, vy0, vy1, vy2, vy3, vy4, vy5, vy6); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); - dot0 += (vy6 * vx6); - } - else if ((n & 16) && (n & 8)) + if (n & 16) { - LD_SP6_INC(x, 4, vx0, vx1, vx2, vx3, vx4, vx5); - LD_SP6_INC(y, 4, vy0, vy1, vy2, vy3, vy4, vy5); + LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); + LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - dot0 += (vy5 * vx5); + dot1 += (vy1 * vx1); + dot2 += (vy2 * vx2); + dot3 += (vy3 * vx3); } - else if ((n & 16) && (n & 4)) - { - LD_SP5_INC(x, 4, vx0, vx1, vx2, vx3, vx4); - LD_SP5_INC(y, 4, vy0, vy1, vy2, vy3, vy4); - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - dot0 += (vy4 * vx4); - } - else if ((n & 8) && (n & 4)) + if (n & 8) { - LD_SP3_INC(x, 4, vx0, vx1, vx2); - LD_SP3_INC(y, 4, vy0, vy1, vy2); + LD_SP2_INC(x, 4, vx0, vx1); + LD_SP2_INC(y, 4, vy0, vy1); dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); + dot1 += (vy1 * vx1); } - else if (n & 16) - { - LD_SP4_INC(x, 4, vx0, vx1, vx2, vx3); - LD_SP4_INC(y, 4, vy0, vy1, vy2, vy3); - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - dot0 += (vy2 * vx2); - dot0 += (vy3 * vx3); - } - else if (n & 8) - { - LD_SP2_INC(x, 4, vx0, vx1); - LD_SP2_INC(y, 4, vy0, vy1); - - dot0 += (vy0 * vx0); - dot0 += (vy1 * vx1); - } - else if (n & 4) + if (n & 4) { vx0 = LD_SP(x); x += 4; vy0 = LD_SP(y); y += 4; @@ -134,16 +123,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot0 += (vy0 * vx0); } - if ((n & 2) && (n & 1)) - { - LD_GP3_INC(x, 1, x0, x1, x2); - LD_GP3_INC(y, 1, y0, y1, y2); - - dot += (y0 * x0); - dot += (y1 * x1); - dot += (y2 * x2); - } - else if (n & 2) + if (n & 2) { LD_GP2_INC(x, 1, x0, x1); LD_GP2_INC(y, 1, y0, y1); @@ -151,7 +131,8 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot += (y0 * x0); dot += (y1 * x1); } - else if (n & 1) + + if (n & 1) { x0 = *x; y0 = *y; @@ -160,6 +141,8 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) } } + dot0 += dot1 + dot2 + dot3; + dot += dot0[0]; dot += dot0[1]; dot += dot0[2]; @@ -178,16 +161,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot += (y3 * x3); } - if ((n & 2) && (n & 1)) - { - LD_GP3_INC(x, inc_x, x0, x1, x2); - LD_GP3_INC(y, inc_y, y0, y1, y2); - - dot += (y0 * x0); - dot += (y1 * x1); - dot += (y2 * x2); - } - else if (n & 2) + if (n & 2) { LD_GP2_INC(x, inc_x, x0, x1); LD_GP2_INC(y, inc_y, y0, y1); @@ -195,7 +169,8 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) dot += (y0 * x0); dot += (y1 * x1); } - else if (n & 1) + + if (n & 1) { x0 = *x; y0 = *y; diff --git a/kernel/mips/sgemm_kernel_8x8_msa.c b/kernel/mips/sgemm_kernel_8x8_msa.c index 1695471add..bfd02f95b0 100644 --- a/kernel/mips/sgemm_kernel_8x8_msa.c +++ b/kernel/mips/sgemm_kernel_8x8_msa.c @@ -91,6 +91,15 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pb0 = B; temp = k; #endif +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 32(%[pa0]) \n\t" + "pref 0, 32(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif LD_SP2_INC(pa0, 4, src_a0, src_a1); LD_SP2_INC(pb0, 4, src_b0, src_b1); @@ -129,6 +138,18 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, for (l = ((temp - 1) >> 1); l--;) { +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 64(%[pb0]) \n\t" + "pref 0, 96(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + LD_SP2_INC(pa0, 4, src_a0, src_a1); LD_SP2_INC(pb0, 4, src_b0, src_b1); @@ -500,6 +521,15 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, ST_SP(dst2, pc6); ST_SP(dst3, pc7); + pc0 += 4; + pc1 += 4; + pc2 += 4; + pc3 += 4; + pc4 += 4; + pc5 += 4; + pc6 += 4; + pc7 += 4; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -516,15 +546,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 4; // number of values in A #endif #endif - - pc0 += 4; - pc1 += 4; - pc2 += 4; - pc3 += 4; - pc4 += 4; - pc5 += 4; - pc6 += 4; - pc7 += 4; } if (m & 2) @@ -763,6 +784,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc6[1] += tmp13; pc7[1] += tmp15; #endif + pc0 += 2; + pc1 += 2; + pc2 += 2; + pc3 += 2; + pc4 += 2; + pc5 += 2; + pc6 += 2; + pc7 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -780,15 +809,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 2; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; - pc2 += 2; - pc3 += 2; - pc4 += 2; - pc5 += 2; - pc6 += 2; - pc7 += 2; } if (m & 1) @@ -959,6 +979,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc6[0] += tmp6; pc7[0] += tmp7; #endif + pc0 += 1; + pc1 += 1; + pc2 += 1; + pc3 += 1; + pc4 += 1; + pc5 += 1; + pc6 += 1; + pc7 += 1; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -976,24 +1004,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 1; // number of values in A #endif #endif - pc0 += 1; - pc1 += 1; - pc2 += 1; - pc3 += 1; - pc4 += 1; - pc5 += 1; - pc6 += 1; - pc7 += 1; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 8; // number of values in A #endif - l = (k << 3); - B = B + l; - i = (ldc << 3); - C = C + i; + B += (k << 3); + C += (ldc << 3); } if (n & 4) @@ -1003,12 +1021,12 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc2 = pc1 + ldc; pc3 = pc2 + ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -1145,7 +1163,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, dst6 += res6 * v_alpha; dst7 += res7 * v_alpha; #endif - ST_SP2_INC(dst0, dst1, pc0, 4); ST_SP2_INC(dst2, dst3, pc1, 4); ST_SP2_INC(dst4, dst5, pc2, 4); @@ -1268,6 +1285,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pa0 += 4; pb0 += 4; } + #if defined(TRMMKERNEL) dst0 = res0 * v_alpha; dst1 = res1 * v_alpha; @@ -1289,6 +1307,11 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, ST_SP(dst2, pc2); ST_SP(dst3, pc3); + pc0 += 4; + pc1 += 4; + pc2 += 4; + pc3 += 4; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -1305,10 +1328,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 4; // number of values in A #endif #endif - pc0 += 4; - pc1 += 4; - pc2 += 4; - pc3 += 4; } if (m & 2) @@ -1459,6 +1478,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc2[1] += tmp5; pc3[1] += tmp7; #endif + pc0 += 2; + pc1 += 2; + pc2 += 2; + pc3 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1476,11 +1499,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 2; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; - pc2 += 2; - pc3 += 2; } if (m & 1) @@ -1591,6 +1609,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc2[0] += tmp2; pc3[0] += tmp3; #endif + pc0 += 1; + pc1 += 1; + pc2 += 1; + pc3 += 1; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1608,20 +1630,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 1; // number of values in A #endif #endif - pc0 += 1; - pc1 += 1; - pc2 += 1; - pc3 += 1; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 4; // number of values in A #endif - l = (k << 2); - B = B + l; - i = (ldc << 2); - C = C + i; + B += (k << 2); + C += (ldc << 2); } if (n & 2) @@ -1629,12 +1645,12 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc0 = C; pc1 = pc0 + ldc; - pa0 = A; - #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -1847,6 +1863,9 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, ST_SP(dst0, pc0); ST_SP(dst1, pc1); + pc0 += 4; + pc1 += 4; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -1863,8 +1882,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 4; // number of values in A #endif #endif - pc0 += 4; - pc1 += 4; } if (m & 2) @@ -1967,6 +1984,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc0[1] += tmp1; pc1[1] += tmp3; #endif + pc0 += 2; + pc1 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1984,9 +2003,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 2; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; } if (m & 1) @@ -2067,6 +2083,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc0[0] += tmp0; pc1[0] += tmp1; #endif + pc0 += 1; + pc1 += 1; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -2084,28 +2102,26 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 1; // number of values in A #endif #endif - pc0 += 1; - pc1 += 1; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 2; // number of values in A #endif - l = (k << 1); - B = B + l; - i = (ldc << 1); - C = C + i; + + B += (k << 1); + C += (ldc << 1); } if (n & 1) { pc0 = C; - pa0 = A; #if defined(TRMMKERNEL) && defined(LEFT) off = offset; #endif + pa0 = A; + for (i = (m >> 3); i--;) { #if defined(TRMMKERNEL) @@ -2272,6 +2288,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #endif ST_SP(dst0, pc0); + pc0 += 4; + #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) temp = k - off; @@ -2288,7 +2306,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 4; // number of values in A #endif #endif - pc0 += 4; } if (m & 2) @@ -2359,6 +2376,9 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pb0 += 1; } + tmp0 = alpha * tmp0; + tmp1 = alpha * tmp1; + #if defined(TRMMKERNEL) pc0[0] = tmp0; pc0[1] = tmp1; @@ -2366,6 +2386,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, pc0[0] += tmp0; pc0[1] += tmp1; #endif + pc0 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -2383,8 +2404,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, off += 2; // number of values in A #endif #endif - - pc0 += 2; } if (m & 1) @@ -2448,34 +2467,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alpha, FLOAT *A, FLOAT *B, #else pc0[0] += alpha * tmp0; #endif - -#if defined(TRMMKERNEL) -#if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) - temp = k - off; -#ifdef LEFT - temp -= 1; // number of values in A -#else - temp -= 1; // number of values in B -#endif - pa0 += temp * 1; - pb0 += temp * 1; -#endif - -#ifdef LEFT - off += 1; // number of values in A -#endif -#endif - - pc0 += 1; } - -#if defined(TRMMKERNEL) && !defined(LEFT) - off += 1; // number of values in A -#endif - l = (k << 0); - B = B + l; - i = (ldc << 0); - C = C + i; } return 0; diff --git a/kernel/mips/srot_msa.c b/kernel/mips/srot_msa.c new file mode 100644 index 0000000000..75730241af --- /dev/null +++ b/kernel/mips/srot_msa.c @@ -0,0 +1,1123 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, + FLOAT c, FLOAT s) +{ + BLASLONG i, j; + FLOAT *px, *py; + FLOAT tp0, tp1, tp2, tp3, tp4, tp5, tp6, tp7; + FLOAT fx0, fx1, fx2, fx3, fy0, fy1, fy2, fy3; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 out0, out1, out2, out3, out4, out5, out6, out7; + v4f32 out8, out9, out10, out11, out12, out13, out14, out15, c0, s0; + + if (n <= 0) return (0); + + px = x; + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + if ((0 == c) && (0 == s)) + { + v4f32 zero = __msa_cast_to_vector_float(0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 0, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 1, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 2, 0.0); + zero = (v4f32) __msa_insert_w((v4i32) zero, 3, 0.0); + + /* process 4 floats */ + for (j = (n >> 2); j--;) + { + ST_SP(zero, px); + ST_SP(zero, py); + px += 4; + py += 4; + } + if (n & 2) + { + px[0] = 0; + py[0] = 0; + px[1] = 0; + py[1] = 0; + px += 2; + py += 2; + } + if (n & 1) + { + px[0] = 0; + py[0] = 0; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 5) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + x0 = LD_SP(px); px += 4; + x1 = LD_SP(px); px += 4; + x2 = LD_SP(px); px += 4; + x3 = LD_SP(px); px += 4; + y0 = LD_SP(py); py += 4; + y1 = LD_SP(py); py += 4; + y2 = LD_SP(py); py += 4; + y3 = LD_SP(py); py += 4; + + for (j = (n >> 5) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + out0 = x0 + y0; + x4 = LD_SP(px); px += 4; + out1 = y0 - x0; + x5 = LD_SP(px); px += 4; + out2 = x1 + y1; + x6 = LD_SP(px); px += 4; + out3 = y1 - x1; + x7 = LD_SP(px); px += 4; + out4 = x2 + y2; + y4 = LD_SP(py); py += 4; + out5 = y2 - x2; + y5 = LD_SP(py); py += 4; + out6 = x3 + y3; + y6 = LD_SP(py); py += 4; + out7 = y3 - x3; + y7 = LD_SP(py); py += 4; + + ST_SP(out0, x); x += 4; + out8 = x4 + y4; + ST_SP(out1, y); y += 4; + out9 = y4 - x4; + ST_SP(out2, x); x += 4; + out10 = x5 + y5; + ST_SP(out3, y); y += 4; + out11 = y5 - x5; + ST_SP(out4, x); x += 4; + out12 = x6 + y6; + ST_SP(out5, y); y += 4; + out13 = y6 - x6; + ST_SP(out6, x); x += 4; + out14 = x7 + y7; + ST_SP(out7, y); y += 4; + out15 = y7 - x7; + + x0 = LD_SP(px); px += 4; + ST_SP(out8, x); x += 4; + x1 = LD_SP(px); px += 4; + ST_SP(out10, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(out12, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(out14, x); x += 4; + y0 = LD_SP(py); py += 4; + ST_SP(out9, y); y += 4; + y1 = LD_SP(py); py += 4; + ST_SP(out11, y); y += 4; + y2 = LD_SP(py); py += 4; + ST_SP(out13, y); y += 4; + y3 = LD_SP(py); py += 4; + ST_SP(out15, y); y += 4; + } + + x4 = LD_SP(px); px += 4; + x5 = LD_SP(px); px += 4; + x6 = LD_SP(px); px += 4; + x7 = LD_SP(px); px += 4; + y4 = LD_SP(py); py += 4; + y5 = LD_SP(py); py += 4; + y6 = LD_SP(py); py += 4; + y7 = LD_SP(py); py += 4; + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + out8 = x4 + y4; + out9 = y4 - x4; + out10 = x5 + y5; + out11 = y5 - x5; + out12 = x6 + y6; + out13 = y6 - x6; + out14 = x7 + y7; + out15 = y7 - x7; + + ST_SP8_INC(out0, out2, out4, out6, out8, out10, out12, out14, x, 4); + ST_SP8_INC(out1, out3, out5, out7, out9, out11, out13, out15, y, 4); + } + if (n & 16) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + out4 = x2 + y2; + out5 = y2 - x2; + out6 = x3 + y3; + out7 = y3 - x3; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 8) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = x0 + y0; + out1 = y0 - x0; + out2 = x1 + y1; + out3 = y1 - x1; + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 4) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + out0 = x0 + y0; + out1 = y0 - x0; + + ST_SP(out0, x); + ST_SP(out1, y); + x += 4; + y += 4; + } + if (n & 2) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + + *x = tp0; + *y = tp1; + } + } + else if (0 == s) + { + c0 = COPY_FLOAT_TO_VECTOR(c); + + if (n >> 5) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + + for (j = (n >> 5) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + y0 = LD_SP(py); py += 4; + x0 *= c0; + y1 = LD_SP(py); py += 4; + x1 *= c0; + y2 = LD_SP(py); py += 4; + x2 *= c0; + y3 = LD_SP(py); py += 4; + x3 *= c0; + y4 = LD_SP(py); py += 4; + x4 *= c0; + y5 = LD_SP(py); py += 4; + x5 *= c0; + y6 = LD_SP(py); py += 4; + x6 *= c0; + y7 = LD_SP(py); py += 4; + x7 *= c0; + + ST_SP(x0, x); x += 4; + y0 *= c0; + ST_SP(x1, x); x += 4; + y1 *= c0; + ST_SP(x2, x); x += 4; + y2 *= c0; + ST_SP(x3, x); x += 4; + y3 *= c0; + ST_SP(x4, x); x += 4; + y4 *= c0; + ST_SP(x5, x); x += 4; + y5 *= c0; + ST_SP(x6, x); x += 4; + y6 *= c0; + ST_SP(x7, x); x += 4; + y7 *= c0; + + x0 = LD_SP(px); px += 4; + ST_SP(y0, y); y += 4; + x1 = LD_SP(px); px += 4; + ST_SP(y1, y); y += 4; + x2 = LD_SP(px); px += 4; + ST_SP(y2, y); y += 4; + x3 = LD_SP(px); px += 4; + ST_SP(y3, y); y += 4; + x4 = LD_SP(px); px += 4; + ST_SP(y4, y); y += 4; + x5 = LD_SP(px); px += 4; + ST_SP(y5, y); y += 4; + x6 = LD_SP(px); px += 4; + ST_SP(y6, y); y += 4; + x7 = LD_SP(px); px += 4; + ST_SP(y7, y); y += 4; + } + + LD_SP8_INC(py, 4, y0, y1, y2, y3, y4, y5, y6, y7); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + x2 *= c0; + y2 *= c0; + x3 *= c0; + y3 *= c0; + x4 *= c0; + y4 *= c0; + x5 *= c0; + y5 *= c0; + x6 *= c0; + y6 *= c0; + x7 *= c0; + y7 *= c0; + + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 4); + ST_SP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 4); + } + if (n & 16) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + x2 *= c0; + y2 *= c0; + x3 *= c0; + y3 *= c0; + + ST_SP4_INC(x0, x1, x2, x3, x, 4); + ST_SP4_INC(y0, y1, y2, y3, y, 4); + } + if (n & 8) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + x0 *= c0; + y0 *= c0; + x1 *= c0; + y1 *= c0; + + ST_SP2_INC(x0, x1, x, 4); + ST_SP2_INC(y0, y1, y, 4); + } + if (n & 4) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + x0 *= c0; + y0 *= c0; + + ST_SP(x0, x); + ST_SP(y0, y); + x += 4; + y += 4; + } + if (n & 2) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = (c * fx0); + tp1 = (c * fy0); + tp2 = (c * fx1); + tp3 = (c * fy1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = (c * fx0); + tp1 = (c * fy0); + + *x = tp0; + *y = tp1; + } + } + else if (0 == c) + { + s0 = COPY_FLOAT_TO_VECTOR(s); + + /* process 16 floats */ + if (n >> 5) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + for (j = (n >> 5) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + x4 = LD_SP(px); px += 4; + out0 = s0 * y0; + x5 = LD_SP(px); px += 4; + out2 = s0 * y1; + x6 = LD_SP(px); px += 4; + out4 = s0 * y2; + x7 = LD_SP(px); px += 4; + out6 = s0 * y3; + y4 = LD_SP(py); py += 4; + out1 = -(s0 * x0); + y5 = LD_SP(py); py += 4; + out3 = -(s0 * x1); + y6 = LD_SP(py); py += 4; + out5 = -(s0 * x2); + y7 = LD_SP(py); py += 4; + out7 = -(s0 * x3); + + ST_SP(out0, x); x += 4; + out0 = s0 * y4; + ST_SP(out2, x); x += 4; + out2 = s0 * y5; + ST_SP(out4, x); x += 4; + out4 = s0 * y6; + ST_SP(out6, x); x += 4; + out6 = s0 * y7; + ST_SP(out1, y); y += 4; + out1 = -(s0 * x4); + ST_SP(out3, y); y += 4; + out3 = -(s0 * x5); + ST_SP(out5, y); y += 4; + out5 = -(s0 * x6); + ST_SP(out7, y); y += 4; + out7 = -(s0 * x7); + + x0 = LD_SP(px); px += 4; + ST_SP(out0, x); x += 4; + x1 = LD_SP(px); px += 4; + ST_SP(out2, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(out4, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(out6, x); x += 4; + y0 = LD_SP(py); py += 4; + ST_SP(out1, y); y += 4; + y1 = LD_SP(py); py += 4; + ST_SP(out3, y); y += 4; + y2 = LD_SP(py); py += 4; + ST_SP(out5, y); y += 4; + y3 = LD_SP(py); py += 4; + ST_SP(out7, y); y += 4; + + } + + out0 = s0 * y0; + out2 = s0 * y1; + out4 = s0 * y2; + out6 = s0 * y3; + out1 = -(s0 * x0); + out3 = -(s0 * x1); + out5 = -(s0 * x2); + out7 = -(s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + + LD_SP4_INC(px, 4, x4, x5, x6, x7); + LD_SP4_INC(py, 4, y4, y5, y6, y7); + + out0 = s0 * y4; + out2 = s0 * y5; + out4 = s0 * y6; + out6 = s0 * y7; + out1 = -(s0 * x4); + out3 = -(s0 * x5); + out5 = -(s0 * x6); + out7 = -(s0 * x7); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 16) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + out4 = s0 * y2; + out5 = - (s0 * x2); + out6 = s0 * y3; + out7 = - (s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 8) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = s0 * y0; + out1 = - (s0 * x0); + out2 = s0 * y1; + out3 = - (s0 * x1); + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 4) + { + x0 = LD_SP(px); px += 4; + y0 = LD_SP(py); py += 4; + + out0 = s0 * y0; + out1 = - (s0 * x0); + + ST_SP(out0, x); x += 4; + ST_SP(out1, y); y += 4; + } + if (n & 2) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = s * fy0; + tp1 = - (s * fx0); + tp2 = s * fy1; + tp3 = - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = s * fy0; + tp1 = - (s * fx0); + + *x = tp0; + *y = tp1; + } + } + else + { + c0 = COPY_FLOAT_TO_VECTOR(c); + s0 = COPY_FLOAT_TO_VECTOR(s); + + /* process 16 floats */ + if (n >> 5) + { + BLASLONG pref_offsetx, pref_offsety; + + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + for (j = (n >> 5) - 1; j--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + x4 = LD_SP(px); px += 4; + out0 = c0 * x0; + x5 = LD_SP(px); px += 4; + out2 = c0 * x1; + x6 = LD_SP(px); px += 4; + out4 = c0 * x2; + x7 = LD_SP(px); px += 4; + out6 = c0 * x3; + y4 = LD_SP(py); py += 4; + out1 = c0 * y0; + y5 = LD_SP(py); py += 4; + out3 = c0 * y1; + y6 = LD_SP(py); py += 4; + out5 = c0 * y2; + y7 = LD_SP(py); py += 4; + out7 = c0 * y3; + + out0 += s0 * y0; + out2 += s0 * y1; + out4 += s0 * y2; + out6 += s0 * y3; + out1 -= s0 * x0; + out3 -= s0 * x1; + out5 -= s0 * x2; + out7 -= s0 * x3; + + ST_SP(out0, x); x += 4; + out0 = c0 * x4; + ST_SP(out2, x); x += 4; + out2 = c0 * x5; + ST_SP(out4, x); x += 4; + out4 = c0 * x6; + ST_SP(out6, x); x += 4; + out6 = c0 * x7; + ST_SP(out1, y); y += 4; + out1 = c0 * y4; + ST_SP(out3, y); y += 4; + out3 = c0 * y5; + ST_SP(out5, y); y += 4; + out5 = c0 * y6; + ST_SP(out7, y); y += 4; + out7 = c0 * y7; + + x0 = LD_SP(px); px += 4; + out0 += s0 * y4; + x1 = LD_SP(px); px += 4; + out2 += s0 * y5; + x2 = LD_SP(px); px += 4; + out4 += s0 * y6; + x3 = LD_SP(px); px += 4; + out6 += s0 * y7; + y0 = LD_SP(py); py += 4; + out1 -= s0 * x4; + y1 = LD_SP(py); py += 4; + out3 -= s0 * x5; + y2 = LD_SP(py); py += 4; + out5 -= s0 * x6; + y3 = LD_SP(py); py += 4; + out7 -= s0 * x7; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + + out0 = c0 * x0; + out2 = c0 * x1; + out4 = c0 * x2; + out6 = c0 * x3; + out1 = c0 * y0; + out3 = c0 * y1; + out5 = c0 * y2; + out7 = c0 * y3; + + out0 += s0 * y0; + out2 += s0 * y1; + out4 += s0 * y2; + out6 += s0 * y3; + out1 -= s0 * x0; + out3 -= s0 * x1; + out5 -= s0 * x2; + out7 -= s0 * x3; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + + LD_SP4_INC(px, 4, x4, x5, x6, x7); + LD_SP4_INC(py, 4, y4, y5, y6, y7); + + out0 = c0 * x4; + out2 = c0 * x5; + out4 = c0 * x6; + out6 = c0 * x7; + out1 = c0 * y4; + out3 = c0 * y5; + out5 = c0 * y6; + out7 = c0 * y7; + + out0 += s0 * y4; + out2 += s0 * y5; + out4 += s0 * y6; + out6 += s0 * y7; + out1 -= s0 * x4; + out3 -= s0 * x5; + out5 -= s0 * x6; + out7 -= s0 * x7; + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 16) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + LD_SP4_INC(py, 4, y0, y1, y2, y3); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + out4 = (c0 * x2) + (s0 * y2); + out5 = (c0 * y2) - (s0 * x2); + out6 = (c0 * x3) + (s0 * y3); + out7 = (c0 * y3) - (s0 * x3); + + ST_SP4_INC(out0, out2, out4, out6, x, 4); + ST_SP4_INC(out1, out3, out5, out7, y, 4); + } + if (n & 8) + { + LD_SP2_INC(px, 4, x0, x1); + LD_SP2_INC(py, 4, y0, y1); + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + out2 = (c0 * x1) + (s0 * y1); + out3 = (c0 * y1) - (s0 * x1); + + ST_SP2_INC(out0, out2, x, 4); + ST_SP2_INC(out1, out3, y, 4); + } + if (n & 4) + { + x0 = LD_SP(px); + y0 = LD_SP(py); + px += 4; + py += 4; + + out0 = (c0 * x0) + (s0 * y0); + out1 = (c0 * y0) - (s0 * x0); + + ST_SP(out0, x); + ST_SP(out1, y); + x += 4; + y += 4; + } + if (n & 2) + { + LD_GP2_INC(px, 1, fx0, fx1); + LD_GP2_INC(py, 1, fy0, fy1); + + tp0 = (c * fx0) + (s * fy0); + tp1 = (c * fy0) - (s * fx0); + tp2 = (c * fx1) + (s * fy1); + tp3 = (c * fy1) - (s * fx1); + + ST_GP2_INC(tp0, tp2, x, 1); + ST_GP2_INC(tp1, tp3, y, 1); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = (c * fx0) + (s * fy0); + tp1 = (c * fy0) - (s * fx0); + + *x = tp0; + *y = tp1; + } + } + } + else + { + if ((0 == c) && (0 == s)) + { + for (i = n; i--;) + { + *x = 0; + *y = 0; + x += inc_x; + y += inc_y; + } + } + else if ((1 == c) && (1 == s)) + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) -1; i--;) + { + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fy2 - fx2; + tp6 = fx3 + fy3; + tp7 = fy3 - fx3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + tp4 = fx2 + fy2; + tp5 = fy2 - fx2; + tp6 = fx3 + fy3; + tp7 = fy3 - fx3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + tp2 = fx1 + fy1; + tp3 = fy1 - fx1; + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = fx0 + fy0; + tp1 = fy0 - fx0; + + *x = tp0; + *y = tp1; + } + } + else if (0 == s) + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) - 1; i--;) + { + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + tp4 = c * fx2; + tp5 = c * fy2; + tp6 = c * fx3; + tp7 = c * fy3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + tp4 = c * fx2; + tp5 = c * fy2; + tp6 = c * fx3; + tp7 = c * fy3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = c * fx0; + tp1 = c * fy0; + tp2 = c * fx1; + tp3 = c * fy1; + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = c * fx0; + tp1 = c * fy0; + + *x = tp0; + *y = tp1; + } + } + else + { + if (n >> 2) + { + fx0 = *px; px += inc_x; + fx1 = *px; px += inc_x; + fx2 = *px; px += inc_x; + fx3 = *px; px += inc_x; + fy0 = *py; py += inc_y; + fy1 = *py; py += inc_y; + fy2 = *py; py += inc_y; + fy3 = *py; py += inc_y; + + for (i = (n >> 2) - 1; i--;) + { + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + tp2 = c * fx1 + s * fy1; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fy2 - s * fx2; + tp6 = c * fx3 + s * fy3; + tp7 = c * fy3 - s * fx3; + + fx0 = *px; px += inc_x; + *x = tp0; x += inc_x; + fx1 = *px; px += inc_x; + *x = tp2; x += inc_x; + fx2 = *px; px += inc_x; + *x = tp4; x += inc_x; + fx3 = *px; px += inc_x; + *x = tp6; x += inc_x; + fy0 = *py; py += inc_y; + *y = tp1; y += inc_y; + fy1 = *py; py += inc_y; + *y = tp3; y += inc_y; + fy2 = *py; py += inc_y; + *y = tp5; y += inc_y; + fy3 = *py; py += inc_y; + *y = tp7; y += inc_y; + } + + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + tp2 = c * fx1 + s * fy1; + tp3 = c * fy1 - s * fx1; + tp4 = c * fx2 + s * fy2; + tp5 = c * fy2 - s * fx2; + tp6 = c * fx3 + s * fy3; + tp7 = c * fy3 - s * fx3; + + *x = tp0; x += inc_x; + *x = tp2; x += inc_x; + *x = tp4; x += inc_x; + *x = tp6; x += inc_x; + *y = tp1; y += inc_y; + *y = tp3; y += inc_y; + *y = tp5; y += inc_y; + *y = tp7; y += inc_y; + } + if (n & 2) + { + LD_GP2_INC(px, inc_x, fx0, fx1); + LD_GP2_INC(py, inc_y, fy0, fy1); + + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + tp2 = c * fx1 + s * fy1; + tp3 = c * fy1 - s * fx1; + + ST_GP2_INC(tp0, tp2, x, inc_x); + ST_GP2_INC(tp1, tp3, y, inc_y); + } + if (n & 1) + { + fx0 = *px; + fy0 = *py; + + tp0 = c * fx0 + s * fy0; + tp1 = c * fy0 - s * fx0; + + *x = tp0; + *y = tp1; + } + } + } + + return 0; +} diff --git a/kernel/mips/sscal_msa.c b/kernel/mips/sscal_msa.c new file mode 100644 index 0000000000..64b62d6598 --- /dev/null +++ b/kernel/mips/sscal_msa.c @@ -0,0 +1,385 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, + BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i; + FLOAT *px; + FLOAT f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15; + v4f32 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + v4f32 da_vec; + + px = x; + + if (1 == inc_x) + { + if (0.0 == da) + { + v4f32 zero_v = __msa_cast_to_vector_float(0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 0, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 1, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 2, 0.0); + zero_v = (v4f32) __msa_insert_w((v4i32) zero_v, 3, 0.0); + + for (i = (n >> 6); i--;) + { + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + } + + if (n & 63) + { + if (n & 32) + { + ST_SP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 4); + } + + if (n & 16) + { + ST_SP4_INC(zero_v, zero_v, zero_v, zero_v, x, 4); + } + + if (n & 8) + { + ST_SP2_INC(zero_v, zero_v, x, 4); + } + + if (n & 4) + { + *x = 0; x += 1; + *x = 0; x += 1; + *x = 0; x += 1; + *x = 0; x += 1; + } + + if (n & 2) + { + *x = 0; x += 1; + *x = 0; x += 1; + } + + if (n & 1) + { + *x = 0; + } + } + } + else + { + da_vec = COPY_FLOAT_TO_VECTOR(da); + + if (n > 63) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 32; + + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = 0; i < (n >> 6) - 1; i++) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 64; + + x8 = LD_SP(px); px += 4; + x0 *= da_vec; + x9 = LD_SP(px); px += 4; + x1 *= da_vec; + x10 = LD_SP(px); px += 4; + x2 *= da_vec; + x11 = LD_SP(px); px += 4; + x3 *= da_vec; + x12 = LD_SP(px); px += 4; + x4 *= da_vec; + x13 = LD_SP(px); px += 4; + x5 *= da_vec; + x14 = LD_SP(px); px += 4; + x6 *= da_vec; + x15 = LD_SP(px); px += 4; + x7 *= da_vec; + x8 *= da_vec; + ST_SP(x0, x); x += 4; + x9 *= da_vec; + ST_SP(x1, x); x += 4; + x10 *= da_vec; + ST_SP(x2, x); x += 4; + x11 *= da_vec; + ST_SP(x3, x); x += 4; + x12 *= da_vec; + ST_SP(x4, x); x += 4; + x13 *= da_vec; + ST_SP(x5, x); x += 4; + x14 *= da_vec; + ST_SP(x6, x); x += 4; + x15 *= da_vec; + ST_SP(x7, x); x += 4; + ST_SP(x8, x); x += 4; + x0 = LD_SP(px); px += 4; + ST_SP(x9, x); x += 4; + x1 = LD_SP(px); px += 4; + ST_SP(x10, x); x += 4; + x2 = LD_SP(px); px += 4; + ST_SP(x11, x); x += 4; + x3 = LD_SP(px); px += 4; + ST_SP(x12, x); x += 4; + x4 = LD_SP(px); px += 4; + ST_SP(x13, x); x += 4; + x5 = LD_SP(px); px += 4; + ST_SP(x14, x); x += 4; + x6 = LD_SP(px); px += 4; + ST_SP(x15, x); x += 4; + x7 = LD_SP(px); px += 4; + } + + x8 = LD_SP(px); px += 4; + x0 *= da_vec; + x9 = LD_SP(px); px += 4; + x1 *= da_vec; + x10 = LD_SP(px); px += 4; + x2 *= da_vec; + x11 = LD_SP(px); px += 4; + x3 *= da_vec; + x12 = LD_SP(px); px += 4; + x4 *= da_vec; + x13 = LD_SP(px); px += 4; + x5 *= da_vec; + x14 = LD_SP(px); px += 4; + x6 *= da_vec; + x15 = LD_SP(px); px += 4; + x7 *= da_vec; + x8 *= da_vec; + ST_SP(x0, x); x += 4; + x9 *= da_vec; + ST_SP(x1, x); x += 4; + x10 *= da_vec; + ST_SP(x2, x); x += 4; + x11 *= da_vec; + ST_SP(x3, x); x += 4; + x12 *= da_vec; + ST_SP(x4, x); x += 4; + x13 *= da_vec; + ST_SP(x5, x); x += 4; + x15 *= da_vec; + ST_SP(x6, x); x += 4; + x14 *= da_vec; + ST_SP(x7, x); x += 4; + + ST_SP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, x, 4); + } + + if (n & 63) + { + if (n & 32) + { + LD_SP8_INC(px, 4, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_vec, x1, da_vec, x2, da_vec, x3, da_vec, x0, x1, x2, x3); + MUL4(x4, da_vec, x5, da_vec, x6, da_vec, x7, da_vec, x4, x5, x6, x7); + ST_SP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 4); + } + + if (n & 16) + { + LD_SP4_INC(px, 4, x0, x1, x2, x3); + MUL4(x0, da_vec, x1, da_vec, x2, da_vec, x3, da_vec, x0, x1, x2, x3); + ST_SP4_INC(x0, x1, x2, x3, x, 4); + } + + if (n & 8) + { + LD_SP2_INC(px, 4, x0, x1); + MUL2(x0, da_vec, x1, da_vec, x0, x1); + ST_SP2_INC(x0, x1, x, 4); + } + + if (n & 4) + { + LD_GP4_INC(px, 1, f0, f1, f2, f3); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, x, 1); + } + + if (n & 2) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da, f1, da, f0, f1); + ST_GP2_INC(f0, f1, x, 1); + } + + if (n & 1) + { + *x *= da; + } + } + } + } + else + { + if (0.0 == da) + { + for (i = n; i--;) + { + *x = 0; + x += inc_x; + } + } + else + { + if (n > 15) + { + LD_GP8_INC(px, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + + for (i = 0; i < (n >> 4) - 1; i++) + { + LD_GP8_INC(px, inc_x, f8, f9, f10, f11, f12, f13, f14, f15); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + + f4 *= da; + f5 *= da; + *x = f0; x += inc_x; + f6 *= da; + *x = f1; x += inc_x; + f7 *= da; + *x = f2; x += inc_x; + f8 *= da; + *x = f3; x += inc_x; + f9 *= da; + *x = f4; x += inc_x; + f10 *= da; + *x = f5; x += inc_x; + f11 *= da; + *x = f6; x += inc_x; + f12 *= da; + *x = f7; x += inc_x; + f13 *= da; + *x = f8; x += inc_x; + f14 *= da; + *x = f9; x += inc_x; + f15 *= da; + *x = f10; x += inc_x; + *x = f11; x += inc_x; + f0 = *px; px += inc_x; + *x = f12; x += inc_x; + f1 = *px; px += inc_x; + *x = f13; x += inc_x; + f2 = *px; px += inc_x; + *x = f14; x += inc_x; + f3 = *px; px += inc_x; + *x = f15; x += inc_x; + f4 = *px; px += inc_x; + f5 = *px; px += inc_x; + f6 = *px; px += inc_x; + f7 = *px; px += inc_x; + } + + LD_GP8_INC(px, inc_x, f8, f9, f10, f11, f12, f13, f14, f15); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + + f4 *= da; + f5 *= da; + *x = f0; x += inc_x; + f6 *= da; + *x = f1; x += inc_x; + f7 *= da; + *x = f2; x += inc_x; + f8 *= da; + *x = f3; x += inc_x; + f9 *= da; + *x = f4; x += inc_x; + f10 *= da; + *x = f5; x += inc_x; + f11 *= da; + *x = f6; x += inc_x; + f12 *= da; + *x = f7; x += inc_x; + f13 *= da; + *x = f8; x += inc_x; + f14 *= da; + *x = f9; x += inc_x; + f15 *= da; + *x = f10; x += inc_x; + *x = f11; x += inc_x; + *x = f12; x += inc_x; + *x = f13; x += inc_x; + *x = f14; x += inc_x; + *x = f15; x += inc_x; + } + + if (n & 15) + { + if (n & 8) + { + LD_GP8_INC(px, inc_x, f0, f1, f2, f3, f4, f5, f6, f7); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + MUL4(f4, da, f5, da, f6, da, f7, da, f4, f5, f6, f7); + ST_GP8_INC(f0, f1, f2, f3, f4, f5, f6, f7, x, inc_x); + } + + if (n & 4) + { + LD_GP4_INC(px, inc_x, f0, f1, f2, f3); + MUL4(f0, da, f1, da, f2, da, f3, da, f0, f1, f2, f3); + ST_GP4_INC(f0, f1, f2, f3, x, inc_x); + } + + if (n & 2) + { + LD_GP2_INC(px, inc_x, f0, f1); + MUL2(f0, da, f1, da, f0, f1); + ST_GP2_INC(f0, f1, x, inc_x); + } + + if (n & 1) + { + *x *= da; + } + } + } + } + + return 0; +} diff --git a/kernel/mips/sswap_msa.c b/kernel/mips/sswap_msa.c new file mode 100644 index 0000000000..46fa8aa871 --- /dev/null +++ b/kernel/mips/sswap_msa.c @@ -0,0 +1,267 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT dummy3, + FLOAT *srcx, BLASLONG inc_x, FLOAT *srcy, BLASLONG inc_y, + FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i = 0, pref_offsetx, pref_offsety; + FLOAT *px, *py; + FLOAT x0, x1, x2, x3, x4, x5, x6, x7; + FLOAT y0, y1, y2, y3, y4, y5, y6, y7; + v4f32 xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7; + v4f32 yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7; + + if (n < 0) return (0); + + pref_offsetx = (BLASLONG)srcx & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)srcy & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + px = srcx; + py = srcy; + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n >> 5) + { + LD_SP8_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7); + + for (i = (n >> 5) - 1; i--;) + { + PREFETCH(px + pref_offsetx + 32); + PREFETCH(px + pref_offsetx + 40); + PREFETCH(px + pref_offsetx + 48); + PREFETCH(px + pref_offsetx + 56); + + PREFETCH(py + pref_offsety + 32); + PREFETCH(py + pref_offsety + 40); + PREFETCH(py + pref_offsety + 48); + PREFETCH(py + pref_offsety + 56); + + yv0 = LD_SP(py); py += 4; + ST_SP(xv0, srcy); srcy += 4; + yv1 = LD_SP(py); py += 4; + ST_SP(xv1, srcy); srcy += 4; + yv2 = LD_SP(py); py += 4; + ST_SP(xv2, srcy); srcy += 4; + yv3 = LD_SP(py); py += 4; + ST_SP(xv3, srcy); srcy += 4; + yv4 = LD_SP(py); py += 4; + ST_SP(xv4, srcy); srcy += 4; + yv5 = LD_SP(py); py += 4; + ST_SP(xv5, srcy); srcy += 4; + yv6 = LD_SP(py); py += 4; + ST_SP(xv6, srcy); srcy += 4; + yv7 = LD_SP(py); py += 4; + ST_SP(xv7, srcy); srcy += 4; + + xv0 = LD_SP(px); px += 4; + ST_SP(yv0, srcx); srcx += 4; + xv1 = LD_SP(px); px += 4; + ST_SP(yv1, srcx); srcx += 4; + xv2 = LD_SP(px); px += 4; + ST_SP(yv2, srcx); srcx += 4; + xv3 = LD_SP(px); px += 4; + ST_SP(yv3, srcx); srcx += 4; + xv4 = LD_SP(px); px += 4; + ST_SP(yv4, srcx); srcx += 4; + xv5 = LD_SP(px); px += 4; + ST_SP(yv5, srcx); srcx += 4; + xv6 = LD_SP(px); px += 4; + ST_SP(yv6, srcx); srcx += 4; + xv7 = LD_SP(px); px += 4; + ST_SP(yv7, srcx); srcx += 4; + } + + LD_SP8_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7); + ST_SP8_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, xv7, srcy, 4); + ST_SP8_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, yv7, srcx, 4); + } + + if (n & 31) + { + if ((n & 16) && (n & 8) && (n & 4)) + { + LD_SP7_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5, xv6); + LD_SP7_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5, yv6); + ST_SP7_INC(xv0, xv1, xv2, xv3, xv4, xv5, xv6, srcy, 4); + ST_SP7_INC(yv0, yv1, yv2, yv3, yv4, yv5, yv6, srcx, 4); + } + else if ((n & 16) && (n & 8)) + { + LD_SP6_INC(px, 4, xv0, xv1, xv2, xv3, xv4, xv5); + LD_SP6_INC(py, 4, yv0, yv1, yv2, yv3, yv4, yv5); + ST_SP6_INC(xv0, xv1, xv2, xv3, xv4, xv5, srcy, 4); + ST_SP6_INC(yv0, yv1, yv2, yv3, yv4, yv5, srcx, 4); + } + else if ((n & 16) && (n & 4)) + { + LD_SP5_INC(px, 4, xv0, xv1, xv2, xv3, xv4); + LD_SP5_INC(py, 4, yv0, yv1, yv2, yv3, yv4); + ST_SP5_INC(xv0, xv1, xv2, xv3, xv4, srcy, 4); + ST_SP5_INC(yv0, yv1, yv2, yv3, yv4, srcx, 4); + } + else if ((n & 8) && (n & 4)) + { + LD_SP3_INC(px, 4, xv0, xv1, xv2); + LD_SP3_INC(py, 4, yv0, yv1, yv2); + ST_SP3_INC(xv0, xv1, xv2, srcy, 4); + ST_SP3_INC(yv0, yv1, yv2, srcx, 4); + } + else if (n & 16) + { + LD_SP4_INC(px, 4, xv0, xv1, xv2, xv3); + LD_SP4_INC(py, 4, yv0, yv1, yv2, yv3); + ST_SP4_INC(xv0, xv1, xv2, xv3, srcy, 4); + ST_SP4_INC(yv0, yv1, yv2, yv3, srcx, 4); + } + else if (n & 8) + { + LD_SP2_INC(px, 4, xv0, xv1); + LD_SP2_INC(py, 4, yv0, yv1); + ST_SP2_INC(xv0, xv1, srcy, 4); + ST_SP2_INC(yv0, yv1, srcx, 4); + } + else if (n & 4) + { + xv0 = LD_SP(px); + yv0 = LD_SP(py); + + px += 4; + py += 4; + + ST_SP(xv0, srcy); + ST_SP(yv0, srcx); + + srcx += 4; + srcy += 4; + } + + if ((n & 2) && (n & 1)) + { + LD_GP3_INC(px, 1, x0, x1, x3); + LD_GP3_INC(py, 1, y0, y1, y3); + ST_GP3_INC(x0, x1, x3, srcy, 1); + ST_GP3_INC(y0, y1, y3, srcx, 1); + } + else if (n & 2) + { + LD_GP2_INC(px, 1, x0, x1); + LD_GP2_INC(py, 1, y0, y1); + ST_GP2_INC(x0, x1, srcy, 1); + ST_GP2_INC(y0, y1, srcx, 1); + } + else if (n & 1) + { + x0 = px[0]; + y0 = py[0]; + srcx[0] = y0; + srcy[0] = x0; + } + } + } + else + { + for (i = (n >> 3); i--;) + { + LD_GP8_INC(px, inc_x, x0, x1, x2, x3, x4, x5, x6, x7); + LD_GP8_INC(py, inc_y, y0, y1, y2, y3, y4, y5, y6, y7); + ST_GP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, srcy, inc_y); + ST_GP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, srcx, inc_x); + } + + if (n & 7) + { + if ((n & 4) && (n & 2) && (n & 1)) + { + LD_GP7_INC(px, inc_x, x0, x1, x2, x3, x4, x5, x6); + LD_GP7_INC(py, inc_y, y0, y1, y2, y3, y4, y5, y6); + ST_GP7_INC(x0, x1, x2, x3, x4, x5, x6, srcy, inc_y); + ST_GP7_INC(y0, y1, y2, y3, y4, y5, y6, srcx, inc_x); + } + else if ((n & 4) && (n & 2)) + { + LD_GP6_INC(px, inc_x, x0, x1, x2, x3, x4, x5); + LD_GP6_INC(py, inc_y, y0, y1, y2, y3, y4, y5); + ST_GP6_INC(x0, x1, x2, x3, x4, x5, srcy, inc_y); + ST_GP6_INC(y0, y1, y2, y3, y4, y5, srcx, inc_x); + } + else if ((n & 4) && (n & 1)) + { + LD_GP5_INC(px, inc_x, x0, x1, x2, x3, x4); + LD_GP5_INC(py, inc_y, y0, y1, y2, y3, y4); + ST_GP5_INC(x0, x1, x2, x3, x4, srcy, inc_y); + ST_GP5_INC(y0, y1, y2, y3, y4, srcx, inc_x); + } + else if ((n & 2) && (n & 1)) + { + LD_GP3_INC(px, inc_x, x0, x1, x2); + LD_GP3_INC(py, inc_y, y0, y1, y2); + ST_GP3_INC(x0, x1, x2, srcy, inc_y); + ST_GP3_INC(y0, y1, y2, srcx, inc_x); + } + else if (n & 4) + { + LD_GP4_INC(px, inc_x, x0, x1, x2, x3); + LD_GP4_INC(py, inc_y, y0, y1, y2, y3); + ST_GP4_INC(x0, x1, x2, x3, srcy, inc_y); + ST_GP4_INC(y0, y1, y2, y3, srcx, inc_x); + } + else if (n & 2) + { + LD_GP2_INC(px, inc_x, x0, x1); + LD_GP2_INC(py, inc_y, y0, y1); + ST_GP2_INC(x0, x1, srcy, inc_y); + ST_GP2_INC(y0, y1, srcx, inc_x); + } + else if (n & 1) + { + x0 = *srcx; + y0 = *srcy; + + *srcx = y0; + *srcy = x0; + } + } + } + + return (0); +} diff --git a/kernel/mips/strsm_kernel_LN_8x8_msa.c b/kernel/mips/strsm_kernel_LN_8x8_msa.c index 53891e64ff..56a3398cbd 100644 --- a/kernel/mips/strsm_kernel_LN_8x8_msa.c +++ b/kernel/mips/strsm_kernel_LN_8x8_msa.c @@ -30,9 +30,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. static void ssolve_8x8_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { - BLASLONG k; - FLOAT *aa = a, *bb = b; - v4f32 src_b, src_b0, src_b1, src_b2, src_b3, src_a1; v4f32 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v4f32 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; v4f32 res_c0, res_c1, res_c2, res_c3, res_c4, res_c5, res_c6, res_c7; @@ -59,34 +56,101 @@ static void ssolve_8x8_ln_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO LD_SP2(c_nxt6line, 4, src_c12, src_c13); LD_SP2(c_nxt7line, 4, src_c14, src_c15); - for (k = 0; k < bk; k++) + if (bk > 0) { - LD_SP2(aa, 4, src_a0, src_a1); + BLASLONG k, pref_offset; + FLOAT *aa = a, *bb = b, *pa0_pref; + v4f32 src_a1, src_b0, src_b1, src_b2, src_b3, src_bb0, src_bb1; - src_b = LD_SP(bb + 0); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c0 -= src_a0 * src_b0; - src_c1 -= src_a1 * src_b0; - src_c2 -= src_a0 * src_b1; - src_c3 -= src_a1 * src_b1; - src_c4 -= src_a0 * src_b2; - src_c5 -= src_a1 * src_b2; - src_c6 -= src_a0 * src_b3; - src_c7 -= src_a1 * src_b3; + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - src_b = LD_SP(bb + 4); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c8 -= src_a0 * src_b0; - src_c9 -= src_a1 * src_b0; - src_c10 -= src_a0 * src_b1; - src_c11 -= src_a1 * src_b1; - src_c12 -= src_a0 * src_b2; - src_c13 -= src_a1 * src_b2; - src_c14 -= src_a0 * src_b3; - src_c15 -= src_a1 * src_b3; + if (pref_offset) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - aa += 8; - bb += 8; + pa0_pref = a + pref_offset; + + for (k = 0; k < (bk >> 1); k++) + { + PREF_OFFSET(pa0_pref, 64); + PREF_OFFSET(pa0_pref, 96); + + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + pa0_pref += 16; + } + + if (bk & 1) + { + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + } } a -= 64; diff --git a/kernel/mips/strsm_kernel_LT_8x8_msa.c b/kernel/mips/strsm_kernel_LT_8x8_msa.c index 5834d77b24..a666915bbe 100644 --- a/kernel/mips/strsm_kernel_LT_8x8_msa.c +++ b/kernel/mips/strsm_kernel_LT_8x8_msa.c @@ -30,8 +30,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. static void ssolve_8x8_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { - BLASLONG k; - v4f32 src_b, src_b0, src_b1, src_b2, src_b3; v4f32 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v4f32 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; v4f32 res_c0, res_c1, res_c2, res_c3, res_c4, res_c5, res_c6, res_c7; @@ -58,34 +56,101 @@ static void ssolve_8x8_lt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO LD_SP2(c_nxt6line, 4, src_c12, src_c13); LD_SP2(c_nxt7line, 4, src_c14, src_c15); - for (k = 0; k < bk; k++) + if (bk > 0) { - LD_SP2(a, 4, src_a0, src_a1); + BLASLONG k, pref_offset; + FLOAT *pa0_pref; + v4f32 src_b0, src_b1, src_b2, src_b3, src_bb0, src_bb1; - src_b = LD_SP(b + 0); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c0 -= src_a0 * src_b0; - src_c1 -= src_a1 * src_b0; - src_c2 -= src_a0 * src_b1; - src_c3 -= src_a1 * src_b1; - src_c4 -= src_a0 * src_b2; - src_c5 -= src_a1 * src_b2; - src_c6 -= src_a0 * src_b3; - src_c7 -= src_a1 * src_b3; + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - src_b = LD_SP(b + 4); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c8 -= src_a0 * src_b0; - src_c9 -= src_a1 * src_b0; - src_c10 -= src_a0 * src_b1; - src_c11 -= src_a1 * src_b1; - src_c12 -= src_a0 * src_b2; - src_c13 -= src_a1 * src_b2; - src_c14 -= src_a0 * src_b3; - src_c15 -= src_a1 * src_b3; + if (pref_offset) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - a += 8; - b += 8; + pa0_pref = a + pref_offset; + + for (k = 0; k < (bk >> 1); k++) + { + PREF_OFFSET(pa0_pref, 64); + PREF_OFFSET(pa0_pref, 96); + + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + pa0_pref += 16; + } + + if (bk & 1) + { + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + } } TRANSPOSE4x4_SP_SP(src_c0, src_c2, src_c4, src_c6, diff --git a/kernel/mips/strsm_kernel_RN_8x8_msa.c b/kernel/mips/strsm_kernel_RN_8x8_msa.c index 642ee37572..ee38948891 100644 --- a/kernel/mips/strsm_kernel_RN_8x8_msa.c +++ b/kernel/mips/strsm_kernel_RN_8x8_msa.c @@ -30,8 +30,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. static void ssolve_8x8_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { - BLASLONG k; - v4f32 src_a0, src_a1; v4f32 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v4f32 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; v4f32 src_b0, src_b1, src_b2, src_b3, src_b4, src_b5, src_b6, src_b7; @@ -56,34 +54,101 @@ static void ssolve_8x8_rn_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO LD_SP2(c_nxt6line, 4, src_c12, src_c13); LD_SP2(c_nxt7line, 4, src_c14, src_c15); - for (k = 0; k < bk; k++) + if (bk > 0) { - LD_SP2(a, 4, src_a0, src_a1); + BLASLONG k, pref_offset; + FLOAT *pa0_pref; + v4f32 src_a0, src_a1, src_bb0, src_bb1; - src_b = LD_SP(b + 0); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c0 -= src_a0 * src_b0; - src_c1 -= src_a1 * src_b0; - src_c2 -= src_a0 * src_b1; - src_c3 -= src_a1 * src_b1; - src_c4 -= src_a0 * src_b2; - src_c5 -= src_a1 * src_b2; - src_c6 -= src_a0 * src_b3; - src_c7 -= src_a1 * src_b3; + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - src_b = LD_SP(b + 4); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c8 -= src_a0 * src_b0; - src_c9 -= src_a1 * src_b0; - src_c10 -= src_a0 * src_b1; - src_c11 -= src_a1 * src_b1; - src_c12 -= src_a0 * src_b2; - src_c13 -= src_a1 * src_b2; - src_c14 -= src_a0 * src_b3; - src_c15 -= src_a1 * src_b3; + if (pref_offset) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - a += 8; - b += 8; + pa0_pref = a + pref_offset; + + for (k = 0; k < (bk >> 1); k++) + { + PREF_OFFSET(pa0_pref, 64); + PREF_OFFSET(pa0_pref, 96); + + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + pa0_pref += 16; + } + + if (bk & 1) + { + LD_SP2_INC(a, 4, src_a0, src_a1); + LD_SP2_INC(b, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + } } src_b = LD_SP(b + 0); diff --git a/kernel/mips/strsm_kernel_RT_8x8_msa.c b/kernel/mips/strsm_kernel_RT_8x8_msa.c index 21e41c8fbd..57438f7c73 100644 --- a/kernel/mips/strsm_kernel_RT_8x8_msa.c +++ b/kernel/mips/strsm_kernel_RT_8x8_msa.c @@ -30,9 +30,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. static void ssolve_8x8_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLONG bk) { - BLASLONG k; - FLOAT *aa = a, *bb = b; - v4f32 src_a0, src_a1, src_b1, src_b2, src_b3; v4f32 src_c0, src_c1, src_c2, src_c3, src_c4, src_c5, src_c6, src_c7; v4f32 src_c8, src_c9, src_c10, src_c11, src_c12, src_c13, src_c14, src_c15; v4f32 src_b, src_b0, src_b8, src_b9, src_b16, src_b17, src_b18, src_b24; @@ -57,34 +54,101 @@ static void ssolve_8x8_rt_msa(FLOAT *a, FLOAT *b, FLOAT *c, BLASLONG ldc, BLASLO LD_SP2(c_nxt6line, 4, src_c12, src_c13); LD_SP2(c_nxt7line, 4, src_c14, src_c15); - for (k = 0; k < bk; k++) + if (bk > 0) { - LD_SP2(aa, 4, src_a0, src_a1); + BLASLONG k, pref_offset; + FLOAT *aa = a, *bb = b, *pa0_pref; + v4f32 src_a0, src_a1, src_b1, src_b2, src_b3, src_bb0, src_bb1; - src_b = LD_SP(bb + 0); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c0 -= src_a0 * src_b0; - src_c1 -= src_a1 * src_b0; - src_c2 -= src_a0 * src_b1; - src_c3 -= src_a1 * src_b1; - src_c4 -= src_a0 * src_b2; - src_c5 -= src_a1 * src_b2; - src_c6 -= src_a0 * src_b3; - src_c7 -= src_a1 * src_b3; + pref_offset = (uintptr_t)a & (L1_DATA_LINESIZE - 1); - src_b = LD_SP(bb + 4); - SPLATI_W4_SP(src_b, src_b0, src_b1, src_b2, src_b3); - src_c8 -= src_a0 * src_b0; - src_c9 -= src_a1 * src_b0; - src_c10 -= src_a0 * src_b1; - src_c11 -= src_a1 * src_b1; - src_c12 -= src_a0 * src_b2; - src_c13 -= src_a1 * src_b2; - src_c14 -= src_a0 * src_b3; - src_c15 -= src_a1 * src_b3; + if (pref_offset) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } - aa += 8; - bb += 8; + pa0_pref = a + pref_offset; + + for (k = 0; k < (bk >> 1); k++) + { + PREF_OFFSET(pa0_pref, 64); + PREF_OFFSET(pa0_pref, 96); + + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + + pa0_pref += 16; + } + + if (bk & 1) + { + LD_SP2_INC(aa, 4, src_a0, src_a1); + LD_SP2_INC(bb, 4, src_bb0, src_bb1); + + SPLATI_W4_SP(src_bb0, src_b0, src_b1, src_b2, src_b3); + src_c0 -= src_a0 * src_b0; + src_c1 -= src_a1 * src_b0; + src_c2 -= src_a0 * src_b1; + src_c3 -= src_a1 * src_b1; + src_c4 -= src_a0 * src_b2; + src_c5 -= src_a1 * src_b2; + src_c6 -= src_a0 * src_b3; + src_c7 -= src_a1 * src_b3; + + SPLATI_W4_SP(src_bb1, src_b0, src_b1, src_b2, src_b3); + src_c8 -= src_a0 * src_b0; + src_c9 -= src_a1 * src_b0; + src_c10 -= src_a0 * src_b1; + src_c11 -= src_a1 * src_b1; + src_c12 -= src_a0 * src_b2; + src_c13 -= src_a1 * src_b2; + src_c14 -= src_a0 * src_b3; + src_c15 -= src_a1 * src_b3; + } } b -= 64; diff --git a/kernel/mips/zasum_msa.c b/kernel/mips/zasum_msa.c index c84d48ecbc..6a26244243 100644 --- a/kernel/mips/zasum_msa.c +++ b/kernel/mips/zasum_msa.c @@ -31,139 +31,232 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define AND_VEC_D(in) ((v2f64) ((v2i64) in & and_vec)) -#define PROCESS_ZD(inc_val) \ - if (n > 8) \ - { \ - n -= 8; \ - \ - LD_DP8_INC(x, inc_val, src0, src1, src2, \ - src3, src4, src5, src6, src7); \ - \ - sum_abs0 = AND_VEC_D(src0); \ - sum_abs1 = AND_VEC_D(src1); \ - sum_abs2 = AND_VEC_D(src2); \ - sum_abs3 = AND_VEC_D(src3); \ - sum_abs0 += AND_VEC_D(src4); \ - sum_abs1 += AND_VEC_D(src5); \ - sum_abs2 += AND_VEC_D(src6); \ - sum_abs3 += AND_VEC_D(src7); \ - } \ - else \ - { \ - sum_abs0 = zero_v; \ - sum_abs1 = zero_v; \ - sum_abs2 = zero_v; \ - sum_abs3 = zero_v; \ - } \ - \ - for (i = (n >> 3); i--;) \ - { \ - LD_DP8_INC(x, inc_val, src0, src1, src2, \ - src3, src4, src5, src6, src7); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - sum_abs3 += AND_VEC_D(src3); \ - sum_abs0 += AND_VEC_D(src4); \ - sum_abs1 += AND_VEC_D(src5); \ - sum_abs2 += AND_VEC_D(src6); \ - sum_abs3 += AND_VEC_D(src7); \ - } \ - \ - if (n & 7) \ - { \ - if ((n & 4) && (n & 2) && (n & 1)) \ - { \ - LD_DP7_INC(x, inc_val, src0, src1, src2, \ - src3, src4, src5, src6); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - sum_abs3 += AND_VEC_D(src3); \ - sum_abs0 += AND_VEC_D(src4); \ - sum_abs1 += AND_VEC_D(src5); \ - sum_abs2 += AND_VEC_D(src6); \ - } \ - else if ((n & 4) && (n & 2)) \ - { \ - LD_DP6_INC(x, inc_val, src0, src1, src2, \ - src3, src4, src5); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - sum_abs3 += AND_VEC_D(src3); \ - sum_abs0 += AND_VEC_D(src4); \ - sum_abs1 += AND_VEC_D(src5); \ - } \ - else if ((n & 4) && (n & 1)) \ - { \ - LD_DP5_INC(x, inc_val, src0, src1, src2, \ - src3, src4); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - sum_abs3 += AND_VEC_D(src3); \ - sum_abs0 += AND_VEC_D(src4); \ - } \ - else if ((n & 2) && (n & 1)) \ - { \ - LD_DP3_INC(x, inc_val, src0, src1, src2); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - } \ - else if (n & 4) \ - { \ - LD_DP4_INC(x, inc_val, src0, src1, src2, \ - src3); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - sum_abs2 += AND_VEC_D(src2); \ - sum_abs3 += AND_VEC_D(src3); \ - } \ - else if (n & 2) \ - { \ - LD_DP2_INC(x, inc_val, src0, src1); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - sum_abs1 += AND_VEC_D(src1); \ - } \ - else if (n & 1) \ - { \ - src0 = LD_DP(x); \ - \ - sum_abs0 += AND_VEC_D(src0); \ - } \ - } \ - \ - sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; \ - sumf = sum_abs0[0] + sum_abs0[1]; - FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) { BLASLONG i; FLOAT sumf = 0.0; v2f64 src0, src1, src2, src3, src4, src5, src6, src7; - v2f64 sum_abs0, sum_abs1, sum_abs2, sum_abs3; - v2f64 zero_v = {0}; + v2f64 src8, src9, src10, src11, src12, src13, src14, src15; + v2f64 sum_abs0 = {0, 0}; + v2f64 sum_abs1 = {0, 0}; + v2f64 sum_abs2 = {0, 0}; + v2f64 sum_abs3 = {0, 0}; v2i64 and_vec = {0x7FFFFFFFFFFFFFFF, 0x7FFFFFFFFFFFFFFF}; if (n <= 0 || inc_x <= 0) return (sumf); if (1 == inc_x) { - PROCESS_ZD(2); + if (n > 16) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 16; + + LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 4) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + LD_DP8_INC(x, 2, src8, src9, src10, src11, src12, src13, src14, src15); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + + LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } + + LD_DP8_INC(x, 2, src8, src9, src10, src11, src12, src13, src14, src15); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(x, 2, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + } + + if (n & 4) + { + LD_DP4_INC(x, 2, src0, src1, src2, src3); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + } + + if (n & 2) + { + LD_DP2_INC(x, 2, src0, src1); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + } + + if (n & 1) + { + src0 = LD_DP(x); + + sum_abs0 += AND_VEC_D(src0); + } + } + + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + sumf = sum_abs0[0] + sum_abs0[1]; } else { inc_x *= 2; - PROCESS_ZD(inc_x); + + if (n > 16) + { + LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + for (i = (n >> 4) - 1; i--;) + { + LD_DP8_INC(x, inc_x, src8, src9, src10, src11, src12, src13, src14, src15); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + + LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } + + LD_DP8_INC(x, inc_x, src8, src9, src10, src11, src12, src13, src14, src15); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + sum_abs0 += AND_VEC_D(src8); + sum_abs1 += AND_VEC_D(src9); + sum_abs2 += AND_VEC_D(src10); + sum_abs3 += AND_VEC_D(src11); + sum_abs0 += AND_VEC_D(src12); + sum_abs1 += AND_VEC_D(src13); + sum_abs2 += AND_VEC_D(src14); + sum_abs3 += AND_VEC_D(src15); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(x, inc_x, src0, src1, src2, src3, src4, src5, src6, src7); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + sum_abs0 += AND_VEC_D(src4); + sum_abs1 += AND_VEC_D(src5); + sum_abs2 += AND_VEC_D(src6); + sum_abs3 += AND_VEC_D(src7); + } + + if (n & 4) + { + LD_DP4_INC(x, inc_x, src0, src1, src2, src3); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + sum_abs2 += AND_VEC_D(src2); + sum_abs3 += AND_VEC_D(src3); + } + + if (n & 2) + { + LD_DP2_INC(x, inc_x, src0, src1); + + sum_abs0 += AND_VEC_D(src0); + sum_abs1 += AND_VEC_D(src1); + } + + if (n & 1) + { + src0 = LD_DP(x); + + sum_abs0 += AND_VEC_D(src0); + } + } + + sum_abs0 += sum_abs1 + sum_abs2 + sum_abs3; + sumf = sum_abs0[0] + sum_abs0[1]; } return (sumf); diff --git a/kernel/mips/zaxpy_msa.c b/kernel/mips/zaxpy_msa.c new file mode 100644 index 0000000000..f17748f022 --- /dev/null +++ b/kernel/mips/zaxpy_msa.c @@ -0,0 +1,494 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +#if !defined(CONJ) + #define OP0 += + #define OP1 -= + #define OP2 += +#else + #define OP0 -= + #define OP1 += + #define OP2 -= +#endif + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, + FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i, inc_x2, inc_y2; + FLOAT *py; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7; + v2f64 y0, y1, y2, y3, y4, y5, y6, y7, dar_vec, dai_vec; + v2f64 x0r, x1r, x2r, x3r, x0i, x1i, x2i, x3i; + v2f64 y0r, y1r, y2r, y3r, y0i, y1i, y2i, y3i; + FLOAT xd0, xd1, yd0, yd1; + + if (n < 0) return(0); + if ((da_r == 0.0) && (da_i == 0.0)) return(0); + + py = y; + + dar_vec = COPY_DOUBLE_TO_VECTOR(da_r); + dai_vec = COPY_DOUBLE_TO_VECTOR(da_i); + + if ((1 == inc_x) && (1 == inc_y)) + { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32; + + for (i = (n >> 3); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 16; + y_pref += 16; + + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + PCKEVOD_D2_DP(x5, x4, x2r, x2i); + PCKEVOD_D2_DP(y5, y4, y2r, y2i); + PCKEVOD_D2_DP(x7, x6, x3r, x3i); + PCKEVOD_D2_DP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ILVRL_D2_DP(y2i, y2r, y4, y5); + ILVRL_D2_DP(y3i, y3r, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 2); + } + + if (n & 7) + { + if (n & 4) + { + LD_DP4_INC(x, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, 2); + } + + if (n & 2) + { + LD_DP2_INC(x, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ST_DP2_INC(y0, y1, y, 2); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + else if (1 == inc_y) + { + FLOAT *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32; + + inc_x2 = 2 * inc_x; + + for (i = (n >> 3); i--;) + { + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + y_pref += 16; + + LD_DP8_INC(x, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + PCKEVOD_D2_DP(x5, x4, x2r, x2i); + PCKEVOD_D2_DP(y5, y4, y2r, y2i); + PCKEVOD_D2_DP(x7, x6, x3r, x3i); + PCKEVOD_D2_DP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ILVRL_D2_DP(y2i, y2r, y4, y5); + ILVRL_D2_DP(y3i, y3r, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, 2); + } + + if (n & 7) + { + if (n & 4) + { + LD_DP4_INC(x, inc_x2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, 2); + } + + if (n & 2) + { + LD_DP2_INC(x, inc_x2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ST_DP2_INC(y0, y1, y, 2); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + else if (1 == inc_x) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32; + + inc_y2 = 2 * inc_y; + + for (i = (n >> 3); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + x_pref += 16; + + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, inc_y2, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + PCKEVOD_D2_DP(x5, x4, x2r, x2i); + PCKEVOD_D2_DP(y5, y4, y2r, y2i); + PCKEVOD_D2_DP(x7, x6, x3r, x3i); + PCKEVOD_D2_DP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ILVRL_D2_DP(y2i, y2r, y4, y5); + ILVRL_D2_DP(y3i, y3r, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, inc_y2); + } + + if (n & 7) + { + if (n & 4) + { + LD_DP4_INC(x, 2, x0, x1, x2, x3); + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, inc_y2); + } + + if (n & 2) + { + LD_DP2_INC(x, 2, x0, x1); + LD_DP2_INC(py, inc_y2, y0, y1); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ST_DP2_INC(y0, y1, y, inc_y2); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + else + { + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + for (i = (n >> 3); i--;) + { + LD_DP8_INC(x, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, inc_y2, y0, y1, y2, y3, y4, y5, y6, y7); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + PCKEVOD_D2_DP(x5, x4, x2r, x2i); + PCKEVOD_D2_DP(y5, y4, y2r, y2i); + PCKEVOD_D2_DP(x7, x6, x3r, x3i); + PCKEVOD_D2_DP(y7, y6, y3r, y3i); + + FMADD4(x0r, x1r, x2r, x3r, dar_vec, y0r, y1r, y2r, y3r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y2i OP0 dar_vec * x2i; + y3i OP0 dar_vec * x3i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y2r OP1 dai_vec * x2i; + y3r OP1 dai_vec * x3i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + y2i OP2 dai_vec * x2r; + y3i OP2 dai_vec * x3r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ILVRL_D2_DP(y2i, y2r, y4, y5); + ILVRL_D2_DP(y3i, y3r, y6, y7); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, inc_y2); + } + + if (n & 7) + { + if (n & 4) + { + LD_DP4_INC(x, inc_x2, x0, x1, x2, x3); + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + PCKEVOD_D2_DP(x3, x2, x1r, x1i); + PCKEVOD_D2_DP(y3, y2, y1r, y1i); + + FMADD2(x0r, x1r, dar_vec, y0r, y1r); + y0i OP0 dar_vec * x0i; + y1i OP0 dar_vec * x1i; + y0r OP1 dai_vec * x0i; + y1r OP1 dai_vec * x1i; + y0i OP2 dai_vec * x0r; + y1i OP2 dai_vec * x1r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ILVRL_D2_DP(y1i, y1r, y2, y3); + ST_DP4_INC(y0, y1, y2, y3, y, inc_y2); + } + + if (n & 2) + { + LD_DP2_INC(x, inc_x2, x0, x1); + LD_DP2_INC(py, inc_y2, y0, y1); + PCKEVOD_D2_DP(x1, x0, x0r, x0i); + PCKEVOD_D2_DP(y1, y0, y0r, y0i); + + y0r += dar_vec * x0r; + y0i OP0 dar_vec * x0i; + y0r OP1 dai_vec * x0i; + y0i OP2 dai_vec * x0r; + + ILVRL_D2_DP(y0i, y0r, y0, y1); + ST_DP2_INC(y0, y1, y, inc_y2); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, xd0, xd1); + LD_GP2_INC(py, 1, yd0, yd1); + + yd0 += da_r * xd0; + yd1 OP0 da_r * xd1; + yd0 OP1 da_i * xd1; + yd1 OP2 da_i * xd0; + + ST_GP2_INC(yd0, yd1, y, 1); + } + } + } + + return (0); +} diff --git a/kernel/mips/zcopy_msa.c b/kernel/mips/zcopy_msa.c new file mode 100644 index 0000000000..690732d833 --- /dev/null +++ b/kernel/mips/zcopy_msa.c @@ -0,0 +1,218 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) +{ + BLASLONG i; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + FLOAT f0, f1; + + if (n < 0) return (0); + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n > 15) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 64 + 16; + + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 4) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + x8 = LD_DP(x); x += 2; + ST_DP(x0, y); y += 2; + x9 = LD_DP(x); x += 2; + ST_DP(x1, y); y += 2; + x10 = LD_DP(x); x += 2; + ST_DP(x2, y); y += 2; + x11 = LD_DP(x); x += 2; + ST_DP(x3, y); y += 2; + x12 = LD_DP(x); x += 2; + ST_DP(x4, y); y += 2; + x13 = LD_DP(x); x += 2; + ST_DP(x5, y); y += 2; + x14 = LD_DP(x); x += 2; + ST_DP(x6, y); y += 2; + x15 = LD_DP(x); x += 2; + ST_DP(x7, y); y += 2; + x0 = LD_DP(x); x += 2; + ST_DP(x8, y); y += 2; + x1 = LD_DP(x); x += 2; + ST_DP(x9, y); y += 2; + x2 = LD_DP(x); x += 2; + ST_DP(x10, y); y += 2; + x3 = LD_DP(x); x += 2; + ST_DP(x11, y); y += 2; + x4 = LD_DP(x); x += 2; + ST_DP(x12, y); y += 2; + x5 = LD_DP(x); x += 2; + ST_DP(x13, y); y += 2; + x6 = LD_DP(x); x += 2; + ST_DP(x14, y); y += 2; + x7 = LD_DP(x); x += 2; + ST_DP(x15, y); y += 2; + } + + x8 = LD_DP(x); x += 2; + x9 = LD_DP(x); x += 2; + ST_DP(x0, y); y += 2; + x10 = LD_DP(x); x += 2; + ST_DP(x1, y); y += 2; + x11 = LD_DP(x); x += 2; + ST_DP(x2, y); y += 2; + x12 = LD_DP(x); x += 2; + ST_DP(x3, y); y += 2; + x13 = LD_DP(x); x += 2; + ST_DP(x4, y); y += 2; + x14 = LD_DP(x); x += 2; + ST_DP(x5, y); y += 2; + x15 = LD_DP(x); x += 2; + ST_DP(x6, y); y += 2; + ST_DP(x7, y); y += 2; + + ST_DP8_INC(x8, x9, x10, x11, x12, x13, x14, x15, y, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(x, 2, x0, x1, x2, x3, x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, y, 2); + } + + if (n & 4) + { + LD_DP4_INC(x, 2, x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, y, 2); + } + + if (n & 2) + { + LD_DP2_INC(x, 2, x0, x1); + ST_DP2_INC(x0, x1, y, 2); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + } + } + else + { + inc_x *= 2; + inc_y *= 2; + + for (i = (n >> 4); i--;) + { + x0 = LD_DP(x); x += inc_x; + x1 = LD_DP(x); x += inc_x; + x2 = LD_DP(x); x += inc_x; + x3 = LD_DP(x); x += inc_x; + x4 = LD_DP(x); x += inc_x; + x5 = LD_DP(x); x += inc_x; + x6 = LD_DP(x); x += inc_x; + x7 = LD_DP(x); x += inc_x; + x8 = LD_DP(x); x += inc_x; + ST_DP(x0, y); y += inc_y; + x9 = LD_DP(x); x += inc_x; + ST_DP(x1, y); y += inc_y; + x10 = LD_DP(x); x += inc_x; + ST_DP(x2, y); y += inc_y; + x11 = LD_DP(x); x += inc_x; + ST_DP(x3, y); y += inc_y; + x12 = LD_DP(x); x += inc_x; + ST_DP(x4, y); y += inc_y; + x13 = LD_DP(x); x += inc_x; + ST_DP(x5, y); y += inc_y; + x14 = LD_DP(x); x += inc_x; + ST_DP(x6, y); y += inc_y; + x15 = LD_DP(x); x += inc_x; + ST_DP(x7, y); y += inc_y; + ST_DP(x8, y); y += inc_y; + ST_DP(x9, y); y += inc_y; + ST_DP(x10, y); y += inc_y; + ST_DP(x11, y); y += inc_y; + ST_DP(x12, y); y += inc_y; + ST_DP(x13, y); y += inc_y; + ST_DP(x14, y); y += inc_y; + ST_DP(x15, y); y += inc_y; + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(x, inc_x, x0, x1, x2, x3, x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, y, inc_y); + } + + if (n & 4) + { + LD_DP4_INC(x, inc_x, x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, y, inc_y); + } + + if (n & 2) + { + LD_DP2_INC(x, inc_x, x0, x1); + ST_DP2_INC(x0, x1, y, inc_y); + } + + if (n & 1) + { + LD_GP2_INC(x, 1, f0, f1); + ST_GP2_INC(f0, f1, y, 1); + } + } + } + + return (0); +} diff --git a/kernel/mips/zdot.c b/kernel/mips/zdot.c index da9ec70767..df99bae852 100644 --- a/kernel/mips/zdot.c +++ b/kernel/mips/zdot.c @@ -27,12 +27,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#ifndef _MSC_VER -#include -FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#else OPENBLAS_COMPLEX_FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#endif { BLASLONG i=0; BLASLONG ix=0,iy=0; diff --git a/kernel/mips/zdot_msa.c b/kernel/mips/zdot_msa.c index b94509392b..0d9b3c4fac 100644 --- a/kernel/mips/zdot_msa.c +++ b/kernel/mips/zdot_msa.c @@ -29,199 +29,343 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "macros_msa.h" #if !defined(CONJ) - #define OP2 += - #define OP3 - - #define OP4 + + #define OP1 -= + #define OP2 += + #define OP3 - + #define OP4 + #else - #define OP2 -= - #define OP3 + - #define OP4 - + #define OP1 += + #define OP2 -= + #define OP3 + + #define OP4 - #endif -#define DOT16_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); \ - \ - dot0 += (vx2r * vy2r); \ - dot0 OPR0## = (vx2i * vy2i); \ - dot1 OPR1## = (vx2i * vy2r); \ - dot1 += (vx2r * vy2i); \ - \ - dot0 += (vx3r * vy3r); \ - dot0 OPR0## = (vx3i * vy3i); \ - dot1 OPR1## = (vx3i * vy3r); \ - dot1 += (vx3r * vy3i); - -#define DOT12_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); \ - \ - dot0 += (vx2r * vy2r); \ - dot0 OPR0## = (vx2i * vy2i); \ - dot1 OPR1## = (vx2i * vy2r); \ - dot1 += (vx2r * vy2i); - -#define DOT8_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); \ - \ - dot0 += (vx1r * vy1r); \ - dot0 OPR0## = (vx1i * vy1i); \ - dot1 OPR1## = (vx1i * vy1r); \ - dot1 += (vx1r * vy1i); - -#define DOT4_KERNEL(OPR0, OPR1) \ - dot0 += (vx0r * vy0r); \ - dot0 OPR0## = (vx0i * vy0i); \ - dot1 OPR1## = (vx0i * vy0r); \ - dot1 += (vx0r * vy0i); - -/* return double, x,y double */ -/* zdotc - CONJ */ -/* zdotu - !CONJ */ -#ifndef _MSC_VER -#include -FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#else OPENBLAS_COMPLEX_FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) -#endif { BLASLONG i = 0; FLOAT dot[2]; - BLASLONG inc_x2; - BLASLONG inc_y2; - v2f64 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7; - v2f64 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7; - v2f64 vx0r, vx0i, vx1r, vx1i, vx2r, vx2i, vx3r, vx3i; - v2f64 vy0r, vy0i, vy1r, vy1i, vy2r, vy2i, vy3r, vy3i; + BLASLONG inc_x2, inc_y2; + v2f64 vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7, vx8, vx9, vx10, vx11; + v2f64 vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7, vy8, vy9, vy10, vy11; + v2f64 vx0r, vx0i, vx1r, vx1i, vx2r, vx2i, vx3r, vx3i; + v2f64 vy0r, vy0i, vy1r, vy1i, vy2r, vy2i, vy3r, vy3i; v2f64 dot0 = {0, 0}; v2f64 dot1 = {0, 0}; + v2f64 dot2 = {0, 0}; + v2f64 dot3 = {0, 0}; + v2f64 dot4 = {0, 0}; + v2f64 dot5 = {0, 0}; + v2f64 dot6 = {0, 0}; + v2f64 dot7 = {0, 0}; v2f64 zero = {0, 0}; - openblas_complex_double result; + OPENBLAS_COMPLEX_FLOAT result; dot[0] = 0.0; dot[1] = 0.0; - __real__(result) = 0.0; - __imag__(result) = 0.0; + CREAL(result) = 0.0; + CIMAG(result) = 0.0; - if ( n < 1 ) return(result); + if (n < 1) return (result); inc_x2 = 2 * inc_x; inc_y2 = 2 * inc_y; - for (i = (n >> 3); i--;) - { - LD_DP8_INC(x, inc_x2, vx0, vx1, vx2, vx3, vx4, vx5, vx6, vx7); - LD_DP8_INC(y, inc_y2, vy0, vy1, vy2, vy3, vy4, vy5, vy6, vy7); - - PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); - PCKEVOD_D2_DP(vx3, vx2, vx1r, vx1i); - PCKEVOD_D2_DP(vx5, vx4, vx2r, vx2i); - PCKEVOD_D2_DP(vx7, vx6, vx3r, vx3i); - - PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); - PCKEVOD_D2_DP(vy3, vy2, vy1r, vy1i); - PCKEVOD_D2_DP(vy5, vy4, vy2r, vy2i); - PCKEVOD_D2_DP(vy7, vy6, vy3r, vy3i); - - #if !defined(CONJ) - DOT16_KERNEL(-, +); - #else - DOT16_KERNEL(+, -); - #endif - } - - if (n & 7) - { - if ((n & 4) && (n & 2)) - { - LD_DP4_INC(x, inc_x2, vx0, vx1, vx2, vx3); - LD_DP4_INC(y, inc_y2, vy0, vy1, vy2, vy3); - LD_DP2_INC(x, inc_x2, vx4, vx5); - LD_DP2_INC(y, inc_y2, vy4, vy5); - - PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); - PCKEVOD_D2_DP(vx3, vx2, vx1r, vx1i); - PCKEVOD_D2_DP(vx5, vx4, vx2r, vx2i); - - PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); - PCKEVOD_D2_DP(vy3, vy2, vy1r, vy1i); - PCKEVOD_D2_DP(vy5, vy4, vy2r, vy2i); - - #if !defined(CONJ) - DOT12_KERNEL(-, +); - #else - DOT12_KERNEL(+, -); - #endif - } - else if (n & 4) - { - LD_DP4_INC(x, inc_x2, vx0, vx1, vx2, vx3); - LD_DP4_INC(y, inc_y2, vy0, vy1, vy2, vy3); - - PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); - PCKEVOD_D2_DP(vx3, vx2, vx1r, vx1i); - - PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); - PCKEVOD_D2_DP(vy3, vy2, vy1r, vy1i); - - #if !defined(CONJ) - DOT8_KERNEL(-, +); - #else - DOT8_KERNEL(+, -); - #endif - } - else if (n & 2) - { - LD_DP2_INC(x, inc_x2, vx0, vx1); - LD_DP2_INC(y, inc_y2, vy0, vy1); - PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); - PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); - - #if !defined(CONJ) - DOT4_KERNEL(-, +); - #else - DOT4_KERNEL(+, -); - #endif - } - - if (n & 1) - { - vx0 = LD_DP(x); - vy0 = LD_DP(y); - PCKEVOD_D2_DP(zero, vx0, vx0r, vx0i); - PCKEVOD_D2_DP(zero, vy0, vy0r, vy0i); - - #if !defined(CONJ) - DOT4_KERNEL(-, +); - #else - DOT4_KERNEL(+, -); - #endif - } - } - - dot[0] += (dot0[0] + dot0[1]); - dot[1] += (dot1[0] + dot1[1]); - - __real__(result) = dot[0]; - __imag__(result) = dot[1]; - - return(result); + if ((1 == inc_x) && (1 == inc_y)) + { + if (n > 7) + { + FLOAT *x_pref, *y_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32 + 8; + + pref_offset = (BLASLONG)y & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + y_pref = y + pref_offset + 32 + 8; + + LD_DP4_INC(x, 2, vx0, vx1, vx2, vx3); + LD_DP4_INC(y, 2, vy0, vy1, vy2, vy3); + + PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); + PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); + + for (i = (n >> 3) - 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(y_pref, 0); + PREF_OFFSET(y_pref, 32); + PREF_OFFSET(y_pref, 64); + PREF_OFFSET(y_pref, 96); + x_pref += 16; + y_pref += 16; + + vx4 = LD_DP(x); x += 2; + vx1r = (v2f64) __msa_pckev_d((v2i64) vx3, (v2i64) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_DP(x); x += 2; + vx1i = (v2f64) __msa_pckod_d((v2i64) vx3, (v2i64) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_DP(y); y += 2; + vy1r = (v2f64) __msa_pckev_d((v2i64) vy3, (v2i64) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_DP(y); y += 2; + vy1i = (v2f64) __msa_pckod_d((v2i64) vy3, (v2i64) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_DP(x); x += 2; + vx7 = LD_DP(x); x += 2; + vy6 = LD_DP(y); y += 2; + vy7 = LD_DP(y); y += 2; + vx8 = LD_DP(x); x += 2; + dot0 OP1 (vx0i * vy0i); + vx9 = LD_DP(x); x += 2; + vx2r = (v2f64) __msa_pckev_d((v2i64) vx5, (v2i64) vx4); + dot1 += (vx0r * vy0i); + vy8 = LD_DP(y); y += 2; + vx2i = (v2f64) __msa_pckod_d((v2i64) vx5, (v2i64) vx4); + dot2 OP1 (vx1i * vy1i); + vy9 = LD_DP(y); y += 2; + vy2r = (v2f64) __msa_pckev_d((v2i64) vy5, (v2i64) vy4); + dot3 += (vx1r * vy1i); + vx10 = LD_DP(x); x += 2; + vy2i = (v2f64) __msa_pckod_d((v2i64) vy5, (v2i64) vy4); + vx11 = LD_DP(x); x += 2; + vx3r = (v2f64) __msa_pckev_d((v2i64) vx7, (v2i64) vx6); + dot4 += (vx2r * vy2r); + vy10 = LD_DP(y); y += 2; + vx3i = (v2f64) __msa_pckod_d((v2i64) vx7, (v2i64) vx6); + dot5 OP2 (vx2i * vy2r); + vy11 = LD_DP(y); y += 2; + vy3r = (v2f64) __msa_pckev_d((v2i64) vy7, (v2i64) vy6); + vy3i = (v2f64) __msa_pckod_d((v2i64) vy7, (v2i64) vy6); + dot6 += (vx3r * vy3r); + vx0r = (v2f64) __msa_pckev_d((v2i64) vx9, (v2i64) vx8); + dot7 OP2 (vx3i * vy3r); + vx0i = (v2f64) __msa_pckod_d((v2i64) vx9, (v2i64) vx8); + vy0r = (v2f64) __msa_pckev_d((v2i64) vy9, (v2i64) vy8); + vx2 = vx10; + vy0i = (v2f64) __msa_pckod_d((v2i64) vy9, (v2i64) vy8); + vx3 = vx11; + dot4 OP1 (vx2i * vy2i); + vy2 = vy10; + dot5 += (vx2r * vy2i); + vy3 = vy11; + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); + } + + vx4 = LD_DP(x); x += 2; + vx1r = (v2f64) __msa_pckev_d((v2i64) vx3, (v2i64) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_DP(x); x += 2; + vx1i = (v2f64) __msa_pckod_d((v2i64) vx3, (v2i64) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_DP(y); y += 2; + vy1r = (v2f64) __msa_pckev_d((v2i64) vy3, (v2i64) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_DP(y); y += 2; + vy1i = (v2f64) __msa_pckod_d((v2i64) vy3, (v2i64) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_DP(x); x += 2; + vx7 = LD_DP(x); x += 2; + vy6 = LD_DP(y); y += 2; + vy7 = LD_DP(y); y += 2; + dot0 OP1 (vx0i * vy0i); + vx2r = (v2f64) __msa_pckev_d((v2i64) vx5, (v2i64) vx4); + dot1 += (vx0r * vy0i); + vx2i = (v2f64) __msa_pckod_d((v2i64) vx5, (v2i64) vx4); + dot2 OP1 (vx1i * vy1i); + vy2r = (v2f64) __msa_pckev_d((v2i64) vy5, (v2i64) vy4); + dot3 += (vx1r * vy1i); + vy2i = (v2f64) __msa_pckod_d((v2i64) vy5, (v2i64) vy4); + vx3r = (v2f64) __msa_pckev_d((v2i64) vx7, (v2i64) vx6); + dot4 += (vx2r * vy2r); + vx3i = (v2f64) __msa_pckod_d((v2i64) vx7, (v2i64) vx6); + dot5 OP2 (vx2i * vy2r); + vy3r = (v2f64) __msa_pckev_d((v2i64) vy7, (v2i64) vy6); + vy3i = (v2f64) __msa_pckod_d((v2i64) vy7, (v2i64) vy6); + dot6 += (vx3r * vy3r); + dot7 OP2 (vx3i * vy3r); + dot4 OP1 (vx2i * vy2i); + dot5 += (vx2r * vy2i); + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); + } + } + else if (n > 7) + { + LD_DP4_INC(x, inc_x2, vx0, vx1, vx2, vx3); + LD_DP4_INC(y, inc_y2, vy0, vy1, vy2, vy3); + + PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); + PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); + + for (i = (n >> 3) - 1; i--;) + { + vx4 = LD_DP(x); x += inc_x2; + vx1r = (v2f64) __msa_pckev_d((v2i64) vx3, (v2i64) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_DP(x); x += inc_x2; + vx1i = (v2f64) __msa_pckod_d((v2i64) vx3, (v2i64) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_DP(y); y += inc_y2; + vy1r = (v2f64) __msa_pckev_d((v2i64) vy3, (v2i64) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_DP(y); y += inc_y2; + vy1i = (v2f64) __msa_pckod_d((v2i64) vy3, (v2i64) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_DP(x); x += inc_x2; + vx7 = LD_DP(x); x += inc_x2; + vy6 = LD_DP(y); y += inc_y2; + vy7 = LD_DP(y); y += inc_y2; + vx8 = LD_DP(x); x += inc_x2; + dot0 OP1 (vx0i * vy0i); + vx9 = LD_DP(x); x += inc_x2; + vx2r = (v2f64) __msa_pckev_d((v2i64) vx5, (v2i64) vx4); + dot1 += (vx0r * vy0i); + vy8 = LD_DP(y); y += inc_y2; + vx2i = (v2f64) __msa_pckod_d((v2i64) vx5, (v2i64) vx4); + dot2 OP1 (vx1i * vy1i); + vy9 = LD_DP(y); y += inc_y2; + vy2r = (v2f64) __msa_pckev_d((v2i64) vy5, (v2i64) vy4); + dot3 += (vx1r * vy1i); + vx10 = LD_DP(x); x += inc_x2; + vy2i = (v2f64) __msa_pckod_d((v2i64) vy5, (v2i64) vy4); + vx11 = LD_DP(x); x += inc_x2; + vx3r = (v2f64) __msa_pckev_d((v2i64) vx7, (v2i64) vx6); + dot4 += (vx2r * vy2r); + vy10 = LD_DP(y); y += inc_y2; + vx3i = (v2f64) __msa_pckod_d((v2i64) vx7, (v2i64) vx6); + dot5 OP2 (vx2i * vy2r); + vy11 = LD_DP(y); y += inc_y2; + vy3r = (v2f64) __msa_pckev_d((v2i64) vy7, (v2i64) vy6); + vy3i = (v2f64) __msa_pckod_d((v2i64) vy7, (v2i64) vy6); + dot6 += (vx3r * vy3r); + vx0r = (v2f64) __msa_pckev_d((v2i64) vx9, (v2i64) vx8); + dot7 OP2 (vx3i * vy3r); + vx0i = (v2f64) __msa_pckod_d((v2i64) vx9, (v2i64) vx8); + vy0r = (v2f64) __msa_pckev_d((v2i64) vy9, (v2i64) vy8); + vx2 = vx10; + vy0i = (v2f64) __msa_pckod_d((v2i64) vy9, (v2i64) vy8); + vx3 = vx11; + dot4 OP1 (vx2i * vy2i); + vy2 = vy10; + dot5 += (vx2r * vy2i); + vy3 = vy11; + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); + } + + vx4 = LD_DP(x); x += inc_x2; + vx1r = (v2f64) __msa_pckev_d((v2i64) vx3, (v2i64) vx2); + dot0 += (vx0r * vy0r); + vx5 = LD_DP(x); x += inc_x2; + vx1i = (v2f64) __msa_pckod_d((v2i64) vx3, (v2i64) vx2); + dot1 OP2 (vx0i * vy0r); + vy4 = LD_DP(y); y += inc_y2; + vy1r = (v2f64) __msa_pckev_d((v2i64) vy3, (v2i64) vy2); + dot2 += (vx1r * vy1r); + vy5 = LD_DP(y); y += inc_y2; + vy1i = (v2f64) __msa_pckod_d((v2i64) vy3, (v2i64) vy2); + dot3 OP2 (vx1i * vy1r); + vx6 = LD_DP(x); x += inc_x2; + vx7 = LD_DP(x); x += inc_x2; + vy6 = LD_DP(y); y += inc_y2; + vy7 = LD_DP(y); y += inc_y2; + dot0 OP1 (vx0i * vy0i); + vx2r = (v2f64) __msa_pckev_d((v2i64) vx5, (v2i64) vx4); + dot1 += (vx0r * vy0i); + vx2i = (v2f64) __msa_pckod_d((v2i64) vx5, (v2i64) vx4); + dot2 OP1 (vx1i * vy1i); + vy2r = (v2f64) __msa_pckev_d((v2i64) vy5, (v2i64) vy4); + dot3 += (vx1r * vy1i); + vy2i = (v2f64) __msa_pckod_d((v2i64) vy5, (v2i64) vy4); + vx3r = (v2f64) __msa_pckev_d((v2i64) vx7, (v2i64) vx6); + dot4 += (vx2r * vy2r); + vx3i = (v2f64) __msa_pckod_d((v2i64) vx7, (v2i64) vx6); + dot5 OP2 (vx2i * vy2r); + vy3r = (v2f64) __msa_pckev_d((v2i64) vy7, (v2i64) vy6); + vy3i = (v2f64) __msa_pckod_d((v2i64) vy7, (v2i64) vy6); + dot6 += (vx3r * vy3r); + dot7 OP2 (vx3i * vy3r); + dot4 OP1 (vx2i * vy2i); + dot5 += (vx2r * vy2i); + dot6 OP1 (vx3i * vy3i); + dot7 += (vx3r * vy3i); + } + + if (n & 7) + { + if (n & 4) + { + LD_DP4_INC(x, inc_x2, vx0, vx1, vx2, vx3); + LD_DP4_INC(y, inc_y2, vy0, vy1, vy2, vy3); + + PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); + PCKEVOD_D2_DP(vx3, vx2, vx1r, vx1i); + + PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); + PCKEVOD_D2_DP(vy3, vy2, vy1r, vy1i); + + dot0 += (vx0r * vy0r); + dot0 OP1 (vx0i * vy0i); + dot1 OP2 (vx0i * vy0r); + dot1 += (vx0r * vy0i); + + dot2 += (vx1r * vy1r); + dot2 OP1 (vx1i * vy1i); + dot3 OP2 (vx1i * vy1r); + dot3 += (vx1r * vy1i); + } + + if (n & 2) + { + LD_DP2_INC(x, inc_x2, vx0, vx1); + LD_DP2_INC(y, inc_y2, vy0, vy1); + PCKEVOD_D2_DP(vx1, vx0, vx0r, vx0i); + PCKEVOD_D2_DP(vy1, vy0, vy0r, vy0i); + + dot0 += (vx0r * vy0r); + dot0 OP1 (vx0i * vy0i); + dot1 OP2 (vx0i * vy0r); + dot1 += (vx0r * vy0i); + } + + if (n & 1) + { + vx0 = LD_DP(x); + vy0 = LD_DP(y); + PCKEVOD_D2_DP(zero, vx0, vx0r, vx0i); + PCKEVOD_D2_DP(zero, vy0, vy0r, vy0i); + + dot0 += (vx0r * vy0r); + dot0 OP1 (vx0i * vy0i); + dot1 OP2 (vx0i * vy0r); + dot1 += (vx0r * vy0i); + } + } + + dot0 += dot2 + dot4 + dot6; + dot1 += dot3 + dot5 + dot7; + + dot[0] += (dot0[0] + dot0[1]); + dot[1] += (dot1[0] + dot1[1]); + + CREAL(result) = dot[0]; + CIMAG(result) = dot[1]; + + return (result); } diff --git a/kernel/mips/zgemm_kernel_4x4_msa.c b/kernel/mips/zgemm_kernel_4x4_msa.c index a185c69dd2..96e56a3051 100644 --- a/kernel/mips/zgemm_kernel_4x4_msa.c +++ b/kernel/mips/zgemm_kernel_4x4_msa.c @@ -851,6 +851,18 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, temp = k; #endif +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 64(%[pb0]) \n\t" + "pref 0, 96(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) ZGEMM_KERNEL_4X4_MSA(, -, , +, +); #endif @@ -866,6 +878,18 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, for (l = (temp - 1); l--;) { +#ifdef ENABLE_PREFETCH + __asm__ __volatile__( + "pref 0, 64(%[pa0]) \n\t" + "pref 0, 96(%[pa0]) \n\t" + "pref 0, 64(%[pb0]) \n\t" + "pref 0, 96(%[pb0]) \n\t" + + : + : [pa0] "r" (pa0), [pb0] "r" (pb0) + ); +#endif + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) ZGEMM_KERNEL_4X4_MSA(+, -, +, +,); #endif @@ -1039,6 +1063,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else ZGEMM_SCALE_1X4_MSA #endif + pc0 += 2; + pc1 += 2; + pc2 += 2; + pc3 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1056,21 +1084,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; - pc2 += 2; - pc3 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 4; // number of values in A #endif - l = k << 3; - B = B + l; - i = ldc << 3; - C = C + i; + B += (k << 3); + C += (ldc << 3); } if (n & 2) @@ -1294,6 +1315,8 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else ZGEMM_SCALE_1X2_MSA #endif + pc0 += 2; + pc1 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1311,19 +1334,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; - pc1 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 2; // number of values in A #endif - l = k << 2; - B = B + l; - i = ldc << 2; - C = C + i; + B += (k << 2); + C += (ldc << 2); } if (n & 1) @@ -1555,6 +1573,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, #else ZGEMM_SCALE_1X1 #endif + pc0 += 2; #if defined(TRMMKERNEL) #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) @@ -1572,18 +1591,15 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG k, FLOAT alphar, FLOAT alphai, off += 1; // number of values in A #endif #endif - - pc0 += 2; } #if defined(TRMMKERNEL) && !defined(LEFT) off += 1; // number of values in A #endif - l = k << 1; - B = B + l; - i = ldc << 1; - C = C + i; + B += (k << 1); + C += (ldc << 1); } + return 0; } diff --git a/kernel/mips/zgemv_n_msa.c b/kernel/mips/zgemv_n_msa.c index aadc610aa5..669c25758e 100644 --- a/kernel/mips/zgemv_n_msa.c +++ b/kernel/mips/zgemv_n_msa.c @@ -312,14 +312,14 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. SPLATI_D2_DP(tp4i, tp0i, tp1i); \ #define ZLOAD_X4_SCALE_GP() \ - x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 0 * inc_x2))); \ - x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((long long *)(x + 1 * inc_x2))); \ - x1r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 2 * inc_x2))); \ - x1r = (v2f64) __msa_insert_d((v2i64) x1r, 1, *((long long *)(x + 3 * inc_x2))); \ - x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 0 * inc_x2 + 1))); \ - x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((long long *)(x + 1 * inc_x2 + 1))); \ - x1i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 2 * inc_x2 + 1))); \ - x1i = (v2f64) __msa_insert_d((v2i64) x1i, 1, *((long long *)(x + 3 * inc_x2 + 1))); \ + x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 0 * inc_x2))); \ + x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((BLASLONG *)(x + 1 * inc_x2))); \ + x1r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 2 * inc_x2))); \ + x1r = (v2f64) __msa_insert_d((v2i64) x1r, 1, *((BLASLONG *)(x + 3 * inc_x2))); \ + x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 0 * inc_x2 + 1))); \ + x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((BLASLONG *)(x + 1 * inc_x2 + 1))); \ + x1i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 2 * inc_x2 + 1))); \ + x1i = (v2f64) __msa_insert_d((v2i64) x1i, 1, *((BLASLONG *)(x + 3 * inc_x2 + 1))); \ \ tp4r = alphar * x0r; \ tp4r OP3 alphai * x0i; \ @@ -337,10 +337,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. SPLATI_D2_DP(tp5i, tp2i, tp3i); \ #define ZLOAD_X2_SCALE_GP() \ - x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 0 * inc_x2))); \ - x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((long long *)(x + 1 * inc_x2))); \ - x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(x + 0 * inc_x2 + 1))); \ - x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((long long *)(x + 1 * inc_x2 + 1))); \ + x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 0 * inc_x2))); \ + x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((BLASLONG *)(x + 1 * inc_x2))); \ + x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(x + 0 * inc_x2 + 1))); \ + x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((BLASLONG *)(x + 1 * inc_x2 + 1))); \ \ tp4r = alphar * x0r; \ tp4r OP3 alphai * x0i; \ @@ -377,182 +377,193 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ILVRL_D2_DP(y0i, y0r, y0, y1); \ ST_DP2(y0, y1, y, 2); \ -#define ZLOAD_Y4_GP() \ - y0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 0 * inc_y2))); \ - y0r = (v2f64) __msa_insert_d((v2i64) y0r, 1, *((long long *)(y + 1 * inc_y2))); \ - y1r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 2 * inc_y2))); \ - y1r = (v2f64) __msa_insert_d((v2i64) y1r, 1, *((long long *)(y + 3 * inc_y2))); \ - y0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 0 * inc_y2 + 1))); \ - y0i = (v2f64) __msa_insert_d((v2i64) y0i, 1, *((long long *)(y + 1 * inc_y2 + 1))); \ - y1i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 2 * inc_y2 + 1))); \ - y1i = (v2f64) __msa_insert_d((v2i64) y1i, 1, *((long long *)(y + 3 * inc_y2 + 1))); \ - -#define ZLOAD_Y2_GP() \ - y0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 0 * inc_y2))); \ - y0r = (v2f64) __msa_insert_d((v2i64) y0r, 1, *((long long *)(y + 1 * inc_y2))); \ - y0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *)(y + 0 * inc_y2 + 1))); \ - y0i = (v2f64) __msa_insert_d((v2i64) y0i, 1, *((long long *)(y + 1 * inc_y2 + 1))); \ - -#define ZSTORE_Y4_GP() \ - *((long long *)(y + 0 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 0); \ - *((long long *)(y + 1 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 1); \ - *((long long *)(y + 2 * inc_y2)) = __msa_copy_s_d((v2i64) y1r, 0); \ - *((long long *)(y + 3 * inc_y2)) = __msa_copy_s_d((v2i64) y1r, 1); \ - *((long long *)(y + 0 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 0); \ - *((long long *)(y + 1 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 1); \ - *((long long *)(y + 2 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y1i, 0); \ - *((long long *)(y + 3 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y1i, 1); \ - -#define ZSTORE_Y2_GP() \ - *((long long *)(y + 0 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 0); \ - *((long long *)(y + 1 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 1); \ - *((long long *)(y + 0 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 0); \ - *((long long *)(y + 1 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 1); \ - -#define ZGEMV_N_MSA() \ - for (j = (n >> 2); j--;) \ - { \ - ZLOAD_X4_SCALE() \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_Y4() \ - ZGEMV_N_4x4() \ - ZSTORE_Y4() \ - \ - k += 2 * 4; \ - y += inc_y2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_Y2() \ - ZGEMV_N_2x4() \ - ZSTORE_Y2() \ - \ - k += 2 * 2; \ - y += inc_y2 * 2; \ - } \ - \ - if (m & 1) \ - { \ - temp0_r = tp4r[0]; \ - temp1_r = tp4r[1]; \ - temp2_r = tp5r[0]; \ - temp3_r = tp5r[1]; \ - \ - temp0_i = tp4i[0]; \ - temp1_i = tp4i[1]; \ - temp2_i = tp5i[0]; \ - temp3_i = tp5i[1]; \ - \ - ZGEMV_N_1x4() \ - k += 2; \ - y += inc_y2; \ - } \ - \ - pa0 += 4 * lda2; \ - pa1 += 4 * lda2; \ - pa2 += 4 * lda2; \ - pa3 += 4 * lda2; \ - \ - x += 4 * inc_x2; \ - } \ - \ - if (n & 2) \ - { \ - ZLOAD_X2_SCALE() \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_Y4() \ - ZGEMV_N_4x2() \ - ZSTORE_Y4() \ - \ - k += 2 * 4; \ - y += inc_y2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_Y2() \ - ZGEMV_N_2x2() \ - ZSTORE_Y2() \ - \ - k += 2 * 2; \ - y += inc_y2 * 2; \ - } \ - \ - if (m & 1) \ - { \ - temp0_r = tp4r[0]; \ - temp1_r = tp4r[1]; \ - \ - temp0_i = tp4i[0]; \ - temp1_i = tp4i[1]; \ - \ - ZGEMV_N_1x2() \ - \ - k += 2; \ - y += inc_y2; \ - } \ - \ - pa0 += 2 * lda2; \ - pa1 += 2 * lda2; \ - \ - x += 2 * inc_x2; \ - } \ - \ - if (n & 1) \ - { \ - ZLOAD_X1_SCALE() \ - \ - k = 0; \ - y = y_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_Y4() \ - ZGEMV_N_4x1() \ - ZSTORE_Y4() \ - \ - k += 2 * 4; \ - y += inc_y2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_Y2() \ - ZGEMV_N_2x1() \ - ZSTORE_Y2() \ - \ - k += 2 * 2; \ - y += inc_y2 * 2; \ - } \ - \ - if (m & 1) \ - { \ - ZGEMV_N_1x1() \ - \ - k += 2; \ - y += inc_y2; \ - } \ - \ - pa0 += lda2; \ - x += inc_x2; \ - } \ +#define ZLOAD_Y4_GP() \ + y0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 0 * inc_y2))); \ + y0r = (v2f64) __msa_insert_d((v2i64) y0r, 1, *((BLASLONG *)(y + 1 * inc_y2))); \ + y1r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 2 * inc_y2))); \ + y1r = (v2f64) __msa_insert_d((v2i64) y1r, 1, *((BLASLONG *)(y + 3 * inc_y2))); \ + y0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 0 * inc_y2 + 1))); \ + y0i = (v2f64) __msa_insert_d((v2i64) y0i, 1, *((BLASLONG *)(y + 1 * inc_y2 + 1))); \ + y1i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 2 * inc_y2 + 1))); \ + y1i = (v2f64) __msa_insert_d((v2i64) y1i, 1, *((BLASLONG *)(y + 3 * inc_y2 + 1))); \ + +#define ZLOAD_Y2_GP() \ + y0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 0 * inc_y2))); \ + y0r = (v2f64) __msa_insert_d((v2i64) y0r, 1, *((BLASLONG *)(y + 1 * inc_y2))); \ + y0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((BLASLONG *)(y + 0 * inc_y2 + 1))); \ + y0i = (v2f64) __msa_insert_d((v2i64) y0i, 1, *((BLASLONG *)(y + 1 * inc_y2 + 1))); \ + +#define ZSTORE_Y4_GP() \ + *((BLASLONG *)(y + 0 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 0); \ + *((BLASLONG *)(y + 1 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 1); \ + *((BLASLONG *)(y + 2 * inc_y2)) = __msa_copy_s_d((v2i64) y1r, 0); \ + *((BLASLONG *)(y + 3 * inc_y2)) = __msa_copy_s_d((v2i64) y1r, 1); \ + *((BLASLONG *)(y + 0 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 0); \ + *((BLASLONG *)(y + 1 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 1); \ + *((BLASLONG *)(y + 2 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y1i, 0); \ + *((BLASLONG *)(y + 3 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y1i, 1); \ + +#define ZSTORE_Y2_GP() \ + *((BLASLONG *)(y + 0 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 0); \ + *((BLASLONG *)(y + 1 * inc_y2)) = __msa_copy_s_d((v2i64) y0r, 1); \ + *((BLASLONG *)(y + 0 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 0); \ + *((BLASLONG *)(y + 1 * inc_y2 + 1)) = __msa_copy_s_d((v2i64) y0i, 1); \ + +#define ZGEMV_N_MSA() \ + for (j = (n >> 2); j--;) \ + { \ + ZLOAD_X4_SCALE() \ + \ + k = 0; \ + k_pref = pref_offset; \ + y = y_org; \ + \ + for (i = (m >> 2); i--;) \ + { \ + PREFETCH(pa0 + k_pref + 8 + 0); \ + PREFETCH(pa0 + k_pref + 8 + 4); \ + PREFETCH(pa1 + k_pref + 8 + 0); \ + PREFETCH(pa1 + k_pref + 8 + 4); \ + PREFETCH(pa2 + k_pref + 8 + 0); \ + PREFETCH(pa2 + k_pref + 8 + 4); \ + PREFETCH(pa3 + k_pref + 8 + 0); \ + PREFETCH(pa3 + k_pref + 8 + 4); \ + \ + ZLOAD_Y4() \ + ZGEMV_N_4x4() \ + ZSTORE_Y4() \ + \ + k += 2 * 4; \ + k_pref += 2 * 4; \ + y += inc_y2 * 4; \ + } \ + \ + if (m & 2) \ + { \ + ZLOAD_Y2() \ + ZGEMV_N_2x4() \ + ZSTORE_Y2() \ + \ + k += 2 * 2; \ + y += inc_y2 * 2; \ + } \ + \ + if (m & 1) \ + { \ + temp0_r = tp4r[0]; \ + temp1_r = tp4r[1]; \ + temp2_r = tp5r[0]; \ + temp3_r = tp5r[1]; \ + \ + temp0_i = tp4i[0]; \ + temp1_i = tp4i[1]; \ + temp2_i = tp5i[0]; \ + temp3_i = tp5i[1]; \ + \ + ZGEMV_N_1x4() \ + k += 2; \ + y += inc_y2; \ + } \ + \ + pa0 += 4 * lda2; \ + pa1 += 4 * lda2; \ + pa2 += 4 * lda2; \ + pa3 += 4 * lda2; \ + \ + x += 4 * inc_x2; \ + } \ + \ + if (n & 2) \ + { \ + ZLOAD_X2_SCALE() \ + \ + k = 0; \ + y = y_org; \ + \ + for (i = (m >> 2); i--;) \ + { \ + ZLOAD_Y4() \ + ZGEMV_N_4x2() \ + ZSTORE_Y4() \ + \ + k += 2 * 4; \ + y += inc_y2 * 4; \ + } \ + \ + if (m & 2) \ + { \ + ZLOAD_Y2() \ + ZGEMV_N_2x2() \ + ZSTORE_Y2() \ + \ + k += 2 * 2; \ + y += inc_y2 * 2; \ + } \ + \ + if (m & 1) \ + { \ + temp0_r = tp4r[0]; \ + temp1_r = tp4r[1]; \ + \ + temp0_i = tp4i[0]; \ + temp1_i = tp4i[1]; \ + \ + ZGEMV_N_1x2() \ + \ + k += 2; \ + y += inc_y2; \ + } \ + \ + pa0 += 2 * lda2; \ + pa1 += 2 * lda2; \ + \ + x += 2 * inc_x2; \ + } \ + \ + if (n & 1) \ + { \ + ZLOAD_X1_SCALE() \ + \ + k = 0; \ + y = y_org; \ + \ + for (i = (m >> 2); i--;) \ + { \ + ZLOAD_Y4() \ + ZGEMV_N_4x1() \ + ZSTORE_Y4() \ + \ + k += 2 * 4; \ + y += inc_y2 * 4; \ + } \ + \ + if (m & 2) \ + { \ + ZLOAD_Y2() \ + ZGEMV_N_2x1() \ + ZSTORE_Y2() \ + \ + k += 2 * 2; \ + y += inc_y2 * 2; \ + } \ + \ + if (m & 1) \ + { \ + ZGEMV_N_1x1() \ + \ + k += 2; \ + y += inc_y2; \ + } \ + \ + pa0 += lda2; \ + x += inc_x2; \ + } \ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha_r, FLOAT alpha_i, FLOAT *A, BLASLONG lda2, FLOAT *x, BLASLONG inc_x2, FLOAT *y, BLASLONG inc_y2, FLOAT *buffer) { - BLASLONG i, j, k; + BLASLONG i, j, k, k_pref, pref_offset; FLOAT *y_org = y; FLOAT *pa0, *pa1, *pa2, *pa3; FLOAT temp0_r, temp1_r, temp2_r, temp3_r, temp0_i, temp1_i, temp2_i; @@ -569,6 +580,10 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha_r, FLOAT alpha_i, inc_x2 = 2 * inc_x2; inc_y2 = 2 * inc_y2; + pref_offset = (uintptr_t)A & (L1_DATA_LINESIZE - 1); + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + pa0 = A; pa1 = A + lda2; pa2 = A + 2 * lda2; diff --git a/kernel/mips/zgemv_t_msa.c b/kernel/mips/zgemv_t_msa.c index b2147b0451..e6febb5775 100644 --- a/kernel/mips/zgemv_t_msa.c +++ b/kernel/mips/zgemv_t_msa.c @@ -44,64 +44,9 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define OP2 -= #endif -#define ZGEMV_T_4x4() \ - LD_DP4(pa0 + k, 2, t0, t1, t2, t3); \ - LD_DP4(pa1 + k, 2, t4, t5, t6, t7); \ - LD_DP4(pa2 + k, 2, t8, t9, t10, t11); \ - LD_DP4(pa3 + k, 2, t12, t13, t14, t15); \ - \ - PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ - PCKEVOD_D2_DP(t3, t2, src1r, src1i); \ - PCKEVOD_D2_DP(t5, t4, src2r, src2i); \ - PCKEVOD_D2_DP(t7, t6, src3r, src3i); \ - PCKEVOD_D2_DP(t9, t8, src4r, src4i); \ - PCKEVOD_D2_DP(t11, t10, src5r, src5i); \ - PCKEVOD_D2_DP(t13, t12, src6r, src6i); \ - PCKEVOD_D2_DP(t15, t14, src7r, src7i); \ - \ - tp0r += src0r * x0r; \ - tp0r += src1r * x1r; \ - tp0r OP0 src0i * x0i; \ - tp0r OP0 src1i * x1i; \ - \ - tp1r += src2r * x0r; \ - tp1r += src3r * x1r; \ - tp1r OP0 src2i * x0i; \ - tp1r OP0 src3i * x1i; \ - \ - tp2r += src4r * x0r; \ - tp2r += src5r * x1r; \ - tp2r OP0 src4i * x0i; \ - tp2r OP0 src5i * x1i; \ - \ - tp3r += src6r * x0r; \ - tp3r += src7r * x1r; \ - tp3r OP0 src6i * x0i; \ - tp3r OP0 src7i * x1i; \ - \ - tp0i OP1 src0r * x0i; \ - tp0i OP1 src1r * x1i; \ - tp0i OP2 src0i * x0r; \ - tp0i OP2 src1i * x1r; \ - \ - tp1i OP1 src2r * x0i; \ - tp1i OP1 src3r * x1i; \ - tp1i OP2 src2i * x0r; \ - tp1i OP2 src3i * x1r; \ - \ - tp2i OP1 src4r * x0i; \ - tp2i OP1 src5r * x1i; \ - tp2i OP2 src4i * x0r; \ - tp2i OP2 src5i * x1r; \ - \ - tp3i OP1 src6r * x0i; \ - tp3i OP1 src7r * x1i; \ - tp3i OP2 src6i * x0r; \ - tp3i OP2 src7i * x1r; \ - -#define ZGEMV_T_4x2() \ - LD_DP4(pa0 + k, 2, t0, t1, t2, t3); \ - LD_DP4(pa1 + k, 2, t4, t5, t6, t7); \ +#define ZGEMV_T_8x1() \ + LD_DP4(pa0, 2, t0, t1, t2, t3); \ + LD_DP4(pa0 + 8, 2, t4, t5, t6, t7); \ \ PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ PCKEVOD_D2_DP(t3, t2, src1r, src1i); \ @@ -109,27 +54,27 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PCKEVOD_D2_DP(t7, t6, src3r, src3i); \ \ tp0r += src0r * x0r; \ - tp0r += src1r * x1r; \ + tp0i OP1 src0r * x0i; \ tp0r OP0 src0i * x0i; \ - tp0r OP0 src1i * x1i; \ + tp0i OP2 src0i * x0r; \ \ - tp1r += src2r * x0r; \ - tp1r += src3r * x1r; \ - tp1r OP0 src2i * x0i; \ - tp1r OP0 src3i * x1i; \ + tp0r += src2r * x2r; \ + tp0i OP1 src2r * x2i; \ + tp0r OP0 src2i * x2i; \ + tp0i OP2 src2i * x2r; \ \ - tp0i OP1 src0r * x0i; \ + tp0r += src1r * x1r; \ tp0i OP1 src1r * x1i; \ - tp0i OP2 src0i * x0r; \ + tp0r OP0 src1i * x1i; \ tp0i OP2 src1i * x1r; \ \ - tp1i OP1 src2r * x0i; \ - tp1i OP1 src3r * x1i; \ - tp1i OP2 src2i * x0r; \ - tp1i OP2 src3i * x1r; \ + tp0r += src3r * x3r; \ + tp0i OP1 src3r * x3i; \ + tp0r OP0 src3i * x3i; \ + tp0i OP2 src3i * x3r; \ #define ZGEMV_T_4x1() \ - LD_DP4(pa0 + k, 2, t0, t1, t2, t3); \ + LD_DP4(pa0, 2, t0, t1, t2, t3); \ \ PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ PCKEVOD_D2_DP(t3, t2, src1r, src1i); \ @@ -144,62 +89,8 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tp0i OP2 src0i * x0r; \ tp0i OP2 src1i * x1r; \ -#define ZGEMV_T_2x4() \ - LD_DP2(pa0 + k, 2, t0, t1); \ - LD_DP2(pa1 + k, 2, t4, t5); \ - LD_DP2(pa2 + k, 2, t8, t9); \ - LD_DP2(pa3 + k, 2, t12, t13); \ - \ - PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ - PCKEVOD_D2_DP(t5, t4, src2r, src2i); \ - PCKEVOD_D2_DP(t9, t8, src4r, src4i); \ - PCKEVOD_D2_DP(t13, t12, src6r, src6i); \ - \ - tp0r += src0r * x0r; \ - tp0r OP0 src0i * x0i; \ - \ - tp1r += src2r * x0r; \ - tp1r OP0 src2i * x0i; \ - \ - tp2r += src4r * x0r; \ - tp2r OP0 src4i * x0i; \ - \ - tp3r += src6r * x0r; \ - tp3r OP0 src6i * x0i; \ - \ - tp0i OP1 src0r * x0i; \ - tp0i OP2 src0i * x0r; \ - \ - tp1i OP1 src2r * x0i; \ - tp1i OP2 src2i * x0r; \ - \ - tp2i OP1 src4r * x0i; \ - tp2i OP2 src4i * x0r; \ - \ - tp3i OP1 src6r * x0i; \ - tp3i OP2 src6i * x0r; \ - -#define ZGEMV_T_2x2() \ - LD_DP2(pa0 + k, 2, t0, t1); \ - LD_DP2(pa1 + k, 2, t4, t5); \ - \ - PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ - PCKEVOD_D2_DP(t5, t4, src2r, src2i); \ - \ - tp0r += src0r * x0r; \ - tp0r OP0 src0i * x0i; \ - \ - tp1r += src2r * x0r; \ - tp1r OP0 src2i * x0i; \ - \ - tp0i OP1 src0r * x0i; \ - tp0i OP2 src0i * x0r; \ - \ - tp1i OP1 src2r * x0i; \ - tp1i OP2 src2i * x0r; \ - #define ZGEMV_T_2x1() \ - LD_DP2(pa0 + k, 2, t0, t1); \ + LD_DP2(pa0, 2, t0, t1); \ \ PCKEVOD_D2_DP(t1, t0, src0r, src0i); \ \ @@ -209,104 +100,12 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tp0i OP1 src0r * x0i; \ tp0i OP2 src0i * x0r; \ -#define ZGEMV_T_1x4() \ - temp0r += pa0[k + 0] * x[0 * inc_x2]; \ - temp0r OP0 pa0[k + 1] * x[0 * inc_x2 + 1]; \ - temp1r += pa1[k + 0] * x[0 * inc_x2]; \ - temp1r OP0 pa1[k + 1] * x[0 * inc_x2 + 1]; \ - temp2r += pa2[k + 0] * x[0 * inc_x2]; \ - temp2r OP0 pa2[k + 1] * x[0 * inc_x2 + 1]; \ - temp3r += pa3[k + 0] * x[0 * inc_x2]; \ - temp3r OP0 pa3[k + 1] * x[0 * inc_x2 + 1]; \ - \ - temp0i OP1 pa0[k + 0] * x[0 * inc_x2 + 1]; \ - temp0i OP2 pa0[k + 1] * x[0 * inc_x2]; \ - temp1i OP1 pa1[k + 0] * x[0 * inc_x2 + 1]; \ - temp1i OP2 pa1[k + 1] * x[0 * inc_x2]; \ - temp2i OP1 pa2[k + 0] * x[0 * inc_x2 + 1]; \ - temp2i OP2 pa2[k + 1] * x[0 * inc_x2]; \ - temp3i OP1 pa3[k + 0] * x[0 * inc_x2 + 1]; \ - temp3i OP2 pa3[k + 1] * x[0 * inc_x2]; \ - -#define ZGEMV_T_1x2() \ - temp0r += pa0[k + 0] * x[0 * inc_x2]; \ - temp0r OP0 pa0[k + 1] * x[0 * inc_x2 + 1]; \ - temp1r += pa1[k + 0] * x[0 * inc_x2]; \ - temp1r OP0 pa1[k + 1] * x[0 * inc_x2 + 1]; \ - \ - temp0i OP1 pa0[k + 0] * x[0 * inc_x2 + 1]; \ - temp0i OP2 pa0[k + 1] * x[0 * inc_x2]; \ - temp1i OP1 pa1[k + 0] * x[0 * inc_x2 + 1]; \ - temp1i OP2 pa1[k + 1] * x[0 * inc_x2]; \ - -#define ZGEMV_T_1x1() \ - temp0r += pa0[k + 0] * x[0 * inc_x2]; \ - temp0r OP0 pa0[k + 1] * x[0 * inc_x2 + 1]; \ - \ - temp0i OP1 pa0[k + 0] * x[0 * inc_x2 + 1]; \ - temp0i OP2 pa0[k + 1] * x[0 * inc_x2]; \ - -#define ZSCALE_STORE_Y4_GP() \ - res0r = y[0 * inc_y2]; \ - res1r = y[1 * inc_y2]; \ - res2r = y[2 * inc_y2]; \ - res3r = y[3 * inc_y2]; \ - \ - res0i = y[0 * inc_y2 + 1]; \ - res1i = y[1 * inc_y2 + 1]; \ - res2i = y[2 * inc_y2 + 1]; \ - res3i = y[3 * inc_y2 + 1]; \ - \ - res0r += alphar * temp0r; \ - res0r OP0 alphai * temp0i; \ - res1r += alphar * temp1r; \ - res1r OP0 alphai * temp1i; \ - res2r += alphar * temp2r; \ - res2r OP0 alphai * temp2i; \ - res3r += alphar * temp3r; \ - res3r OP0 alphai * temp3i; \ - \ - res0i OP1 alphar * temp0i; \ - res0i OP2 alphai * temp0r; \ - res1i OP1 alphar * temp1i; \ - res1i OP2 alphai * temp1r; \ - res2i OP1 alphar * temp2i; \ - res2i OP2 alphai * temp2r; \ - res3i OP1 alphar * temp3i; \ - res3i OP2 alphai * temp3r; \ - \ - y[0 * inc_y2] = res0r; \ - y[1 * inc_y2] = res1r; \ - y[2 * inc_y2] = res2r; \ - y[3 * inc_y2] = res3r; \ - \ - y[0 * inc_y2 + 1] = res0i; \ - y[1 * inc_y2 + 1] = res1i; \ - y[2 * inc_y2 + 1] = res2i; \ - y[3 * inc_y2 + 1] = res3i; \ - -#define ZSCALE_STORE_Y2_GP() \ - res0r = y[0 * inc_y2]; \ - res1r = y[1 * inc_y2]; \ - \ - res0i = y[0 * inc_y2 + 1]; \ - res1i = y[1 * inc_y2 + 1]; \ - \ - res0r += alphar * temp0r; \ - res0r OP0 alphai * temp0i; \ - res1r += alphar * temp1r; \ - res1r OP0 alphai * temp1i; \ - \ - res0i OP1 alphar * temp0i; \ - res0i OP2 alphai * temp0r; \ - res1i OP1 alphar * temp1i; \ - res1i OP2 alphai * temp1r; \ - \ - y[0 * inc_y2] = res0r; \ - y[1 * inc_y2] = res1r; \ - \ - y[0 * inc_y2 + 1] = res0i; \ - y[1 * inc_y2 + 1] = res1i; \ +#define ZGEMV_T_1x1() \ + temp0r += pa0[0] * x[0 * inc_x2]; \ + temp0r OP0 pa0[1] * x[0 * inc_x2 + 1]; \ + \ + temp0i OP1 pa0[0] * x[0 * inc_x2 + 1]; \ + temp0i OP2 pa0[1] * x[0 * inc_x2]; \ #define ZSCALE_STORE_Y1_GP() \ res0r = y[0 * inc_y2]; \ @@ -321,6 +120,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. y[0 * inc_y2] = res0r; \ y[0 * inc_y2 + 1] = res0i; \ +#define ZLOAD_X8_VECTOR() \ + LD_DP4(x, 2, x0, x1, x2, x3); \ + LD_DP4(x + 8, 2, x4, x5, x6, x7); \ + \ + PCKEVOD_D2_DP(x1, x0, x0r, x0i); \ + PCKEVOD_D2_DP(x3, x2, x1r, x1i); \ + PCKEVOD_D2_DP(x5, x4, x2r, x2i); \ + PCKEVOD_D2_DP(x7, x6, x3r, x3i); \ + #define ZLOAD_X4_VECTOR() \ LD_DP4(x, 2, x0, x1, x2, x3); \ PCKEVOD_D2_DP(x1, x0, x0r, x0i); \ @@ -330,6 +138,24 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. LD_DP2(x, 2, x0, x1); \ PCKEVOD_D2_DP(x1, x0, x0r, x0i); \ +#define ZLOAD_X8_GP() \ + x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 0 * inc_x2))); \ + x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((long long *) (x + 1 * inc_x2))); \ + x1r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 2 * inc_x2))); \ + x1r = (v2f64) __msa_insert_d((v2i64) x1r, 1, *((long long *) (x + 3 * inc_x2))); \ + x2r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 4 * inc_x2))); \ + x2r = (v2f64) __msa_insert_d((v2i64) x2r, 1, *((long long *) (x + 5 * inc_x2))); \ + x3r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 6 * inc_x2))); \ + x3r = (v2f64) __msa_insert_d((v2i64) x3r, 1, *((long long *) (x + 7 * inc_x2))); \ + x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 0 * inc_x2 + 1))); \ + x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((long long *) (x + 1 * inc_x2 + 1))); \ + x1i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 2 * inc_x2 + 1))); \ + x1i = (v2f64) __msa_insert_d((v2i64) x1i, 1, *((long long *) (x + 3 * inc_x2 + 1))); \ + x2i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 4 * inc_x2 + 1))); \ + x2i = (v2f64) __msa_insert_d((v2i64) x2i, 1, *((long long *) (x + 5 * inc_x2 + 1))); \ + x3i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 6 * inc_x2 + 1))); \ + x3i = (v2f64) __msa_insert_d((v2i64) x3i, 1, *((long long *) (x + 7 * inc_x2 + 1))); \ + #define ZLOAD_X4_GP() \ x0r = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 0 * inc_x2))); \ x0r = (v2f64) __msa_insert_d((v2i64) x0r, 1, *((long long *) (x + 1 * inc_x2))); \ @@ -346,196 +172,405 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. x0i = (v2f64) __msa_insert_d((v2i64) tp0r, 0, *((long long *) (x + 0 * inc_x2 + 1))); \ x0i = (v2f64) __msa_insert_d((v2i64) x0i, 1, *((long long *) (x + 1 * inc_x2 + 1))); \ -#define ZGEMV_T_MSA() \ - for (j = (n >> 2); j--;) \ - { \ - tp0r = tp1r = tp2r = tp3r = zero; \ - tp0i = tp1i = tp2i = tp3i = zero; \ - \ - k = 0; \ - x = srcx_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_X4(); \ - ZGEMV_T_4x4(); \ - \ - k += 2 * 4; \ - x += inc_x2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_X2(); \ - ZGEMV_T_2x4(); \ - \ - k += 2 * 2; \ - x += inc_x2 * 2; \ - } \ - \ - temp0r = tp0r[0] + tp0r[1]; \ - temp1r = tp1r[0] + tp1r[1]; \ - temp2r = tp2r[0] + tp2r[1]; \ - temp3r = tp3r[0] + tp3r[1]; \ - temp0i = tp0i[0] + tp0i[1]; \ - temp1i = tp1i[0] + tp1i[1]; \ - temp2i = tp2i[0] + tp2i[1]; \ - temp3i = tp3i[0] + tp3i[1]; \ - \ - if (m & 1) \ - { \ - ZGEMV_T_1x4(); \ - \ - k += 2; \ - x += inc_x2; \ - } \ - \ - ZSCALE_STORE_Y4_GP(); \ - \ - pa0 += 4 * lda2; \ - pa1 += 4 * lda2; \ - pa2 += 4 * lda2; \ - pa3 += 4 * lda2; \ - y += 4 * inc_y2; \ - } \ - \ - if (n & 2) \ - { \ - tp0r = tp1r = zero; \ - tp0i = tp1i = zero; \ - \ - k = 0; \ - x = srcx_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_X4(); \ - ZGEMV_T_4x2(); \ - \ - k += 2 * 4; \ - x += inc_x2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_X2(); \ - ZGEMV_T_2x2(); \ - \ - k += 2 * 2; \ - x += inc_x2 * 2; \ - } \ - \ - temp0r = tp0r[0] + tp0r[1]; \ - temp1r = tp1r[0] + tp1r[1]; \ - temp0i = tp0i[0] + tp0i[1]; \ - temp1i = tp1i[0] + tp1i[1]; \ - \ - if (m & 1) \ - { \ - ZGEMV_T_1x2(); \ - \ - k += 2; \ - x += inc_x2; \ - } \ - \ - ZSCALE_STORE_Y2_GP(); \ - \ - pa0 += 2 * lda2; \ - pa1 += 2 * lda2; \ - y += 2 * inc_y2; \ - } \ - \ - if (n & 1) \ - { \ - tp0r = zero; \ - tp0i = zero; \ - \ - k = 0; \ - x = srcx_org; \ - \ - for (i = (m >> 2); i--;) \ - { \ - ZLOAD_X4(); \ - ZGEMV_T_4x1(); \ - \ - k += 2 * 4; \ - x += inc_x2 * 4; \ - } \ - \ - if (m & 2) \ - { \ - ZLOAD_X2(); \ - ZGEMV_T_2x1(); \ - \ - k += 2 * 2; \ - x += inc_x2 * 2; \ - } \ - \ - temp0r = tp0r[0] + tp0r[1]; \ - temp0i = tp0i[0] + tp0i[1]; \ - \ - if (m & 1) \ - { \ - ZGEMV_T_1x1(); \ - \ - k += 2; \ - x += inc_x2; \ - } \ - \ - ZSCALE_STORE_Y1_GP(); \ - \ - pa0 += lda2; \ - y += inc_y2; \ - } \ +#define ZGEMV_T_MSA() \ + for (j = n; j--;) \ + { \ + tp0r = zero; \ + tp0i = zero; \ + tp1r = zero; \ + tp1i = zero; \ + tp2r = zero; \ + tp2i = zero; \ + tp3r = zero; \ + tp3i = zero; \ + \ + pa0 = A; \ + x = srcx_org; \ + \ + if (m >> 4) \ + { \ + x0 = LD_DP(x); \ + x1 = LD_DP(x + 1 * inc_x2); \ + t0 = LD_DP(pa0); \ + t1 = LD_DP(pa0 + 2); \ + \ + x4 = LD_DP(x + 4 * inc_x2); \ + x5 = LD_DP(x + 5 * inc_x2); \ + t4 = LD_DP(pa0 + 8); \ + t5 = LD_DP(pa0 + 10); \ + \ + for (i = (m >> 4) - 1; i--;) \ + { \ + pa0_pref = pa0 + pref_offset; \ + \ + PREFETCH(pa0_pref + 36); \ + PREFETCH(pa0_pref + 44); \ + PREFETCH(pa0_pref + 48); \ + PREFETCH(pa0_pref + 52); \ + PREFETCH(pa0_pref + 56); \ + PREFETCH(pa0_pref + 60); \ + PREFETCH(pa0_pref + 64); \ + PREFETCH(pa0_pref + 72); \ + \ + x0r = (v2f64) __msa_pckev_d((v2i64) x1, (v2i64) x0); \ + x0i = (v2f64) __msa_pckod_d((v2i64) x1, (v2i64) x0); \ + src0r = (v2f64) __msa_pckev_d((v2i64) t1, (v2i64) t0); \ + src0i = (v2f64) __msa_pckod_d((v2i64) t1, (v2i64) t0); \ + \ + tp0r += src0r * x0r; \ + x2 = LD_DP(x + 2 * inc_x2); \ + x2r = (v2f64) __msa_pckev_d((v2i64) x5, (v2i64) x4); \ + \ + tp0i OP1 src0r * x0i; \ + x3 = LD_DP(x + 3 * inc_x2); \ + x2i = (v2f64) __msa_pckod_d((v2i64) x5, (v2i64) x4); \ + \ + tp1r OP0 src0i * x0i; \ + t2 = LD_DP(pa0 + 4); \ + src2r = (v2f64) __msa_pckev_d((v2i64) t5, (v2i64) t4); \ + \ + tp1i OP2 src0i * x0r; \ + t3 = LD_DP(pa0 + 6); \ + src2i = (v2f64) __msa_pckod_d((v2i64) t5, (v2i64) t4); \ + \ + tp2r += src2r * x2r; \ + x6 = LD_DP(x + 6 * inc_x2); \ + \ + tp2i OP1 src2r * x2i; \ + x7 = LD_DP(x + 7 * inc_x2); \ + \ + tp3r OP0 src2i * x2i; \ + t6 = LD_DP(pa0 + 12); \ + \ + tp3i OP2 src2i * x2r; \ + t7 = LD_DP(pa0 + 14); \ + \ + x1r = (v2f64) __msa_pckev_d((v2i64) x3, (v2i64) x2); \ + x1i = (v2f64) __msa_pckod_d((v2i64) x3, (v2i64) x2); \ + src1r = (v2f64) __msa_pckev_d((v2i64) t3, (v2i64) t2); \ + src1i = (v2f64) __msa_pckod_d((v2i64) t3, (v2i64) t2); \ + \ + tp0r += src1r * x1r; \ + x0 = LD_DP(x + 8 * inc_x2); \ + x3r = (v2f64) __msa_pckev_d((v2i64) x7, (v2i64) x6); \ + \ + tp0i OP1 src1r * x1i; \ + x1 = LD_DP(x + 9 * inc_x2); \ + x3i = (v2f64) __msa_pckod_d((v2i64) x7, (v2i64) x6); \ + \ + tp1r OP0 src1i * x1i; \ + t0 = LD_DP(pa0 + 16); \ + src3r = (v2f64) __msa_pckev_d((v2i64) t7, (v2i64) t6); \ + \ + tp1i OP2 src1i * x1r; \ + t1 = LD_DP(pa0 + 18); \ + src3i = (v2f64) __msa_pckod_d((v2i64) t7, (v2i64) t6); \ + \ + tp2r += src3r * x3r; \ + x4 = LD_DP(x + 12 * inc_x2); \ + \ + tp2i OP1 src3r * x3i; \ + x5 = LD_DP(x + 13 * inc_x2); \ + \ + tp3r OP0 src3i * x3i; \ + t4 = LD_DP(pa0 + 24); \ + \ + tp3i OP2 src3i * x3r; \ + t5 = LD_DP(pa0 + 26); \ + \ + x0r = (v2f64) __msa_pckev_d((v2i64) x1, (v2i64) x0); \ + x0i = (v2f64) __msa_pckod_d((v2i64) x1, (v2i64) x0); \ + src0r = (v2f64) __msa_pckev_d((v2i64) t1, (v2i64) t0); \ + src0i = (v2f64) __msa_pckod_d((v2i64) t1, (v2i64) t0); \ + \ + tp0r += src0r * x0r; \ + x2 = LD_DP(x + 10 * inc_x2); \ + x2r = (v2f64) __msa_pckev_d((v2i64) x5, (v2i64) x4); \ + \ + tp0i OP1 src0r * x0i; \ + x3 = LD_DP(x + 11 * inc_x2); \ + x2i = (v2f64) __msa_pckod_d((v2i64) x5, (v2i64) x4); \ + \ + tp1r OP0 src0i * x0i; \ + t2 = LD_DP(pa0 + 20); \ + src2r = (v2f64) __msa_pckev_d((v2i64) t5, (v2i64) t4); \ + \ + tp1i OP2 src0i * x0r; \ + t3 = LD_DP(pa0 + 22); \ + src2i = (v2f64) __msa_pckod_d((v2i64) t5, (v2i64) t4); \ + \ + tp2r += src2r * x2r; \ + x6 = LD_DP(x + 14 * inc_x2); \ + \ + tp2i OP1 src2r * x2i; \ + x7 = LD_DP(x + 15 * inc_x2); \ + \ + tp3r OP0 src2i * x2i; \ + t6 = LD_DP(pa0 + 28); \ + \ + tp3i OP2 src2i * x2r; \ + t7 = LD_DP(pa0 + 30); \ + \ + x1r = (v2f64) __msa_pckev_d((v2i64) x3, (v2i64) x2); \ + x1i = (v2f64) __msa_pckod_d((v2i64) x3, (v2i64) x2); \ + src1r = (v2f64) __msa_pckev_d((v2i64) t3, (v2i64) t2); \ + src1i = (v2f64) __msa_pckod_d((v2i64) t3, (v2i64) t2); \ + \ + tp0r += src1r * x1r; \ + x0 = LD_DP(x + inc_x2 * 16); \ + x3r = (v2f64) __msa_pckev_d((v2i64) x7, (v2i64) x6); \ + \ + tp0i OP1 src1r * x1i; \ + x1 = LD_DP(x + inc_x2 * 16 + 1 * inc_x2); \ + x3i = (v2f64) __msa_pckod_d((v2i64) x7, (v2i64) x6); \ + \ + tp1r OP0 src1i * x1i; \ + t0 = LD_DP(pa0 + 2 * 16); \ + src3r = (v2f64) __msa_pckev_d((v2i64) t7, (v2i64) t6); \ + \ + tp1i OP2 src1i * x1r; \ + t1 = LD_DP(pa0 + 2 * 16 + 2); \ + src3i = (v2f64) __msa_pckod_d((v2i64) t7, (v2i64) t6); \ + \ + tp2r += src3r * x3r; \ + x4 = LD_DP(x + inc_x2 * 16 + 4 * inc_x2); \ + \ + tp2i OP1 src3r * x3i; \ + x5 = LD_DP(x + inc_x2 * 16 + 5 * inc_x2); \ + \ + tp3r OP0 src3i * x3i; \ + t4 = LD_DP(pa0 + 2 * 16 + 8); \ + \ + tp3i OP2 src3i * x3r; \ + t5 = LD_DP(pa0 + 2 * 16 + 10); \ + \ + pa0 += 2 * 16; \ + x += inc_x2 * 16; \ + } \ + \ + x0r = (v2f64) __msa_pckev_d((v2i64) x1, (v2i64) x0); \ + x0i = (v2f64) __msa_pckod_d((v2i64) x1, (v2i64) x0); \ + src0r = (v2f64) __msa_pckev_d((v2i64) t1, (v2i64) t0); \ + src0i = (v2f64) __msa_pckod_d((v2i64) t1, (v2i64) t0); \ + \ + tp0r += src0r * x0r; \ + x2 = LD_DP(x + 2 * inc_x2); \ + x2r = (v2f64) __msa_pckev_d((v2i64) x5, (v2i64) x4); \ + \ + tp0i OP1 src0r * x0i; \ + x3 = LD_DP(x + 3 * inc_x2); \ + x2i = (v2f64) __msa_pckod_d((v2i64) x5, (v2i64) x4); \ + \ + tp1r OP0 src0i * x0i; \ + t2 = LD_DP(pa0 + 4); \ + src2r = (v2f64) __msa_pckev_d((v2i64) t5, (v2i64) t4); \ + \ + tp1i OP2 src0i * x0r; \ + t3 = LD_DP(pa0 + 6); \ + src2i = (v2f64) __msa_pckod_d((v2i64) t5, (v2i64) t4); \ + \ + tp2r += src2r * x2r; \ + x6 = LD_DP(x + 6 * inc_x2); \ + \ + tp2i OP1 src2r * x2i; \ + x7 = LD_DP(x + 7 * inc_x2); \ + \ + tp3r OP0 src2i * x2i; \ + t6 = LD_DP(pa0 + 12); \ + \ + tp3i OP2 src2i * x2r; \ + t7 = LD_DP(pa0 + 14); \ + \ + x1r = (v2f64) __msa_pckev_d((v2i64) x3, (v2i64) x2); \ + x1i = (v2f64) __msa_pckod_d((v2i64) x3, (v2i64) x2); \ + src1r = (v2f64) __msa_pckev_d((v2i64) t3, (v2i64) t2); \ + src1i = (v2f64) __msa_pckod_d((v2i64) t3, (v2i64) t2); \ + \ + tp0r += src1r * x1r; \ + x0 = LD_DP(x + 8 * inc_x2); \ + x3r = (v2f64) __msa_pckev_d((v2i64) x7, (v2i64) x6); \ + \ + tp0i OP1 src1r * x1i; \ + x1 = LD_DP(x + 9 * inc_x2); \ + x3i = (v2f64) __msa_pckod_d((v2i64) x7, (v2i64) x6); \ + \ + tp1r OP0 src1i * x1i; \ + t0 = LD_DP(pa0 + 16); \ + src3r = (v2f64) __msa_pckev_d((v2i64) t7, (v2i64) t6); \ + \ + tp1i OP2 src1i * x1r; \ + t1 = LD_DP(pa0 + 18); \ + src3i = (v2f64) __msa_pckod_d((v2i64) t7, (v2i64) t6); \ + \ + tp2r += src3r * x3r; \ + x4 = LD_DP(x + 12 * inc_x2); \ + \ + tp2i OP1 src3r * x3i; \ + x5 = LD_DP(x + 13 * inc_x2); \ + \ + tp3r OP0 src3i * x3i; \ + t4 = LD_DP(pa0 + 24); \ + \ + tp3i OP2 src3i * x3r; \ + t5 = LD_DP(pa0 + 26); \ + \ + x0r = (v2f64) __msa_pckev_d((v2i64) x1, (v2i64) x0); \ + x0i = (v2f64) __msa_pckod_d((v2i64) x1, (v2i64) x0); \ + src0r = (v2f64) __msa_pckev_d((v2i64) t1, (v2i64) t0); \ + src0i = (v2f64) __msa_pckod_d((v2i64) t1, (v2i64) t0); \ + \ + tp0r += src0r * x0r; \ + x2 = LD_DP(x + 10 * inc_x2); \ + x2r = (v2f64) __msa_pckev_d((v2i64) x5, (v2i64) x4); \ + \ + tp0i OP1 src0r * x0i; \ + x3 = LD_DP(x + 11 * inc_x2); \ + x2i = (v2f64) __msa_pckod_d((v2i64) x5, (v2i64) x4); \ + \ + tp1r OP0 src0i * x0i; \ + t2 = LD_DP(pa0 + 20); \ + src2r = (v2f64) __msa_pckev_d((v2i64) t5, (v2i64) t4); \ + \ + tp1i OP2 src0i * x0r; \ + t3 = LD_DP(pa0 + 22); \ + src2i = (v2f64) __msa_pckod_d((v2i64) t5, (v2i64) t4); \ + \ + tp2r += src2r * x2r; \ + x6 = LD_DP(x + 14 * inc_x2); \ + \ + tp2i OP1 src2r * x2i; \ + x7 = LD_DP(x + 15 * inc_x2); \ + \ + tp3r OP0 src2i * x2i; \ + t6 = LD_DP(pa0 + 28); \ + \ + tp3i OP2 src2i * x2r; \ + t7 = LD_DP(pa0 + 30); \ + \ + x1r = (v2f64) __msa_pckev_d((v2i64) x3, (v2i64) x2); \ + x1i = (v2f64) __msa_pckod_d((v2i64) x3, (v2i64) x2); \ + src1r = (v2f64) __msa_pckev_d((v2i64) t3, (v2i64) t2); \ + src1i = (v2f64) __msa_pckod_d((v2i64) t3, (v2i64) t2); \ + \ + tp0r += src1r * x1r; \ + x3r = (v2f64) __msa_pckev_d((v2i64) x7, (v2i64) x6); \ + \ + tp0i OP1 src1r * x1i; \ + x3i = (v2f64) __msa_pckod_d((v2i64) x7, (v2i64) x6); \ + \ + tp1r OP0 src1i * x1i; \ + src3r = (v2f64) __msa_pckev_d((v2i64) t7, (v2i64) t6); \ + \ + tp1i OP2 src1i * x1r; \ + src3i = (v2f64) __msa_pckod_d((v2i64) t7, (v2i64) t6); \ + \ + tp2r += src3r * x3r; \ + tp2i OP1 src3r * x3i; \ + tp3r OP0 src3i * x3i; \ + tp3i OP2 src3i * x3r; \ + \ + pa0 += 2 * 16; \ + x += inc_x2 * 16; \ + \ + tp0r += tp1r + tp2r + tp3r; \ + tp0i += tp1i + tp2i + tp3i; \ + } \ + \ + if (m & 8) \ + { \ + ZLOAD_X8(); \ + ZGEMV_T_8x1(); \ + \ + pa0 += 2 * 8; \ + x += inc_x2 * 8; \ + } \ + \ + if (m & 4) \ + { \ + ZLOAD_X4(); \ + ZGEMV_T_4x1(); \ + \ + pa0 += 2 * 4; \ + x += inc_x2 * 4; \ + } \ + \ + if (m & 2) \ + { \ + ZLOAD_X2(); \ + ZGEMV_T_2x1(); \ + \ + pa0 += 2 * 2; \ + x += inc_x2 * 2; \ + } \ + \ + temp0r = tp0r[0] + tp0r[1]; \ + temp0i = tp0i[0] + tp0i[1]; \ + \ + if (m & 1) \ + { \ + ZGEMV_T_1x1(); \ + \ + pa0 += 2; \ + x += inc_x2; \ + } \ + \ + ZSCALE_STORE_Y1_GP(); \ + \ + A += lda2; \ + y += inc_y2; \ + } \ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alphar, FLOAT alphai, FLOAT *A, BLASLONG lda, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *buffer) { - BLASLONG i, j, k; + BLASLONG i, j, pref_offset; BLASLONG inc_x2, inc_y2, lda2; - FLOAT *pa0, *pa1, *pa2, *pa3; + FLOAT *pa0, *pa0_pref; FLOAT *srcx_org = x; - FLOAT temp0r, temp0i, temp2r, temp2i, temp1r, temp1i, temp3r, temp3i; - FLOAT res0r, res0i, res2r, res2i, res1r, res1i, res3r, res3i; + FLOAT temp0r, temp0i; + FLOAT res0r, res0i; v2f64 zero = {0}; v2f64 x0, x1, x2, x3, x0r, x1r, x0i, x1i; - v2f64 t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14, t15; - v2f64 src0r, src1r, src2r, src3r, src4r, src5r, src6r, src7r; - v2f64 src0i, src1i, src2i, src3i, src4i, src5i, src6i, src7i; + v2f64 x4, x5, x6, x7, x2r, x3r, x2i, x3i; + v2f64 t0, t1, t2, t3, t4, t5, t6, t7; + v2f64 src0r, src1r, src2r, src3r; + v2f64 src0i, src1i, src2i, src3i; v2f64 tp0r, tp1r, tp2r, tp3r, tp0i, tp1i, tp2i, tp3i; lda2 = 2 * lda; - pa0 = A; - pa1 = A + lda2; - pa2 = A + 2 * lda2; - pa3 = A + 3 * lda2; - inc_x2 = 2 * inc_x; inc_y2 = 2 * inc_y; + pref_offset = (uintptr_t)A & L1_DATA_LINESIZE; + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + if (2 == inc_x2) { + #define ZLOAD_X8 ZLOAD_X8_VECTOR #define ZLOAD_X4 ZLOAD_X4_VECTOR #define ZLOAD_X2 ZLOAD_X2_VECTOR ZGEMV_T_MSA(); + #undef ZLOAD_X8 #undef ZLOAD_X4 #undef ZLOAD_X2 } else { + #define ZLOAD_X8 ZLOAD_X8_GP #define ZLOAD_X4 ZLOAD_X4_GP #define ZLOAD_X2 ZLOAD_X2_GP ZGEMV_T_MSA(); + #undef ZLOAD_X8 #undef ZLOAD_X4 #undef ZLOAD_X2 } - return(0); } diff --git a/kernel/mips/zrot_msa.c b/kernel/mips/zrot_msa.c new file mode 100644 index 0000000000..c71b157fbe --- /dev/null +++ b/kernel/mips/zrot_msa.c @@ -0,0 +1,738 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +#define PROCESS_ZROT(inc_x2, inc_y2) \ + if ((0 == c) && (0 == s)) \ + { \ + v2f64 zero = {0, 0}; \ + zero = (v2f64) __msa_insert_d((v2i64) zero, 0, 0.0); \ + zero = (v2f64) __msa_insert_d((v2i64) zero, 1, 0.0); \ + \ + /* process 4 floats */ \ + for (j = (n >> 1); j--;) \ + { \ + ST_DP2_INC(zero, zero, px, inc_x2); \ + ST_DP2_INC(zero, zero, py, inc_y2); \ + } \ + \ + if (n & 1) \ + { \ + ST_DP(zero, px); \ + ST_DP(zero, py); \ + } \ + } \ + else if ((1 == c) && (1 == s)) \ + { \ + /* process 8 elements */ \ + if (n >> 3) \ + { \ + BLASLONG pref_offsetx, pref_offsety; \ + \ + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); \ + if (pref_offsetx > 0) \ + { \ + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; \ + pref_offsetx = pref_offsetx / sizeof(FLOAT); \ + } \ + \ + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); \ + if (pref_offsety > 0) \ + { \ + pref_offsety = L1_DATA_LINESIZE - pref_offsety; \ + pref_offsety = pref_offsety / sizeof(FLOAT); \ + } \ + \ + x0 = LD_DP(px); px += inc_x2; \ + x1 = LD_DP(px); px += inc_x2; \ + x2 = LD_DP(px); px += inc_x2; \ + x3 = LD_DP(px); px += inc_x2; \ + y0 = LD_DP(py); py += inc_y2; \ + y1 = LD_DP(py); py += inc_y2; \ + y2 = LD_DP(py); py += inc_y2; \ + y3 = LD_DP(py); py += inc_y2; \ + \ + for (j = (n >> 3) - 1; j--;) \ + { \ + PREFETCH(px + pref_offsetx + 16); \ + PREFETCH(px + pref_offsetx + 20); \ + PREFETCH(px + pref_offsetx + 24); \ + PREFETCH(px + pref_offsetx + 28); \ + PREFETCH(py + pref_offsety + 16); \ + PREFETCH(py + pref_offsety + 20); \ + PREFETCH(py + pref_offsety + 24); \ + PREFETCH(py + pref_offsety + 28); \ + \ + out0 = x0 + y0; \ + x4 = LD_DP(px); px += inc_x2; \ + out1 = y0 - x0; \ + x5 = LD_DP(px); px += inc_x2; \ + out2 = x1 + y1; \ + x6 = LD_DP(px); px += inc_x2; \ + out3 = y1 - x1; \ + x7 = LD_DP(px); px += inc_x2; \ + out4 = x2 + y2; \ + y4 = LD_DP(py); py += inc_y2; \ + out5 = y2 - x2; \ + y5 = LD_DP(py); py += inc_y2; \ + out6 = x3 + y3; \ + y6 = LD_DP(py); py += inc_y2; \ + out7 = y3 - x3; \ + y7 = LD_DP(py); py += inc_y2; \ + \ + ST_DP(out0, x); x += inc_x2; \ + out8 = x4 + y4; \ + ST_DP(out1, y); y += inc_y2; \ + out9 = y4 - x4; \ + ST_DP(out2, x); x += inc_x2; \ + out10 = x5 + y5; \ + ST_DP(out3, y); y += inc_y2; \ + out11 = y5 - x5; \ + ST_DP(out4, x); x += inc_x2; \ + out12 = x6 + y6; \ + ST_DP(out5, y); y += inc_y2; \ + out13 = y6 - x6; \ + ST_DP(out6, x); x += inc_x2; \ + out14 = x7 + y7; \ + ST_DP(out7, y); y += inc_y2; \ + out15 = y7 - x7; \ + \ + x0 = LD_DP(px); px += inc_x2; \ + ST_DP(out8, x); x += inc_x2; \ + x1 = LD_DP(px); px += inc_x2; \ + ST_DP(out10, x); x += inc_x2; \ + x2 = LD_DP(px); px += inc_x2; \ + ST_DP(out12, x); x += inc_x2; \ + x3 = LD_DP(px); px += inc_x2; \ + ST_DP(out14, x); x += inc_x2; \ + \ + y0 = LD_DP(py); py += inc_y2; \ + ST_DP(out9, y); y += inc_y2; \ + y1 = LD_DP(py); py += inc_y2; \ + ST_DP(out11, y); y += inc_y2; \ + y2 = LD_DP(py); py += inc_y2; \ + ST_DP(out13, y); y += inc_y2; \ + y3 = LD_DP(py); py += inc_y2; \ + ST_DP(out15, y); y += inc_y2; \ + } \ + \ + x4 = LD_DP(px); px += inc_x2; \ + x5 = LD_DP(px); px += inc_x2; \ + x6 = LD_DP(px); px += inc_x2; \ + x7 = LD_DP(px); px += inc_x2; \ + y4 = LD_DP(py); py += inc_y2; \ + y5 = LD_DP(py); py += inc_y2; \ + y6 = LD_DP(py); py += inc_y2; \ + y7 = LD_DP(py); py += inc_y2; \ + \ + out0 = x0 + y0; \ + out1 = y0 - x0; \ + out2 = x1 + y1; \ + out3 = y1 - x1; \ + out4 = x2 + y2; \ + out5 = y2 - x2; \ + out6 = x3 + y3; \ + out7 = y3 - x3; \ + out8 = x4 + y4; \ + out9 = y4 - x4; \ + out10 = x5 + y5; \ + out11 = y5 - x5; \ + out12 = x6 + y6; \ + out13 = y6 - x6; \ + out14 = x7 + y7; \ + out15 = y7 - x7; \ + \ + ST_DP8_INC(out0, out2, out4, out6, out8, out10, out12, out14, x, inc_x2); \ + ST_DP8_INC(out1, out3, out5, out7, out9, out11, out13, out15, y, inc_y2); \ + } \ + if (n & 4) \ + { \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + out0 = x0 + y0; \ + out1 = y0 - x0; \ + out2 = x1 + y1; \ + out3 = y1 - x1; \ + out4 = x2 + y2; \ + out5 = y2 - x2; \ + out6 = x3 + y3; \ + out7 = y3 - x3; \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + if (n & 2) \ + { \ + LD_DP2_INC(px, inc_x2, x0, x1); \ + LD_DP2_INC(py, inc_y2, y0, y1); \ + \ + out0 = x0 + y0; \ + out1 = y0 - x0; \ + out2 = x1 + y1; \ + out3 = y1 - x1; \ + \ + ST_DP2_INC(out0, out2, x, inc_x2); \ + ST_DP2_INC(out1, out3, y, inc_y2); \ + } \ + if (n & 1) \ + { \ + x0 = LD_DP(px); \ + y0 = LD_DP(py); \ + \ + out0 = x0 + y0; \ + out1 = y0 - x0; \ + \ + ST_DP(out0, px); \ + ST_DP(out1, py); \ + } \ + } \ + else if (0 == s) \ + { \ + c0 = COPY_DOUBLE_TO_VECTOR(c); \ + \ + if (n >> 3) \ + { \ + BLASLONG pref_offsetx, pref_offsety; \ + \ + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); \ + if (pref_offsetx > 0) \ + { \ + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; \ + pref_offsetx = pref_offsetx / sizeof(FLOAT); \ + } \ + \ + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); \ + if (pref_offsety > 0) \ + { \ + pref_offsety = L1_DATA_LINESIZE - pref_offsety; \ + pref_offsety = pref_offsety / sizeof(FLOAT); \ + } \ + \ + LD_DP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); \ + \ + for (j = (n >> 3) - 1; j--;) \ + { \ + PREFETCH(px + pref_offsetx + 16); \ + PREFETCH(px + pref_offsetx + 20); \ + PREFETCH(px + pref_offsetx + 24); \ + PREFETCH(px + pref_offsetx + 28); \ + PREFETCH(py + pref_offsety + 16); \ + PREFETCH(py + pref_offsety + 20); \ + PREFETCH(py + pref_offsety + 24); \ + PREFETCH(py + pref_offsety + 28); \ + \ + y0 = LD_DP(py); py += inc_y2; \ + x0 *= c0; \ + y1 = LD_DP(py); py += inc_y2; \ + x1 *= c0; \ + y2 = LD_DP(py); py += inc_y2; \ + x2 *= c0; \ + y3 = LD_DP(py); py += inc_y2; \ + x3 *= c0; \ + y4 = LD_DP(py); py += inc_y2; \ + x4 *= c0; \ + y5 = LD_DP(py); py += inc_y2; \ + x5 *= c0; \ + y6 = LD_DP(py); py += inc_y2; \ + x6 *= c0; \ + y7 = LD_DP(py); py += inc_y2; \ + x7 *= c0; \ + \ + ST_DP(x0, x); x += inc_x2; \ + y0 *= c0; \ + ST_DP(x1, x); x += inc_x2; \ + y1 *= c0; \ + ST_DP(x2, x); x += inc_x2; \ + y2 *= c0; \ + ST_DP(x3, x); x += inc_x2; \ + y3 *= c0; \ + ST_DP(x4, x); x += inc_x2; \ + y4 *= c0; \ + ST_DP(x5, x); x += inc_x2; \ + y5 *= c0; \ + ST_DP(x6, x); x += inc_x2; \ + y6 *= c0; \ + ST_DP(x7, x); x += inc_x2; \ + y7 *= c0; \ + \ + x0 = LD_DP(px); px += inc_x2; \ + ST_DP(y0, y); y += inc_y2; \ + x1 = LD_DP(px); px += inc_x2; \ + ST_DP(y1, y); y += inc_y2; \ + x2 = LD_DP(px); px += inc_x2; \ + ST_DP(y2, y); y += inc_y2; \ + x3 = LD_DP(px); px += inc_x2; \ + ST_DP(y3, y); y += inc_y2; \ + x4 = LD_DP(px); px += inc_x2; \ + ST_DP(y4, y); y += inc_y2; \ + x5 = LD_DP(px); px += inc_x2; \ + ST_DP(y5, y); y += inc_y2; \ + x6 = LD_DP(px); px += inc_x2; \ + ST_DP(y6, y); y += inc_y2; \ + x7 = LD_DP(px); px += inc_x2; \ + ST_DP(y7, y); y += inc_y2; \ + } \ + \ + LD_DP8_INC(py, inc_y2, y0, y1, y2, y3, y4, y5, y6, y7); \ + \ + x0 *= c0; \ + y0 *= c0; \ + x1 *= c0; \ + y1 *= c0; \ + x2 *= c0; \ + y2 *= c0; \ + x3 *= c0; \ + y3 *= c0; \ + x4 *= c0; \ + y4 *= c0; \ + x5 *= c0; \ + y5 *= c0; \ + x6 *= c0; \ + y6 *= c0; \ + x7 *= c0; \ + y7 *= c0; \ + \ + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, inc_x2); \ + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, y, inc_y2); \ + } \ + \ + if (n & 4) \ + { \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + out0 = c0 * x0; \ + out1 = c0 * y0; \ + out2 = c0 * x1; \ + out3 = c0 * y1; \ + out4 = c0 * x2; \ + out5 = c0 * y2; \ + out6 = c0 * x3; \ + out7 = c0 * y3; \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + if (n & 2) \ + { \ + LD_DP2_INC(px, inc_x2, x0, x1); \ + LD_DP2_INC(py, inc_y2, y0, y1); \ + \ + out0 = c0 * x0; \ + out1 = c0 * y0; \ + out2 = c0 * x1; \ + out3 = c0 * y1; \ + \ + ST_DP2_INC(out0, out2, x, inc_x2); \ + ST_DP2_INC(out1, out3, y, inc_y2); \ + } \ + if (n & 1) \ + { \ + x0 = LD_DP(px); \ + y0 = LD_DP(py); \ + \ + out0 = c0 * x0; \ + out1 = c0 * y0; \ + \ + ST_DP(out0, px); \ + ST_DP(out1, py); \ + } \ + } \ + else if (0 == c) \ + { \ + s0 = COPY_DOUBLE_TO_VECTOR(s); \ + \ + /* process 16 floats */ \ + if (n >> 3) \ + { \ + BLASLONG pref_offsetx, pref_offsety; \ + \ + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); \ + if (pref_offsetx > 0) \ + { \ + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; \ + pref_offsetx = pref_offsetx / sizeof(FLOAT); \ + } \ + \ + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); \ + if (pref_offsety > 0) \ + { \ + pref_offsety = L1_DATA_LINESIZE - pref_offsety; \ + pref_offsety = pref_offsety / sizeof(FLOAT); \ + } \ + \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + for (j = (n >> 3) - 1; j--;) \ + { \ + PREFETCH(px + pref_offsetx + 16); \ + PREFETCH(px + pref_offsetx + 20); \ + PREFETCH(px + pref_offsetx + 24); \ + PREFETCH(px + pref_offsetx + 28); \ + PREFETCH(py + pref_offsety + 16); \ + PREFETCH(py + pref_offsety + 20); \ + PREFETCH(py + pref_offsety + 24); \ + PREFETCH(py + pref_offsety + 28); \ + \ + x4 = LD_DP(px); px += inc_x2; \ + out0 = s0 * y0; \ + x5 = LD_DP(px); px += inc_x2; \ + out2 = s0 * y1; \ + x6 = LD_DP(px); px += inc_x2; \ + out4 = s0 * y2; \ + x7 = LD_DP(px); px += inc_x2; \ + out6 = s0 * y3; \ + y4 = LD_DP(py); py += inc_y2; \ + out1 = -(s0 * x0); \ + y5 = LD_DP(py); py += inc_y2; \ + out3 = -(s0 * x1); \ + y6 = LD_DP(py); py += inc_y2; \ + out5 = -(s0 * x2); \ + y7 = LD_DP(py); py += inc_y2; \ + out7 = -(s0 * x3); \ + \ + ST_DP(out0, x); x += inc_y2; \ + out0 = s0 * y4; \ + ST_DP(out2, x); x += inc_y2; \ + out2 = s0 * y5; \ + ST_DP(out4, x); x += inc_y2; \ + out4 = s0 * y6; \ + ST_DP(out6, x); x += inc_y2; \ + out6 = s0 * y7; \ + ST_DP(out1, y); y += inc_y2; \ + out1 = -(s0 * x4); \ + ST_DP(out3, y); y += inc_y2; \ + out3 = -(s0 * x5); \ + ST_DP(out5, y); y += inc_y2; \ + out5 = -(s0 * x6); \ + ST_DP(out7, y); y += inc_y2; \ + out7 = -(s0 * x7); \ + \ + x0 = LD_DP(px); px += inc_x2; \ + ST_DP(out0, x); x += inc_y2; \ + x1 = LD_DP(px); px += inc_x2; \ + ST_DP(out2, x); x += inc_y2; \ + x2 = LD_DP(px); px += inc_x2; \ + ST_DP(out4, x); x += inc_y2; \ + x3 = LD_DP(px); px += inc_x2; \ + ST_DP(out6, x); x += inc_y2; \ + y0 = LD_DP(py); py += inc_y2; \ + ST_DP(out1, y); y += inc_y2; \ + y1 = LD_DP(py); py += inc_y2; \ + ST_DP(out3, y); y += inc_y2; \ + y2 = LD_DP(py); py += inc_y2; \ + ST_DP(out5, y); y += inc_y2; \ + y3 = LD_DP(py); py += inc_y2; \ + ST_DP(out7, y); y += inc_y2; \ + } \ + \ + out0 = s0 * y0; \ + out2 = s0 * y1; \ + out4 = s0 * y2; \ + out6 = s0 * y3; \ + out1 = -(s0 * x0); \ + out3 = -(s0 * x1); \ + out5 = -(s0 * x2); \ + out7 = -(s0 * x3); \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + \ + LD_DP4_INC(px, inc_x2, x4, x5, x6, x7); \ + LD_DP4_INC(py, inc_y2, y4, y5, y6, y7); \ + \ + out0 = s0 * y4; \ + out2 = s0 * y5; \ + out4 = s0 * y6; \ + out6 = s0 * y7; \ + out1 = -(s0 * x4); \ + out3 = -(s0 * x5); \ + out5 = -(s0 * x6); \ + out7 = -(s0 * x7); \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + if (n & 4) \ + { \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + out0 = s0 * y0; \ + out1 = - (s0 * x0); \ + out2 = s0 * y1; \ + out3 = - (s0 * x1); \ + out4 = s0 * y2; \ + out5 = - (s0 * x2); \ + out6 = s0 * y3; \ + out7 = - (s0 * x3); \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + if (n & 2) \ + { \ + LD_DP2_INC(px, inc_x2, x0, x1); \ + LD_DP2_INC(py, inc_y2, y0, y1); \ + \ + out0 = s0 * y0; \ + out1 = - (s0 * x0); \ + out2 = s0 * y1; \ + out3 = - (s0 * x1); \ + \ + ST_DP2_INC(out0, out2, x, inc_x2); \ + ST_DP2_INC(out1, out3, y, inc_y2); \ + } \ + if (n & 1) \ + { \ + x0 = LD_DP(px); px += inc_x2; \ + y0 = LD_DP(py); py += inc_y2; \ + \ + out0 = s0 * y0; \ + out1 = - (s0 * x0); \ + \ + ST_DP(out0, x); x += inc_x2; \ + ST_DP(out1, y); y += inc_y2; \ + } \ + } \ + else \ + { \ + c0 = COPY_DOUBLE_TO_VECTOR(c); \ + s0 = COPY_DOUBLE_TO_VECTOR(s); \ + \ + if (n >> 3) \ + { \ + BLASLONG pref_offsetx, pref_offsety; \ + \ + pref_offsetx = (BLASLONG)px & (L1_DATA_LINESIZE - 1); \ + if (pref_offsetx > 0) \ + { \ + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; \ + pref_offsetx = pref_offsetx / sizeof(FLOAT); \ + } \ + \ + pref_offsety = (BLASLONG)py & (L1_DATA_LINESIZE - 1); \ + if (pref_offsety > 0) \ + { \ + pref_offsety = L1_DATA_LINESIZE - pref_offsety; \ + pref_offsety = pref_offsety / sizeof(FLOAT); \ + } \ + \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + for (j = (n >> 3) - 1; j--;) \ + { \ + PREFETCH(px + pref_offsetx + 16); \ + PREFETCH(px + pref_offsetx + 20); \ + PREFETCH(px + pref_offsetx + 24); \ + PREFETCH(px + pref_offsetx + 28); \ + PREFETCH(py + pref_offsety + 16); \ + PREFETCH(py + pref_offsety + 20); \ + PREFETCH(py + pref_offsety + 24); \ + PREFETCH(py + pref_offsety + 28); \ + \ + x4 = LD_DP(px); px += inc_x2; \ + out0 = c0 * x0; \ + x5 = LD_DP(px); px += inc_x2; \ + out2 = c0 * x1; \ + x6 = LD_DP(px); px += inc_x2; \ + out4 = c0 * x2; \ + x7 = LD_DP(px); px += inc_x2; \ + out6 = c0 * x3; \ + y4 = LD_DP(py); py += inc_y2; \ + out1 = c0 * y0; \ + y5 = LD_DP(py); py += inc_y2; \ + out3 = c0 * y1; \ + y6 = LD_DP(py); py += inc_y2; \ + out5 = c0 * y2; \ + y7 = LD_DP(py); py += inc_y2; \ + out7 = c0 * y3; \ + \ + out0 += s0 * y0; \ + out2 += s0 * y1; \ + out4 += s0 * y2; \ + out6 += s0 * y3; \ + out1 -= s0 * x0; \ + out3 -= s0 * x1; \ + out5 -= s0 * x2; \ + out7 -= s0 * x3; \ + \ + ST_DP(out0, x); x += inc_x2; \ + out0 = c0 * x4; \ + ST_DP(out2, x); x += inc_x2; \ + out2 = c0 * x5; \ + ST_DP(out4, x); x += inc_x2; \ + out4 = c0 * x6; \ + ST_DP(out6, x); x += inc_x2; \ + out6 = c0 * x7; \ + ST_DP(out1, y); y += inc_y2; \ + out1 = c0 * y4; \ + ST_DP(out3, y); y += inc_y2; \ + out3 = c0 * y5; \ + ST_DP(out5, y); y += inc_y2; \ + out5 = c0 * y6; \ + ST_DP(out7, y); y += inc_y2; \ + out7 = c0 * y7; \ + \ + x0 = LD_DP(px); px += inc_x2; \ + out0 += s0 * y4; \ + x1 = LD_DP(px); px += inc_x2; \ + out2 += s0 * y5; \ + x2 = LD_DP(px); px += inc_x2; \ + out4 += s0 * y6; \ + x3 = LD_DP(px); px += inc_x2; \ + out6 += s0 * y7; \ + y0 = LD_DP(py); py += inc_y2; \ + out1 -= s0 * x4; \ + y1 = LD_DP(py); py += inc_y2; \ + out3 -= s0 * x5; \ + y2 = LD_DP(py); py += inc_y2; \ + out5 -= s0 * x6; \ + y3 = LD_DP(py); py += inc_y2; \ + out7 -= s0 * x7; \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + \ + out0 = c0 * x0; \ + out0 += s0 * y0; \ + out1 = c0 * y0; \ + out1 -= s0 * x0; \ + out2 = c0 * x1; \ + out2 += s0 * y1; \ + out3 = c0 * y1; \ + out3 -= s0 * x1; \ + out4 = c0 * x2; \ + out4 += s0 * y2; \ + out5 = c0 * y2; \ + out5 -= s0 * x2; \ + out6 = c0 * x3; \ + out6 += s0 * y3; \ + out7 = c0 * y3; \ + out7 -= s0 * x3; \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + \ + LD_DP4_INC(px, inc_x2, x4, x5, x6, x7); \ + LD_DP4_INC(py, inc_y2, y4, y5, y6, y7); \ + \ + out8 = c0 * x4; \ + out8 += s0 * y4; \ + out9 = c0 * y4; \ + out9 -= s0 * x4; \ + out10 = c0 * x5; \ + out10 += s0 * y5; \ + out11 = c0 * y5; \ + out11 -= s0 * x5; \ + out12 = c0 * x6; \ + out12 += s0 * y6; \ + out13 = c0 * y6; \ + out13 -= s0 * x6; \ + out14 = c0 * x7; \ + out14 += s0 * y7; \ + out15 = c0 * y7; \ + out15 -= s0 * x7; \ + \ + ST_DP4_INC(out8, out10, out12, out14, x, inc_x2); \ + ST_DP4_INC(out9, out11, out13, out15, y, inc_y2); \ + } \ + if (n & 4) \ + { \ + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); \ + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); \ + \ + out0 = (c0 * x0) + (s0 * y0); \ + out1 = (c0 * y0) - (s0 * x0); \ + out2 = (c0 * x1) + (s0 * y1); \ + out3 = (c0 * y1) - (s0 * x1); \ + out4 = (c0 * x2) + (s0 * y2); \ + out5 = (c0 * y2) - (s0 * x2); \ + out6 = (c0 * x3) + (s0 * y3); \ + out7 = (c0 * y3) - (s0 * x3); \ + \ + ST_DP4_INC(out0, out2, out4, out6, x, inc_x2); \ + ST_DP4_INC(out1, out3, out5, out7, y, inc_y2); \ + } \ + if (n & 2) \ + { \ + LD_DP2_INC(px, inc_x2, x0, x1); \ + LD_DP2_INC(py, inc_y2, y0, y1); \ + \ + out0 = (c0 * x0) + (s0 * y0); \ + out1 = (c0 * y0) - (s0 * x0); \ + out2 = (c0 * x1) + (s0 * y1); \ + out3 = (c0 * y1) - (s0 * x1); \ + \ + ST_DP2_INC(out0, out2, x, inc_x2); \ + ST_DP2_INC(out1, out3, y, inc_y2); \ + } \ + if (n & 1) \ + { \ + x0 = LD_DP(px); \ + y0 = LD_DP(py); \ + \ + out0 = (c0 * x0) + (s0 * y0); \ + out1 = (c0 * y0) - (s0 * x0); \ + \ + ST_DP(out0, px); \ + ST_DP(out1, py); \ + } \ + } + +int CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, + FLOAT c, FLOAT s) +{ + BLASLONG j; + FLOAT *px, *py; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, y0, y1, y2, y3, y4, y5, y6, y7; + v2f64 out0, out1, out2, out3, out4, out5, out6, out7, c0, s0; + v2f64 out8, out9, out10, out11, out12, out13, out14, out15; + + px = x; + py = y; + + if ((1 == inc_x) && (1 == inc_y)) + { + PROCESS_ZROT(2, 2); + } + else + { + inc_x *= 2; + inc_y *= 2; + + PROCESS_ZROT(inc_x, inc_y); + } + + return 0; +} diff --git a/kernel/mips/zscal_msa.c b/kernel/mips/zscal_msa.c new file mode 100644 index 0000000000..5a8766d3c5 --- /dev/null +++ b/kernel/mips/zscal_msa.c @@ -0,0 +1,717 @@ +/******************************************************************************* +Copyright (c) 2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +/* This will shuffle the elements in 'in' vector as (mask needed :: 01 00 11 10) + 0 1 2 3 => 2 3 0 1 */ +#define SHF_78 78 + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, + FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y, FLOAT *dummy, + BLASLONG dummy2) +{ + BLASLONG i, inc_x2; + FLOAT *px; + FLOAT tp0, tp1, f0, f1; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + v2f64 d0, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15; + v2f64 da_i_vec, da_i_vec_neg, da_r_vec; + + px = x; + + if (1 == inc_x) + { + if ((0.0 == da_r) && (0.0 == da_i)) + { + v2f64 zero_v = __msa_cast_to_vector_double(0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 0, 0.0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 1, 0.0); + + for (i = (n >> 4); i--;) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + } + + if (n & 15) + { + if (n & 8) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, 2); + } + + if (n & 4) + { + ST_DP4_INC(zero_v, zero_v, zero_v, zero_v, x, 2); + } + + if (n & 2) + { + ST_DP2_INC(zero_v, zero_v, x, 2); + } + + if (n & 1) + { + ST_DP(zero_v, x); + } + } + } + else if (0.0 == da_r) + { + da_i_vec = COPY_DOUBLE_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v2f64) __msa_ilvev_d((v2i64) da_i_vec_neg, (v2i64) da_i_vec); + + if (n > 15) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32 + 16; + + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 4)- 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + x8 = LD_DP(px); px += 2; + x0 *= da_i_vec; + x9 = LD_DP(px); px += 2; + x1 *= da_i_vec; + x10 = LD_DP(px); px += 2; + x2 *= da_i_vec; + x11 = LD_DP(px); px += 2; + x3 *= da_i_vec; + x12 = LD_DP(px); px += 2; + x4 *= da_i_vec; + x13 = LD_DP(px); px += 2; + x5 *= da_i_vec; + x0 = (v2f64) __msa_shf_w((v4i32) x0, SHF_78); + x14 = LD_DP(px); px += 2; + x6 *= da_i_vec; + x1 = (v2f64) __msa_shf_w((v4i32) x1, SHF_78); + x15 = LD_DP(px); px += 2; + x7 *= da_i_vec; + x2 = (v2f64) __msa_shf_w((v4i32) x2, SHF_78); + x8 *= da_i_vec; + x3 = (v2f64) __msa_shf_w((v4i32) x3, SHF_78); + ST_DP(x0, x); x += 2; + x9 *= da_i_vec; + x4 = (v2f64) __msa_shf_w((v4i32) x4, SHF_78); + ST_DP(x1, x); x += 2; + x10 *= da_i_vec; + x5 = (v2f64) __msa_shf_w((v4i32) x5, SHF_78); + ST_DP(x2, x); x += 2; + x11 *= da_i_vec; + x6 = (v2f64) __msa_shf_w((v4i32) x6, SHF_78); + ST_DP(x3, x); x += 2; + x12 *= da_i_vec; + x7 = (v2f64) __msa_shf_w((v4i32) x7, SHF_78); + ST_DP(x4, x); x += 2; + x13 *= da_i_vec; + x8 = (v2f64) __msa_shf_w((v4i32) x8, SHF_78); + ST_DP(x5, x); x += 2; + x14 *= da_i_vec; + x9 = (v2f64) __msa_shf_w((v4i32) x9, SHF_78); + ST_DP(x6, x); x += 2; + x15 *= da_i_vec; + x10 = (v2f64) __msa_shf_w((v4i32) x10, SHF_78); + ST_DP(x7, x); x += 2; + x11 = (v2f64) __msa_shf_w((v4i32) x11, SHF_78); + ST_DP(x8, x); x += 2; + x0 = LD_DP(px); px += 2; + x12 = (v2f64) __msa_shf_w((v4i32) x12, SHF_78); + ST_DP(x9, x); x += 2; + x1 = LD_DP(px); px += 2; + x13 = (v2f64) __msa_shf_w((v4i32) x13, SHF_78); + ST_DP(x10, x); x += 2; + x2 = LD_DP(px); px += 2; + x14 = (v2f64) __msa_shf_w((v4i32) x14, SHF_78); + ST_DP(x11, x); x += 2; + x3 = LD_DP(px); px += 2; + x15 = (v2f64) __msa_shf_w((v4i32) x15, SHF_78); + ST_DP(x12, x); x += 2; + x4 = LD_DP(px); px += 2; + ST_DP(x13, x); x += 2; + x5 = LD_DP(px); px += 2; + ST_DP(x14, x); x += 2; + x6 = LD_DP(px); px += 2; + ST_DP(x15, x); x += 2; + x7 = LD_DP(px); px += 2; + } + + LD_DP8_INC(px, 2, x8, x9, x10, x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + x8, x9, x10, x11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + x12, x13, x14, x15); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + SHF_W4_DP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_78); + SHF_W4_DP(x8, x9, x10, x11, x8, x9, x10, x11, SHF_78); + SHF_W4_DP(x12, x13, x14, x15, x12, x13, x14, x15, SHF_78); + ST_DP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + SHF_W4_DP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_78); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 2); + } + + if (n & 4) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + ST_DP4_INC(x0, x1, x2, x3, x, 2); + } + + if (n & 2) + { + LD_DP2_INC(px, 2, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, x0, x1); + SHF_W2_DP(x0, x1, x0, x1, SHF_78); + ST_DP2_INC(x0, x1, x, 2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_i, f1, -da_i, f0, f1); + ST_GP2_INC(f1, f0, x, 1); + } + } + } + else if (0.0 == da_i) + { + da_r_vec = COPY_DOUBLE_TO_VECTOR(da_r); + + if (n > 15) + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32 + 16; + + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + for (i = (n >> 4)- 1; i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + x8 = LD_DP(px); px += 2; + x0 *= da_r_vec; + x9 = LD_DP(px); px += 2; + x1 *= da_r_vec; + x10 = LD_DP(px); px += 2; + x2 *= da_r_vec; + x11 = LD_DP(px); px += 2; + x3 *= da_r_vec; + x12 = LD_DP(px); px += 2; + x4 *= da_r_vec; + x13 = LD_DP(px); px += 2; + x5 *= da_r_vec; + ST_DP(x0, x); x += 2; + x14 = LD_DP(px); px += 2; + x6 *= da_r_vec; + ST_DP(x1, x); x += 2; + x15 = LD_DP(px); px += 2; + x7 *= da_r_vec; + ST_DP(x2, x); x += 2; + x8 *= da_r_vec; + ST_DP(x3, x); x += 2; + x9 *= da_r_vec; + ST_DP(x4, x); x += 2; + x10 *= da_r_vec; + ST_DP(x5, x); x += 2; + x11 *= da_r_vec; + ST_DP(x6, x); x += 2; + x12 *= da_r_vec; + ST_DP(x7, x); x += 2; + x13 *= da_r_vec; + ST_DP(x8, x); x += 2; + x0 = LD_DP(px); px += 2; + x14 *= da_r_vec; + ST_DP(x9, x); x += 2; + x1 = LD_DP(px); px += 2; + x15 *= da_r_vec; + ST_DP(x10, x); x += 2; + x2 = LD_DP(px); px += 2; + ST_DP(x11, x); x += 2; + x3 = LD_DP(px); px += 2; + ST_DP(x12, x); x += 2; + x4 = LD_DP(px); px += 2; + ST_DP(x13, x); x += 2; + x5 = LD_DP(px); px += 2; + ST_DP(x14, x); x += 2; + x6 = LD_DP(px); px += 2; + ST_DP(x15, x); x += 2; + x7 = LD_DP(px); px += 2; + } + + LD_DP8_INC(px, 2, x8, x9, x10, x11, x12, x13, x14, x15); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + MUL4(x8, da_r_vec, x9, da_r_vec, x10, da_r_vec, x11, da_r_vec, + x8, x9, x10, x11); + MUL4(x12, da_r_vec, x13, da_r_vec, x14, da_r_vec, x15, da_r_vec, + x12, x13, x14, x15); + ST_DP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, 2); + } + + if (n & 4) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, x, 2); + } + + if (n & 2) + { + LD_DP2_INC(px, 2, x0, x1); + MUL2(x0, da_r_vec, x1, da_r_vec, x0, x1); + ST_DP2_INC(x0, x1, x, 2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_r, f1, da_r, f0, f1); + ST_GP2_INC(f0, f1, x, 1); + } + } + } + else + { + FLOAT *x_pref; + BLASLONG pref_offset; + + pref_offset = (BLASLONG)x & (L1_DATA_LINESIZE - 1); + if (pref_offset > 0) + { + pref_offset = L1_DATA_LINESIZE - pref_offset; + pref_offset = pref_offset / sizeof(FLOAT); + } + x_pref = x + pref_offset + 32; + + da_i_vec = COPY_DOUBLE_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v2f64) __msa_ilvev_d((v2i64) da_i_vec_neg, (v2i64) da_i_vec); + + da_r_vec = COPY_DOUBLE_TO_VECTOR(da_r); + + for (i = (n >> 4); i--;) + { + PREF_OFFSET(x_pref, 0); + PREF_OFFSET(x_pref, 32); + PREF_OFFSET(x_pref, 64); + PREF_OFFSET(x_pref, 96); + PREF_OFFSET(x_pref, 128); + PREF_OFFSET(x_pref, 160); + PREF_OFFSET(x_pref, 192); + PREF_OFFSET(x_pref, 224); + x_pref += 32; + + LD_DP16_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, + x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + d8, d9, d10, d11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + d12, d13, d14, d15); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + SHF_W4_DP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_78); + SHF_W4_DP(d8, d9, d10, d11, d8, d9, d10, d11, SHF_78); + SHF_W4_DP(d12, d13, d14, d15, d12, d13, d14, d15, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + FMADD4(x8, x9, x10, x11, da_r_vec, d8, d9, d10, d11); + FMADD4(x12, x13, x14, x15, da_r_vec, d12, d13, d14, d15); + ST_DP16_INC(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, + d12, d13, d14, d15, x, 2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + SHF_W4_DP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + ST_DP8_INC(d0, d1, d2, d3, d4, d5, d6, d7, x, 2); + } + + if (n & 4) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + ST_DP4_INC(d0, d1, d2, d3, x, 2); + } + + if (n & 2) + { + LD_DP2_INC(px, 2, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, d0, d1); + SHF_W2_DP(d0, d1, d0, d1, SHF_78); + FMADD2(x0, x1, da_r_vec, d0, d1); + ST_DP2_INC(d0, d1, x, 2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + + ST_GP2_INC(tp0, tp1, x, 1); + } + } + } + } + else + { + inc_x2 = 2 * inc_x; + + if ((0.0 == da_r) && (0.0 == da_i)) + { + v2f64 zero_v = __msa_cast_to_vector_double(0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 0, 0.0); + zero_v = (v2f64) __msa_insert_d((v2i64) zero_v, 1, 0.0); + + for (i = (n >> 4); i--;) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, inc_x2); + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, inc_x2); + } + + if (n & 15) + { + if (n & 8) + { + ST_DP8_INC(zero_v, zero_v, zero_v, zero_v, zero_v, zero_v, + zero_v, zero_v, x, inc_x2); + } + + if (n & 4) + { + ST_DP4_INC(zero_v, zero_v, zero_v, zero_v, x, inc_x2); + } + + if (n & 2) + { + ST_DP2_INC(zero_v, zero_v, x, inc_x2); + } + + if (n & 1) + { + ST_DP(zero_v, x); + } + } + } + else if (0.0 == da_r) + { + da_i_vec = COPY_DOUBLE_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v2f64) __msa_ilvev_d((v2i64) da_i_vec_neg, (v2i64) da_i_vec); + + for (i = (n >> 4); i--;) + { + LD_DP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + x8, x9, x10, x11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + x12, x13, x14, x15); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + SHF_W4_DP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_78); + SHF_W4_DP(x8, x9, x10, x11, x8, x9, x10, x11, SHF_78); + SHF_W4_DP(x12, x13, x14, x15, x12, x13, x14, x15, SHF_78); + ST_DP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, inc_x2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + x4, x5, x6, x7); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + SHF_W4_DP(x4, x5, x6, x7, x4, x5, x6, x7, SHF_78); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, inc_x2); + } + + if (n & 4) + { + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + x0, x1, x2, x3); + SHF_W4_DP(x0, x1, x2, x3, x0, x1, x2, x3, SHF_78); + ST_DP4_INC(x0, x1, x2, x3, x, inc_x2); + } + + if (n & 2) + { + LD_DP2_INC(px, inc_x2, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, x0, x1); + SHF_W2_DP(x0, x1, x0, x1, SHF_78); + ST_DP2_INC(x0, x1, x, inc_x2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_i, f1, -da_i, f0, f1); + ST_GP2_INC(f1, f0, x, 1); + } + } + } + else if (0.0 == da_i) + { + da_r_vec = COPY_DOUBLE_TO_VECTOR(da_r); + + for (i = (n >> 4); i--;) + { + LD_DP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + MUL4(x8, da_r_vec, x9, da_r_vec, x10, da_r_vec, x11, da_r_vec, + x8, x9, x10, x11); + MUL4(x12, da_r_vec, x13, da_r_vec, x14, da_r_vec, x15, da_r_vec, + x12, x13, x14, x15); + ST_DP16_INC(x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, + x12, x13, x14, x15, x, inc_x2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + MUL4(x4, da_r_vec, x5, da_r_vec, x6, da_r_vec, x7, da_r_vec, + x4, x5, x6, x7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, x, inc_x2); + } + + if (n & 4) + { + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); + MUL4(x0, da_r_vec, x1, da_r_vec, x2, da_r_vec, x3, da_r_vec, + x0, x1, x2, x3); + ST_DP4_INC(x0, x1, x2, x3, x, inc_x2); + } + + if (n & 2) + { + LD_DP2_INC(px, inc_x2, x0, x1); + MUL2(x0, da_r_vec, x1, da_r_vec, x0, x1); + ST_DP2_INC(x0, x1, x, inc_x2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + MUL2(f0, da_r, f1, da_r, f0, f1); + ST_GP2_INC(f0, f1, x, 1); + } + } + } + else + { + da_i_vec = COPY_DOUBLE_TO_VECTOR(da_i); + da_i_vec_neg = -da_i_vec; + da_i_vec = (v2f64) __msa_ilvev_d((v2i64) da_i_vec_neg, (v2i64) da_i_vec); + + da_r_vec = COPY_DOUBLE_TO_VECTOR(da_r); + + for (i = (n >> 4); i--;) + { + LD_DP16_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, + x10, x11, x12, x13, x14, x15); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + MUL4(x8, da_i_vec, x9, da_i_vec, x10, da_i_vec, x11, da_i_vec, + d8, d9, d10, d11); + MUL4(x12, da_i_vec, x13, da_i_vec, x14, da_i_vec, x15, da_i_vec, + d12, d13, d14, d15); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + SHF_W4_DP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_78); + SHF_W4_DP(d8, d9, d10, d11, d8, d9, d10, d11, SHF_78); + SHF_W4_DP(d12, d13, d14, d15, d12, d13, d14, d15, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + FMADD4(x8, x9, x10, x11, da_r_vec, d8, d9, d10, d11); + FMADD4(x12, x13, x14, x15, da_r_vec, d12, d13, d14, d15); + ST_DP16_INC(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, + d12, d13, d14, d15, x, inc_x2); + } + + if (n & 15) + { + if (n & 8) + { + LD_DP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + MUL4(x4, da_i_vec, x5, da_i_vec, x6, da_i_vec, x7, da_i_vec, + d4, d5, d6, d7); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + SHF_W4_DP(d4, d5, d6, d7, d4, d5, d6, d7, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + FMADD4(x4, x5, x6, x7, da_r_vec, d4, d5, d6, d7); + ST_DP8_INC(d0, d1, d2, d3, d4, d5, d6, d7, x, inc_x2); + } + + if (n & 4) + { + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); + MUL4(x0, da_i_vec, x1, da_i_vec, x2, da_i_vec, x3, da_i_vec, + d0, d1, d2, d3); + SHF_W4_DP(d0, d1, d2, d3, d0, d1, d2, d3, SHF_78); + FMADD4(x0, x1, x2, x3, da_r_vec, d0, d1, d2, d3); + ST_DP4_INC(d0, d1, d2, d3, x, inc_x2); + } + + if (n & 2) + { + LD_DP2_INC(px, inc_x2, x0, x1); + MUL2(x0, da_i_vec, x1, da_i_vec, d0, d1); + SHF_W2_DP(d0, d1, d0, d1, SHF_78); + FMADD2(x0, x1, da_r_vec, d0, d1); + ST_DP2_INC(d0, d1, x, inc_x2); + } + + if (n & 1) + { + LD_GP2_INC(px, 1, f0, f1); + + tp0 = da_r * f0; + tp0 -= da_i * f1; + tp1 = da_r * f1; + tp1 += da_i * f0; + + ST_GP2_INC(tp0, tp1, x, 1); + } + } + } + } + + return (0); +} diff --git a/kernel/mips/zswap_msa.c b/kernel/mips/zswap_msa.c new file mode 100644 index 0000000000..eaf7ec16ea --- /dev/null +++ b/kernel/mips/zswap_msa.c @@ -0,0 +1,238 @@ +/******************************************************************************* +Copyright (c) 2016, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*******************************************************************************/ + +#include "common.h" +#include "macros_msa.h" + +int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT dummy3, + FLOAT dummy4, FLOAT *srcx, BLASLONG inc_x, FLOAT *srcy, + BLASLONG inc_y, FLOAT *dummy, BLASLONG dummy2) +{ + BLASLONG i, inc_x2, inc_y2, pref_offsetx, pref_offsety; + FLOAT *px, *py; + v2f64 x0, x1, x2, x3, x4, x5, x6, x7; + v2f64 y0, y1, y2, y3, y4, y5, y6, y7; + + if (n < 0) return (0); + + pref_offsetx = (BLASLONG)srcx & (L1_DATA_LINESIZE - 1); + if (pref_offsetx > 0) + { + pref_offsetx = L1_DATA_LINESIZE - pref_offsetx; + pref_offsetx = pref_offsetx / sizeof(FLOAT); + } + + pref_offsety = (BLASLONG)srcy & (L1_DATA_LINESIZE - 1); + if (pref_offsety > 0) + { + pref_offsety = L1_DATA_LINESIZE - pref_offsety; + pref_offsety = pref_offsety / sizeof(FLOAT); + } + + inc_x2 = 2 * inc_x; + inc_y2 = 2 * inc_y; + + px = srcx; + py = srcy; + + if ((1 == inc_x) && (1 == inc_y)) + { + if (n >> 3) + { + LD_DP8_INC(px, 2, x0, x1, x2, x3, x4, x5, x6, x7); + + for (i = (n >> 3) - 1; i--;) + { + PREFETCH(px + pref_offsetx + 16); + PREFETCH(px + pref_offsetx + 20); + PREFETCH(px + pref_offsetx + 24); + PREFETCH(px + pref_offsetx + 28); + + PREFETCH(py + pref_offsety + 16); + PREFETCH(py + pref_offsety + 20); + PREFETCH(py + pref_offsety + 24); + PREFETCH(py + pref_offsety + 28); + + y0 = LD_DP(py); py += 2; + ST_DP(x0, srcy); srcy += 2; + y1 = LD_DP(py); py += 2; + ST_DP(x1, srcy); srcy += 2; + y2 = LD_DP(py); py += 2; + ST_DP(x2, srcy); srcy += 2; + y3 = LD_DP(py); py += 2; + ST_DP(x3, srcy); srcy += 2; + y4 = LD_DP(py); py += 2; + ST_DP(x4, srcy); srcy += 2; + y5 = LD_DP(py); py += 2; + ST_DP(x5, srcy); srcy += 2; + y6 = LD_DP(py); py += 2; + ST_DP(x6, srcy); srcy += 2; + y7 = LD_DP(py); py += 2; + ST_DP(x7, srcy); srcy += 2; + + x0 = LD_DP(px); px += 2; + ST_DP(y0, srcx); srcx += 2; + x1 = LD_DP(px); px += 2; + ST_DP(y1, srcx); srcx += 2; + x2 = LD_DP(px); px += 2; + ST_DP(y2, srcx); srcx += 2; + x3 = LD_DP(px); px += 2; + ST_DP(y3, srcx); srcx += 2; + x4 = LD_DP(px); px += 2; + ST_DP(y4, srcx); srcx += 2; + x5 = LD_DP(px); px += 2; + ST_DP(y5, srcx); srcx += 2; + x6 = LD_DP(px); px += 2; + ST_DP(y6, srcx); srcx += 2; + x7 = LD_DP(px); px += 2; + ST_DP(y7, srcx); srcx += 2; + } + + LD_DP8_INC(py, 2, y0, y1, y2, y3, y4, y5, y6, y7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, srcy, 2); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, srcx, 2); + } + + if (n & 7) + { + if ((n & 4) && (n & 2) && (n & 1)) + { + LD_DP7_INC(px, 2, x0, x1, x2, x3, x4, x5, x6); + LD_DP7_INC(py, 2, y0, y1, y2, y3, y4, y5, y6); + ST_DP7_INC(x0, x1, x2, x3, x4, x5, x6, srcy, 2); + ST_DP7_INC(y0, y1, y2, y3, y4, y5, y6, srcx, 2); + } + else if ((n & 4) && (n & 2)) + { + LD_DP6_INC(px, 2, x0, x1, x2, x3, x4, x5); + LD_DP6_INC(py, 2, y0, y1, y2, y3, y4, y5); + ST_DP6_INC(x0, x1, x2, x3, x4, x5, srcy, 2); + ST_DP6_INC(y0, y1, y2, y3, y4, y5, srcx, 2); + } + else if ((n & 4) && (n & 1)) + { + LD_DP5_INC(px, 2, x0, x1, x2, x3, x4); + LD_DP5_INC(py, 2, y0, y1, y2, y3, y4); + ST_DP5_INC(x0, x1, x2, x3, x4, srcy, 2); + ST_DP5_INC(y0, y1, y2, y3, y4, srcx, 2); + } + else if ((n & 2) && (n & 1)) + { + LD_DP3_INC(px, 2, x0, x1, x2); + LD_DP3_INC(py, 2, y0, y1, y2); + ST_DP3_INC(x0, x1, x2, srcy, 2); + ST_DP3_INC(y0, y1, y2, srcx, 2); + } + else if (n & 4) + { + LD_DP4_INC(px, 2, x0, x1, x2, x3); + LD_DP4_INC(py, 2, y0, y1, y2, y3); + ST_DP4_INC(x0, x1, x2, x3, srcy, 2); + ST_DP4_INC(y0, y1, y2, y3, srcx, 2); + } + else if (n & 2) + { + LD_DP2_INC(px, 2, x0, x1); + LD_DP2_INC(py, 2, y0, y1); + ST_DP2_INC(x0, x1, srcy, 2); + ST_DP2_INC(y0, y1, srcx, 2); + } + else if (n & 1) + { + x0 = LD_DP(px); + y0 = LD_DP(py); + ST_DP(y0, srcx); + ST_DP(x0, srcy); + } + } + } + else + { + for (i = (n >> 3); i--;) + { + LD_DP8_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6, x7); + LD_DP8_INC(py, inc_y2, y0, y1, y2, y3, y4, y5, y6, y7); + ST_DP8_INC(x0, x1, x2, x3, x4, x5, x6, x7, srcy, inc_y2); + ST_DP8_INC(y0, y1, y2, y3, y4, y5, y6, y7, srcx, inc_x2); + } + + if (n & 7) + { + if ((n & 4) && (n & 2) && (n & 1)) + { + LD_DP7_INC(px, inc_x2, x0, x1, x2, x3, x4, x5, x6); + LD_DP7_INC(py, inc_y2, y0, y1, y2, y3, y4, y5, y6); + ST_DP7_INC(x0, x1, x2, x3, x4, x5, x6, srcy, inc_y2); + ST_DP7_INC(y0, y1, y2, y3, y4, y5, y6, srcx, inc_x2); + } + else if ((n & 4) && (n & 2)) + { + LD_DP6_INC(px, inc_x2, x0, x1, x2, x3, x4, x5); + LD_DP6_INC(py, inc_y2, y0, y1, y2, y3, y4, y5); + ST_DP6_INC(x0, x1, x2, x3, x4, x5, srcy, inc_y2); + ST_DP6_INC(y0, y1, y2, y3, y4, y5, srcx, inc_x2); + } + else if ((n & 4) && (n & 1)) + { + LD_DP5_INC(px, inc_x2, x0, x1, x2, x3, x4); + LD_DP5_INC(py, inc_y2, y0, y1, y2, y3, y4); + ST_DP5_INC(x0, x1, x2, x3, x4, srcy, inc_y2); + ST_DP5_INC(y0, y1, y2, y3, y4, srcx, inc_x2); + } + else if ((n & 2) && (n & 1)) + { + LD_DP3_INC(px, inc_x2, x0, x1, x2); + LD_DP3_INC(py, inc_y2, y0, y1, y2); + ST_DP3_INC(x0, x1, x2, srcy, inc_y2); + ST_DP3_INC(y0, y1, y2, srcx, inc_x2); + } + else if (n & 4) + { + LD_DP4_INC(px, inc_x2, x0, x1, x2, x3); + LD_DP4_INC(py, inc_y2, y0, y1, y2, y3); + ST_DP4_INC(x0, x1, x2, x3, srcy, inc_y2); + ST_DP4_INC(y0, y1, y2, y3, srcx, inc_x2); + } + else if (n & 2) + { + LD_DP2_INC(px, inc_x2, x0, x1); + LD_DP2_INC(py, inc_y2, y0, y1); + ST_DP2_INC(x0, x1, srcy, inc_y2); + ST_DP2_INC(y0, y1, srcx, inc_x2); + } + else if (n & 1) + { + x0 = LD_DP(px); + y0 = LD_DP(py); + ST_DP(y0, srcx); + ST_DP(x0, srcy); + } + } + } + + return (0); +} diff --git a/kernel/power/casum.c b/kernel/power/casum.c index aeed0ca780..d1108581d3 100644 --- a/kernel/power/casum.c +++ b/kernel/power/casum.c @@ -53,7 +53,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_16 -static void casum_kernel_16(BLASLONG n, FLOAT *x1, FLOAT *svec) +static FLOAT casum_kernel_16(BLASLONG n, FLOAT *x1) { BLASLONG i=0; @@ -92,11 +92,7 @@ static void casum_kernel_16(BLASLONG n, FLOAT *x1, FLOAT *svec) } - svec[0] = sum0+sum1+sum2+sum3; - svec[1] = 0.0; - svec[2] = 0.0; - svec[3] = 0.0; - + return sum0+sum1+sum2+sum3; } #endif @@ -106,7 +102,6 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) BLASLONG i=0; BLASLONG ip=0; FLOAT sumf = 0.0; - FLOAT svec[4] __attribute__ ((aligned (16)));; BLASLONG n1; BLASLONG inc_x2; @@ -119,8 +114,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) if ( n1 > 0 ) { - casum_kernel_16(n1, x, svec); - sumf = svec[0] + svec[1]+svec[2]+svec[3]; + sumf = casum_kernel_16(n1, x); i=n1; ip = 2 * n1; } diff --git a/kernel/power/casum_microk_power8.c b/kernel/power/casum_microk_power8.c index cb50234cea..7d12c98858 100644 --- a/kernel/power/casum_microk_power8.c +++ b/kernel/power/casum_microk_power8.c @@ -34,144 +34,145 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_16 1 -static void casum_kernel_16( BLASLONG n, FLOAT *x, FLOAT *svec) __attribute__ ((noinline)); -static void casum_kernel_16( BLASLONG n, FLOAT *x, FLOAT *svec) +static float casum_kernel_16 (long n, float *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "dcbt %2 , %4 \n\t" - - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2 , %4 \n\t" - - "xvabssp 48, 40 \n\t" - "xvabssp 49, 41 \n\t" - "xvabssp 50, 42 \n\t" - "xvabssp 51, 43 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - - "xvabssp 52, 44 \n\t" - "xvabssp 53, 45 \n\t" - - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - - "xvabssp 54, 46 \n\t" - "xvabssp 55, 47 \n\t" - - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - - "xvaddsp 32, 32, 48 \n\t" - "xvaddsp 33, 33, 49 \n\t" - - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "xvaddsp 34, 34, 50 \n\t" - "xvaddsp 35, 35, 51 \n\t" - "addi %2, %2, 128 \n\t" - "xvaddsp 36, 36, 52 \n\t" - "xvaddsp 37, 37, 53 \n\t" - "addic. %0 , %0 , -16 \n\t" - "xvaddsp 38, 38, 54 \n\t" - "xvaddsp 39, 39, 55 \n\t" - - "bgt 1b \n\t" - - "2: \n\t" - - - "xvabssp 48, 40 \n\t" - "xvabssp 49, 41 \n\t" - "xvabssp 50, 42 \n\t" - "xvabssp 51, 43 \n\t" - "xvabssp 52, 44 \n\t" - "xvabssp 53, 45 \n\t" - "xvabssp 54, 46 \n\t" - "xvabssp 55, 47 \n\t" - - "xvaddsp 32, 32, 48 \n\t" - "xvaddsp 33, 33, 49 \n\t" - "xvaddsp 34, 34, 50 \n\t" - "xvaddsp 35, 35, 51 \n\t" - "xvaddsp 36, 36, 52 \n\t" - "xvaddsp 37, 37, 53 \n\t" - "xvaddsp 38, 38, 54 \n\t" - "xvaddsp 39, 39, 55 \n\t" - - "xvaddsp 32, 32, 33 \n\t" - "xvaddsp 34, 34, 35 \n\t" - "xvaddsp 36, 36, 37 \n\t" - "xvaddsp 38, 38, 39 \n\t" - - "xvaddsp 32, 32, 34 \n\t" - "xvaddsp 36, 36, 38 \n\t" - - "xvaddsp 32, 32, 36 \n\t" - - - "stxvw4x 32, 0, %3 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (svec), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2", "memory" - ); - -} - - + float sum; + __vector float t0; + __vector float t1; + __vector float t2; + __vector float t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvabssp 48, 40 \n\t" + "xvabssp 49, 41 \n\t" + "xvabssp 50, 42 \n\t" + "xvabssp 51, 43 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + + "xvabssp %x3, 44 \n\t" + "xvabssp %x4, 45 \n\t" + + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + + "xvabssp %x5, 46 \n\t" + "xvabssp %x6, 47 \n\t" + + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + + "xvaddsp 32, 32, 48 \n\t" + "xvaddsp 33, 33, 49 \n\t" + + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "xvaddsp 34, 34, 50 \n\t" + "xvaddsp 35, 35, 51 \n\t" + "addi %2, %2, 128 \n\t" + "xvaddsp 36, 36, %x3 \n\t" + "xvaddsp 37, 37, %x4 \n\t" + "addic. %1, %1, -16 \n\t" + "xvaddsp 38, 38, %x5 \n\t" + "xvaddsp 39, 39, %x6 \n\t" + + "bgt 1b \n" + + "2: \n\t" + + "xvabssp 48, 40 \n\t" + "xvabssp 49, 41 \n\t" + "xvabssp 50, 42 \n\t" + "xvabssp 51, 43 \n\t" + "xvabssp %x3, 44 \n\t" + "xvabssp %x4, 45 \n\t" + "xvabssp %x5, 46 \n\t" + "xvabssp %x6, 47 \n\t" + + "xvaddsp 32, 32, 48 \n\t" + "xvaddsp 33, 33, 49 \n\t" + "xvaddsp 34, 34, 50 \n\t" + "xvaddsp 35, 35, 51 \n\t" + "xvaddsp 36, 36, %x3 \n\t" + "xvaddsp 37, 37, %x4 \n\t" + "xvaddsp 38, 38, %x5 \n\t" + "xvaddsp 39, 39, %x6 \n\t" + + "xvaddsp 32, 32, 33 \n\t" + "xvaddsp 34, 34, 35 \n\t" + "xvaddsp 36, 36, 37 \n\t" + "xvaddsp 38, 38, 39 \n\t" + + "xvaddsp 32, 32, 34 \n\t" + "xvaddsp 36, 36, 38 \n\t" + + "xvaddsp 32, 32, 36 \n\t" + + "xxsldwi 33, 32, 32, 2 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xxsldwi 33, 32, 32, 1 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xscvspdp %x0, 32 \n" + + "#n=%1 x=%3=%2 sum=%0 o16=%8 o32=%9 o48=%10 o64=%11 o80=%12 o96=%13 o112=%14\n" + "#t0=%x3 t1=%x4 t2=%x5 t3=%x6" + : + "=f" (sum), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0), // 3 + "=wa" (t1), // 4 + "=wa" (t2), // 5 + "=wa" (t3) // 6 + : + "m" (*x), + "b" (16), // 8 + "b" (32), // 9 + "b" (48), // 10 + "b" (64), // 11 + "b" (80), // 12 + "b" (96), // 13 + "b" (112) // 14 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return sum; +} diff --git a/kernel/power/ccopy_microk_power8.c b/kernel/power/ccopy_microk_power8.c index 95b3559ba5..613c4d2869 100644 --- a/kernel/power/ccopy_microk_power8.c +++ b/kernel/power/ccopy_microk_power8.c @@ -35,140 +35,121 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void ccopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void ccopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void ccopy_kernel_32 (long n, float *x, float *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvw4x 50, 0, %2 \n\t" - "lxvw4x 51, %5, %2 \n\t" - "lxvw4x 52, %6, %2 \n\t" - "lxvw4x 53, %7, %2 \n\t" - "lxvw4x 54, %8, %2 \n\t" - "lxvw4x 55, %9, %2 \n\t" - "lxvw4x 56, %10, %2 \n\t" - "lxvw4x 57, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "stxvw4x 40, 0, %1 \n\t" - "stxvw4x 41, %5, %1 \n\t" - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "stxvw4x 42, %6, %1 \n\t" - "stxvw4x 43, %7, %1 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "stxvw4x 44, %8, %1 \n\t" - "stxvw4x 45, %9, %1 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "stxvw4x 46, %10, %1 \n\t" - "stxvw4x 47, %11, %1 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "stxvw4x 50, 0, %1 \n\t" - "stxvw4x 51, %5, %1 \n\t" - "lxvw4x 50, 0, %2 \n\t" - "lxvw4x 51, %5, %2 \n\t" - "stxvw4x 52, %6, %1 \n\t" - "stxvw4x 53, %7, %1 \n\t" - "lxvw4x 52, %6, %2 \n\t" - "lxvw4x 53, %7, %2 \n\t" - "stxvw4x 54, %8, %1 \n\t" - "stxvw4x 55, %9, %1 \n\t" - "lxvw4x 54, %8, %2 \n\t" - "lxvw4x 55, %9, %2 \n\t" - "stxvw4x 56, %10, %1 \n\t" - "stxvw4x 57, %11, %1 \n\t" - "lxvw4x 56, %10, %2 \n\t" - "lxvw4x 57, %11, %2 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "stxvw4x 40, 0, %1 \n\t" - "stxvw4x 41, %5, %1 \n\t" - "stxvw4x 42, %6, %1 \n\t" - "stxvw4x 43, %7, %1 \n\t" - "stxvw4x 44, %8, %1 \n\t" - "stxvw4x 45, %9, %1 \n\t" - "stxvw4x 46, %10, %1 \n\t" - "stxvw4x 47, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvw4x 50, 0, %1 \n\t" - "stxvw4x 51, %5, %1 \n\t" - "stxvw4x 52, %6, %1 \n\t" - "stxvw4x 53, %7, %1 \n\t" - "stxvw4x 54, %8, %1 \n\t" - "stxvw4x 55, %9, %1 \n\t" - "stxvw4x 56, %10, %1 \n\t" - "stxvw4x 57, %11, %1 \n\t" - - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __asm__ + ( + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n" + + "#n=%1 x=%4=%2 y=%0=%3 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "=m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y) // 3 + : + "m" (*x), + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/cswap_microk_power8.c b/kernel/power/cswap_microk_power8.c index 90ab59c547..8d7d0c0b9f 100644 --- a/kernel/power/cswap_microk_power8.c +++ b/kernel/power/cswap_microk_power8.c @@ -35,146 +35,124 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void cswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void cswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void cswap_kernel_32 (long n, float *x, float *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "addi %3, %3, -4 \n\t" - "addi %4, %4, -4 \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "lxvw4x 32, 0, %2 \n\t" - "lxvw4x 33, %5, %2 \n\t" - "lxvw4x 34, %6, %2 \n\t" - "lxvw4x 35, %7, %2 \n\t" - "lxvw4x 36, %8, %2 \n\t" - "lxvw4x 37, %9, %2 \n\t" - "lxvw4x 38, %10, %2 \n\t" - "lxvw4x 39, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvw4x 48, 0, %1 \n\t" - "lxvw4x 49, %5, %1 \n\t" - "lxvw4x 50, %6, %1 \n\t" - "lxvw4x 51, %7, %1 \n\t" - "lxvw4x 52, %8, %1 \n\t" - "lxvw4x 53, %9, %1 \n\t" - "lxvw4x 54, %10, %1 \n\t" - "lxvw4x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "lxvw4x 56, 0, %1 \n\t" - "lxvw4x 57, %5, %1 \n\t" - "lxvw4x 58, %6, %1 \n\t" - "lxvw4x 59, %7, %1 \n\t" - "lxvw4x 60, %8, %1 \n\t" - "lxvw4x 61, %9, %1 \n\t" - "lxvw4x 62, %10, %1 \n\t" - "lxvw4x 63, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvw4x 32, 0, %3 \n\t" - "stxvw4x 33, %5, %3 \n\t" - "stxvw4x 34, %6, %3 \n\t" - "stxvw4x 35, %7, %3 \n\t" - "stxvw4x 36, %8, %3 \n\t" - "stxvw4x 37, %9, %3 \n\t" - "stxvw4x 38, %10, %3 \n\t" - "stxvw4x 39, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvw4x 40, 0, %3 \n\t" - "stxvw4x 41, %5, %3 \n\t" - "stxvw4x 42, %6, %3 \n\t" - "stxvw4x 43, %7, %3 \n\t" - "stxvw4x 44, %8, %3 \n\t" - "stxvw4x 45, %9, %3 \n\t" - "stxvw4x 46, %10, %3 \n\t" - "stxvw4x 47, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvw4x 48, 0, %4 \n\t" - "stxvw4x 49, %5, %4 \n\t" - "stxvw4x 50, %6, %4 \n\t" - "stxvw4x 51, %7, %4 \n\t" - "stxvw4x 52, %8, %4 \n\t" - "stxvw4x 53, %9, %4 \n\t" - "stxvw4x 54, %10, %4 \n\t" - "stxvw4x 55, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "stxvw4x 56, 0, %4 \n\t" - "stxvw4x 57, %5, %4 \n\t" - "stxvw4x 58, %6, %4 \n\t" - "stxvw4x 59, %7, %4 \n\t" - "stxvw4x 60, %8, %4 \n\t" - "stxvw4x 61, %9, %4 \n\t" - "stxvw4x 62, %10, %4 \n\t" - "stxvw4x 63, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (y2), // 3 - "r" (x2), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "%3", "%4", "memory" - ); - -} - - + __asm__ + ( + ".p2align 5 \n" + "1: \n\t" + + "lxvd2x 32, 0, %4 \n\t" + "lxvd2x 33, %5, %4 \n\t" + "lxvd2x 34, %6, %4 \n\t" + "lxvd2x 35, %7, %4 \n\t" + "lxvd2x 36, %8, %4 \n\t" + "lxvd2x 37, %9, %4 \n\t" + "lxvd2x 38, %10, %4 \n\t" + "lxvd2x 39, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "lxvd2x 40, 0, %4 \n\t" + "lxvd2x 41, %5, %4 \n\t" + "lxvd2x 42, %6, %4 \n\t" + "lxvd2x 43, %7, %4 \n\t" + "lxvd2x 44, %8, %4 \n\t" + "lxvd2x 45, %9, %4 \n\t" + "lxvd2x 46, %10, %4 \n\t" + "lxvd2x 47, %11, %4 \n\t" + + "addi %4, %4, -128 \n\t" + + "lxvd2x 48, 0, %3 \n\t" + "lxvd2x 49, %5, %3 \n\t" + "lxvd2x 50, %6, %3 \n\t" + "lxvd2x 51, %7, %3 \n\t" + "lxvd2x 0, %8, %3 \n\t" + "lxvd2x 1, %9, %3 \n\t" + "lxvd2x 2, %10, %3 \n\t" + "lxvd2x 3, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "lxvd2x 4, 0, %3 \n\t" + "lxvd2x 5, %5, %3 \n\t" + "lxvd2x 6, %6, %3 \n\t" + "lxvd2x 7, %7, %3 \n\t" + "lxvd2x 8, %8, %3 \n\t" + "lxvd2x 9, %9, %3 \n\t" + "lxvd2x 10, %10, %3 \n\t" + "lxvd2x 11, %11, %3 \n\t" + + "addi %3, %3, -128 \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 48, 0, %4 \n\t" + "stxvd2x 49, %5, %4 \n\t" + "stxvd2x 50, %6, %4 \n\t" + "stxvd2x 51, %7, %4 \n\t" + "stxvd2x 0, %8, %4 \n\t" + "stxvd2x 1, %9, %4 \n\t" + "stxvd2x 2, %10, %4 \n\t" + "stxvd2x 3, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "stxvd2x 4, 0, %4 \n\t" + "stxvd2x 5, %5, %4 \n\t" + "stxvd2x 6, %6, %4 \n\t" + "stxvd2x 7, %7, %4 \n\t" + "stxvd2x 8, %8, %4 \n\t" + "stxvd2x 9, %9, %4 \n\t" + "stxvd2x 10, %10, %4 \n\t" + "stxvd2x 11, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "addic. %2, %2, -32 \n\t" + "bgt 1b \n" + + "#n=%2 x=%0=%3 y=%1=%4 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y) // 4 + : + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51","vs0","vs1","vs2","vs3", + "vs4","vs5","vs6","vs7","vs8","vs9","vs10","vs11" + ); +} diff --git a/kernel/power/dasum.c b/kernel/power/dasum.c index 77f5345bab..73962c2f21 100644 --- a/kernel/power/dasum.c +++ b/kernel/power/dasum.c @@ -42,7 +42,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #else -#define ABS fabsf +#error supports double only #endif @@ -53,7 +53,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_16 -static void dasum_kernel_16(BLASLONG n, FLOAT *x1, FLOAT *svec) +static FLOAT dasum_kernel_16(BLASLONG n, FLOAT *x1) { BLASLONG i=0; @@ -92,9 +92,7 @@ static void dasum_kernel_16(BLASLONG n, FLOAT *x1, FLOAT *svec) } - svec[0] = sum0+sum1+sum2+sum3; - svec[1] = 0.0; - + return sum0+sum1+sum2+sum3; } #endif @@ -103,7 +101,6 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) { BLASLONG i=0; FLOAT sumf = 0.0; - FLOAT svec[2] __attribute__ ((aligned (16)));; BLASLONG n1; if (n <= 0 || inc_x <= 0) return(sumf); @@ -115,8 +112,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) if ( n1 > 0 ) { - dasum_kernel_16(n1, x, svec); - sumf = svec[0] + svec[1]; + sumf = dasum_kernel_16(n1, x); i=n1; } diff --git a/kernel/power/dasum_microk_power8.c b/kernel/power/dasum_microk_power8.c index cc38c4f7dc..880d7d2717 100644 --- a/kernel/power/dasum_microk_power8.c +++ b/kernel/power/dasum_microk_power8.c @@ -34,144 +34,142 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_16 1 -static void dasum_kernel_16( BLASLONG n, FLOAT *x, FLOAT *svec) __attribute__ ((noinline)); -static void dasum_kernel_16( BLASLONG n, FLOAT *x, FLOAT *svec) +static double dasum_kernel_16 (long n, double *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "dcbt %2 , %4 \n\t" - - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2 , %4 \n\t" - - "xvabsdp 48, 40 \n\t" - "xvabsdp 49, 41 \n\t" - "xvabsdp 50, 42 \n\t" - "xvabsdp 51, 43 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - - "xvabsdp 52, 44 \n\t" - "xvabsdp 53, 45 \n\t" - - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "xvabsdp 54, 46 \n\t" - "xvabsdp 55, 47 \n\t" - - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - - "xvadddp 32, 32, 48 \n\t" - "xvadddp 33, 33, 49 \n\t" - - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "xvadddp 34, 34, 50 \n\t" - "xvadddp 35, 35, 51 \n\t" - "addi %2, %2, 128 \n\t" - "xvadddp 36, 36, 52 \n\t" - "xvadddp 37, 37, 53 \n\t" - "addic. %0 , %0 , -16 \n\t" - "xvadddp 38, 38, 54 \n\t" - "xvadddp 39, 39, 55 \n\t" - - "bgt 1b \n\t" - - "2: \n\t" - - - "xvabsdp 48, 40 \n\t" - "xvabsdp 49, 41 \n\t" - "xvabsdp 50, 42 \n\t" - "xvabsdp 51, 43 \n\t" - "xvabsdp 52, 44 \n\t" - "xvabsdp 53, 45 \n\t" - "xvabsdp 54, 46 \n\t" - "xvabsdp 55, 47 \n\t" - - "xvadddp 32, 32, 48 \n\t" - "xvadddp 33, 33, 49 \n\t" - "xvadddp 34, 34, 50 \n\t" - "xvadddp 35, 35, 51 \n\t" - "xvadddp 36, 36, 52 \n\t" - "xvadddp 37, 37, 53 \n\t" - "xvadddp 38, 38, 54 \n\t" - "xvadddp 39, 39, 55 \n\t" - - "xvadddp 32, 32, 33 \n\t" - "xvadddp 34, 34, 35 \n\t" - "xvadddp 36, 36, 37 \n\t" - "xvadddp 38, 38, 39 \n\t" - - "xvadddp 32, 32, 34 \n\t" - "xvadddp 36, 36, 38 \n\t" - - "xvadddp 32, 32, 36 \n\t" - - - "stxvd2x 32, 0, %3 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (svec), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2", "memory" - ); - -} + double sum; + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvabsdp 48, 40 \n\t" + "xvabsdp 49, 41 \n\t" + "xvabsdp 50, 42 \n\t" + "xvabsdp 51, 43 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + + "xvabsdp %x3, 44 \n\t" + "xvabsdp %x4, 45 \n\t" + + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + + "xvabsdp %x5, 46 \n\t" + "xvabsdp %x6, 47 \n\t" + + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + + "xvadddp 32, 32, 48 \n\t" + "xvadddp 33, 33, 49 \n\t" + + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "xvadddp 34, 34, 50 \n\t" + "xvadddp 35, 35, 51 \n\t" + "addi %2, %2, 128 \n\t" + "xvadddp 36, 36, %x3 \n\t" + "xvadddp 37, 37, %x4 \n\t" + "addic. %1, %1, -16 \n\t" + "xvadddp 38, 38, %x5 \n\t" + "xvadddp 39, 39, %x6 \n\t" + + "bgt 1b \n" + + "2: \n\t" + + "xvabsdp 48, 40 \n\t" + "xvabsdp 49, 41 \n\t" + "xvabsdp 50, 42 \n\t" + "xvabsdp 51, 43 \n\t" + "xvabsdp %x3, 44 \n\t" + "xvabsdp %x4, 45 \n\t" + "xvabsdp %x5, 46 \n\t" + "xvabsdp %x6, 47 \n\t" + + "xvadddp 32, 32, 48 \n\t" + "xvadddp 33, 33, 49 \n\t" + "xvadddp 34, 34, 50 \n\t" + "xvadddp 35, 35, 51 \n\t" + "xvadddp 36, 36, %x3 \n\t" + "xvadddp 37, 37, %x4 \n\t" + "xvadddp 38, 38, %x5 \n\t" + "xvadddp 39, 39, %x6 \n\t" + + "xvadddp 32, 32, 33 \n\t" + "xvadddp 34, 34, 35 \n\t" + "xvadddp 36, 36, 37 \n\t" + "xvadddp 38, 38, 39 \n\t" + + "xvadddp 32, 32, 34 \n\t" + "xvadddp 36, 36, 38 \n\t" + + "xvadddp 32, 32, 36 \n\t" + + "xxswapd 33, 32 \n\t" + "xsadddp %x0, 32, 33 \n" + + "#n=%1 x=%3=%2 sum=%0 o16=%8 o32=%9 o48=%10 o64=%11 o80=%12 o96=%13 o112=%14\n" + "#t0=%x3 t1=%x4 t2=%x5 t3=%x6" + : + "=d" (sum), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0), // 3 + "=wa" (t1), // 4 + "=wa" (t2), // 5 + "=wa" (t3) // 6 + : + "m" (*x), + "b" (16), // 8 + "b" (32), // 9 + "b" (48), // 10 + "b" (64), // 11 + "b" (80), // 12 + "b" (96), // 13 + "b" (112) // 14 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return sum; +} diff --git a/kernel/power/daxpy.c b/kernel/power/daxpy.c index 4365bd88d9..df0572e8ee 100644 --- a/kernel/power/daxpy.c +++ b/kernel/power/daxpy.c @@ -43,21 +43,20 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_8 -static void daxpy_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *alpha) +static void daxpy_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT alpha) { BLASLONG register i = 0; - FLOAT a = *alpha; while(i < n) { - y[i] += a * x[i]; - y[i+1] += a * x[i+1]; - y[i+2] += a * x[i+2]; - y[i+3] += a * x[i+3]; - y[i+4] += a * x[i+4]; - y[i+5] += a * x[i+5]; - y[i+6] += a * x[i+6]; - y[i+7] += a * x[i+7]; + y[i] += alpha * x[i]; + y[i+1] += alpha * x[i+1]; + y[i+2] += alpha * x[i+2]; + y[i+3] += alpha * x[i+3]; + y[i+4] += alpha * x[i+4]; + y[i+5] += alpha * x[i+5]; + y[i+6] += alpha * x[i+6]; + y[i+7] += alpha * x[i+7]; i+=8 ; } @@ -70,11 +69,6 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, BLAS { BLASLONG i=0; BLASLONG ix=0,iy=0; - FLOAT a2[4]; - a2[0]=da; - a2[1]=da; - a2[2]=da; - a2[3]=da; if ( n <= 0 ) return(0); @@ -84,7 +78,7 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, BLAS BLASLONG n1 = n & -16; if ( n1 ) - daxpy_kernel_8(n1, x, y , a2 ); + daxpy_kernel_8(n1, x, y, da); i = n1; while(i < n) diff --git a/kernel/power/daxpy_microk_power8.c b/kernel/power/daxpy_microk_power8.c index bb3f73aca5..fb714a3f90 100644 --- a/kernel/power/daxpy_microk_power8.c +++ b/kernel/power/daxpy_microk_power8.c @@ -35,167 +35,183 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_8 1 -static void daxpy_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y , FLOAT *alpha) __attribute__ ((noinline)); -static void daxpy_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *alpha) +static void daxpy_kernel_8 (long n, double *x, double *y, double alpha) { + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + __vector double t4; + __vector double t5; + __vector double t6; + __vector double t7; + __vector double t8; + __vector double t9; + __vector double t10; + __vector double t11; + __vector double t12; + __vector double t13; + __vector double t14; + __vector double t15; + __vector double t16; + __asm__ + ( + "xxspltd %x4, %x22, 0 \n\t" - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *y2=y+1; - BLASLONG pre = 384; + "dcbt 0, %2 \n\t" + "dcbt 0, %3 \n\t" - __asm__ __volatile__ - ( + "lxvd2x %x5, 0, %2 \n\t" + "lxvd2x %x6, %23, %2 \n\t" + "lxvd2x %x7, %24, %2 \n\t" + "lxvd2x %x8, %25, %2 \n\t" - "lxsdx 33, %5, %4 \n\t" - "xxspltd 32, 33, 0 \n\t" - "addi %8, %8, -8 \n\t" + "lxvd2x %x13, 0, %3 \n\t" + "lxvd2x %x14, %23, %3 \n\t" + "lxvd2x %x15, %24, %3 \n\t" + "lxvd2x %x16, %25, %3 \n\t" - "dcbt %2, %9 \n\t" - "dcbt %3, %9 \n\t" + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" + "lxvd2x %x9, 0, %2 \n\t" + "lxvd2x %x10, %23, %2 \n\t" + "lxvd2x %x11, %24, %2 \n\t" + "lxvd2x %x12, %25, %2 \n\t" - "lxvd2x 48, 0, %3 \n\t" - "lxvd2x 49, %5, %3 \n\t" - "lxvd2x 50, %6, %3 \n\t" - "lxvd2x 51, %7, %3 \n\t" - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "lxvd2x 44, 0, %2 \n\t" - "lxvd2x 45, %5, %2 \n\t" - "lxvd2x 46, %6, %2 \n\t" - "lxvd2x 47, %7, %2 \n\t" - - "lxvd2x 52, 0, %3 \n\t" - "lxvd2x 53, %5, %3 \n\t" - "lxvd2x 54, %6, %3 \n\t" - "lxvd2x 55, %7, %3 \n\t" - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %9 \n\t" - "dcbt %3, %9 \n\t" - - "xvmaddadp 48, 40, 32 \n\t" - "xvmaddadp 49, 41, 32 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - - "stxvd2x 48, 0, %8 \n\t" - "stxvd2x 49, %5, %8 \n\t" - - "xvmaddadp 50, 42, 32 \n\t" - "xvmaddadp 51, 43, 32 \n\t" - - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" - - "lxvd2x 48, 0, %3 \n\t" - "lxvd2x 49, %5, %3 \n\t" - "lxvd2x 50, %6, %3 \n\t" - "lxvd2x 51, %7, %3 \n\t" - - "addi %2, %2, 64 \n\t" - "addi %8, %8, 64 \n\t" - - "xvmaddadp 52, 44, 32 \n\t" - "addi %3, %3, 64 \n\t" - "xvmaddadp 53, 45, 32 \n\t" - - "lxvd2x 44, 0, %2 \n\t" - "lxvd2x 45, %5, %2 \n\t" - - "stxvd2x 52, 0, %8 \n\t" - "stxvd2x 53, %5, %8 \n\t" - - "xvmaddadp 54, 46, 32 \n\t" - "xvmaddadp 55, 47, 32 \n\t" - - "lxvd2x 46, %6, %2 \n\t" - "lxvd2x 47, %7, %2 \n\t" - - "stxvd2x 54, %6, %8 \n\t" - "stxvd2x 55, %7, %8 \n\t" - - "addi %2, %2, 64 \n\t" - "addi %8, %8, 64 \n\t" - - "lxvd2x 52, 0, %3 \n\t" - "lxvd2x 53, %5, %3 \n\t" - "lxvd2x 54, %6, %3 \n\t" - "lxvd2x 55, %7, %3 \n\t" - - "addi %3, %3, 64 \n\t" - - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - - "xvmaddadp 48, 40, 32 \n\t" - "xvmaddadp 49, 41, 32 \n\t" - "xvmaddadp 50, 42, 32 \n\t" - "xvmaddadp 51, 43, 32 \n\t" - - "xvmaddadp 52, 44, 32 \n\t" - "xvmaddadp 53, 45, 32 \n\t" - "xvmaddadp 54, 46, 32 \n\t" - "xvmaddadp 55, 47, 32 \n\t" - - "stxvd2x 48, 0, %8 \n\t" - "stxvd2x 49, %5, %8 \n\t" - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - "stxvd2x 52, 0, %8 \n\t" - "stxvd2x 53, %5, %8 \n\t" - "stxvd2x 54, %6, %8 \n\t" - "stxvd2x 55, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (y1), // 3 - "r" (alpha), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (y2), // 8 - "r" (pre) // 9 - : "cr0", "%0", "%2" , "%3", "%8", "memory" - ); - -} + "lxvd2x %x17, 0, %3 \n\t" + "lxvd2x %x18, %23, %3 \n\t" + "lxvd2x %x19, %24, %3 \n\t" + "lxvd2x %x20, %25, %3 \n\t" + + "addi %2, %2, 64 \n\t" + "addi %3, %3, -64 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".align 5 \n" + "1: \n\t" + + "xvmaddadp %x13, %x5, %x4 \n\t" + "xvmaddadp %x14, %x6, %x4 \n\t" + + "lxvd2x %x5, 0, %2 \n\t" + "lxvd2x %x6, %23, %2 \n\t" + + "stxvd2x %x13, 0, %3 \n\t" + "stxvd2x %x14, %23, %3 \n\t" + + "xvmaddadp %x15, %x7, %x4 \n\t" + "xvmaddadp %x16, %x8, %x4 \n\t" + + "lxvd2x %x7, %24, %2 \n\t" + "lxvd2x %x8, %25, %2 \n\t" + + "stxvd2x %x15, %24, %3 \n\t" + "stxvd2x %x16, %25, %3 \n\t" + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 128 \n\t" + + "lxvd2x %x13, 0, %3 \n\t" + "lxvd2x %x14, %23, %3 \n\t" + "lxvd2x %x15, %24, %3 \n\t" + "lxvd2x %x16, %25, %3 \n\t" + + "addi %3, %3, -64 \n\t" + + "xvmaddadp %x17, %x9, %x4 \n\t" + "xvmaddadp %x18, %x10, %x4 \n\t" + + "lxvd2x %x9, 0, %2 \n\t" + "lxvd2x %x10, %23, %2 \n\t" + + "stxvd2x %x17, 0, %3 \n\t" + "stxvd2x %x18, %23, %3 \n\t" + + "xvmaddadp %x19, %x11, %x4 \n\t" + "xvmaddadp %x20, %x12, %x4 \n\t" + + "lxvd2x %x11, %24, %2 \n\t" + "lxvd2x %x12, %25, %2 \n\t" + + "stxvd2x %x19, %24, %3 \n\t" + "stxvd2x %x20, %25, %3 \n\t" + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 128 \n\t" + + "lxvd2x %x17, 0, %3 \n\t" + "lxvd2x %x18, %23, %3 \n\t" + "lxvd2x %x19, %24, %3 \n\t" + "lxvd2x %x20, %25, %3 \n\t" + + "addi %3, %3, -64 \n\t" + + "addic. %1, %1, -16 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmaddadp %x13, %x5, %x4 \n\t" + "xvmaddadp %x14, %x6, %x4 \n\t" + "xvmaddadp %x15, %x7, %x4 \n\t" + "xvmaddadp %x16, %x8, %x4 \n\t" + + "xvmaddadp %x17, %x9, %x4 \n\t" + "xvmaddadp %x18, %x10, %x4 \n\t" + "xvmaddadp %x19, %x11, %x4 \n\t" + "xvmaddadp %x20, %x12, %x4 \n\t" + + "stxvd2x %x13, 0, %3 \n\t" + "stxvd2x %x14, %23, %3 \n\t" + "stxvd2x %x15, %24, %3 \n\t" + "stxvd2x %x16, %25, %3 \n\t" + + "addi %3, %3, 64 \n\t" + + "stxvd2x %x17, 0, %3 \n\t" + "stxvd2x %x18, %23, %3 \n\t" + "stxvd2x %x19, %24, %3 \n\t" + "stxvd2x %x20, %25, %3 \n" + + "#n=%1 x=%21=%2 y=%0=%3 alpha=%22 o16=%23 o32=%24 o48=%25\n" + "#t0=%x4 t1=%x5 t2=%x6 t3=%x7 t4=%x8 t5=%x9 t6=%x10 t7=%x11 t8=%x12 t9=%x13 t10=%x14 t11=%x15 t12=%x16 t13=%x17 t14=%x18 t15=%x19 t16=%x20" + : + "+m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y), // 3 + "=wa" (t0), // 4 + "=wa" (t1), // 5 + "=wa" (t2), // 6 + "=wa" (t3), // 7 + "=wa" (t4), // 8 + "=wa" (t5), // 9 + "=wa" (t6), // 10 + "=wa" (t7), // 11 + "=wa" (t8), // 12 + "=wa" (t9), // 13 + "=wa" (t10), // 14 + "=wa" (t11), // 15 + "=wa" (t12), // 16 + "=wa" (t13), // 17 + "=wa" (t14), // 18 + "=wa" (t15), // 19 + "=wa" (t16) // 20 + : + "m" (*x), + "d" (alpha), // 22 + "b" (16), // 23 + "b" (32), // 24 + "b" (48) // 25 + : + "cr0" + ); + +} diff --git a/kernel/power/dcopy_microk_power8.c b/kernel/power/dcopy_microk_power8.c index 04f7db5560..261dc04de1 100644 --- a/kernel/power/dcopy_microk_power8.c +++ b/kernel/power/dcopy_microk_power8.c @@ -35,140 +35,121 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void dcopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void dcopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void dcopy_kernel_32 (long n, double *x, double *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 50, 0, %2 \n\t" - "lxvd2x 51, %5, %2 \n\t" - "lxvd2x 52, %6, %2 \n\t" - "lxvd2x 53, %7, %2 \n\t" - "lxvd2x 54, %8, %2 \n\t" - "lxvd2x 55, %9, %2 \n\t" - "lxvd2x 56, %10, %2 \n\t" - "lxvd2x 57, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "stxvd2x 40, 0, %1 \n\t" - "stxvd2x 41, %5, %1 \n\t" - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "stxvd2x 42, %6, %1 \n\t" - "stxvd2x 43, %7, %1 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "stxvd2x 44, %8, %1 \n\t" - "stxvd2x 45, %9, %1 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "stxvd2x 46, %10, %1 \n\t" - "stxvd2x 47, %11, %1 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "stxvd2x 50, 0, %1 \n\t" - "stxvd2x 51, %5, %1 \n\t" - "lxvd2x 50, 0, %2 \n\t" - "lxvd2x 51, %5, %2 \n\t" - "stxvd2x 52, %6, %1 \n\t" - "stxvd2x 53, %7, %1 \n\t" - "lxvd2x 52, %6, %2 \n\t" - "lxvd2x 53, %7, %2 \n\t" - "stxvd2x 54, %8, %1 \n\t" - "stxvd2x 55, %9, %1 \n\t" - "lxvd2x 54, %8, %2 \n\t" - "lxvd2x 55, %9, %2 \n\t" - "stxvd2x 56, %10, %1 \n\t" - "stxvd2x 57, %11, %1 \n\t" - "lxvd2x 56, %10, %2 \n\t" - "lxvd2x 57, %11, %2 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "stxvd2x 40, 0, %1 \n\t" - "stxvd2x 41, %5, %1 \n\t" - "stxvd2x 42, %6, %1 \n\t" - "stxvd2x 43, %7, %1 \n\t" - "stxvd2x 44, %8, %1 \n\t" - "stxvd2x 45, %9, %1 \n\t" - "stxvd2x 46, %10, %1 \n\t" - "stxvd2x 47, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvd2x 50, 0, %1 \n\t" - "stxvd2x 51, %5, %1 \n\t" - "stxvd2x 52, %6, %1 \n\t" - "stxvd2x 53, %7, %1 \n\t" - "stxvd2x 54, %8, %1 \n\t" - "stxvd2x 55, %9, %1 \n\t" - "stxvd2x 56, %10, %1 \n\t" - "stxvd2x 57, %11, %1 \n\t" - - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __asm__ + ( + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n" + + "#n=%1 x=%4=%2 y=%0=%3 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "=m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y) // 3 + : + "m" (*x), + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/ddot.c b/kernel/power/ddot.c index cef60a2e53..e43470e23d 100644 --- a/kernel/power/ddot.c +++ b/kernel/power/ddot.c @@ -43,7 +43,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_8 -static void ddot_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) +static FLOAT ddot_kernel_8 (BLASLONG n, FLOAT *x, FLOAT *y) { BLASLONG register i = 0; FLOAT dot = 0.0; @@ -62,8 +62,7 @@ static void ddot_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) i+=8 ; } - *d += dot; - + return dot; } #endif @@ -83,7 +82,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) BLASLONG n1 = n & -16; if ( n1 ) - ddot_kernel_8(n1, x, y , &dot ); + dot = ddot_kernel_8(n1, x, y); i = n1; while(i < n) diff --git a/kernel/power/ddot_microk_power8.c b/kernel/power/ddot_microk_power8.c index b880492123..4e6bc29c9d 100644 --- a/kernel/power/ddot_microk_power8.c +++ b/kernel/power/ddot_microk_power8.c @@ -34,145 +34,138 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_8 1 -static void ddot_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y , FLOAT *dot) __attribute__ ((noinline)); -static void ddot_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *dot) +static double ddot_kernel_8 (long n, double *x, double *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "dcbt %2, %12 \n\t" - "dcbt %3, %12 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 48, 0, %3 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 49, %5, %3 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 50, %6, %3 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 51, %7, %3 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 52, %8, %3 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 53, %9, %3 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 54, %10, %3 \n\t" - "lxvd2x 47, %11, %2 \n\t" - "lxvd2x 55, %11, %3 \n\t" - - "addi %2, %2, 128 \n\t" - "addi %3, %3, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %12 \n\t" - "dcbt %3, %12 \n\t" - - "xvmaddadp 32, 40, 48 \n\t" - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 48, 0, %3 \n\t" - "xvmaddadp 33, 41, 49 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 49, %5, %3 \n\t" - "xvmaddadp 34, 42, 50 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 50, %6, %3 \n\t" - "xvmaddadp 35, 43, 51 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 51, %7, %3 \n\t" - "xvmaddadp 36, 44, 52 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 52, %8, %3 \n\t" - "xvmaddadp 37, 45, 53 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 53, %9, %3 \n\t" - "xvmaddadp 38, 46, 54 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 54, %10, %3 \n\t" - "xvmaddadp 39, 47, 55 \n\t" - - "lxvd2x 47, %11, %2 \n\t" - "lxvd2x 55, %11, %3 \n\t" - - - "addi %2, %2, 128 \n\t" - "addi %3, %3, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmaddadp 32, 40, 48 \n\t" - "xvmaddadp 33, 41, 49 \n\t" - "xvmaddadp 34, 42, 50 \n\t" - "xvmaddadp 35, 43, 51 \n\t" - "xvmaddadp 36, 44, 52 \n\t" - "xvmaddadp 37, 45, 53 \n\t" - "xvmaddadp 38, 46, 54 \n\t" - "xvmaddadp 39, 47, 55 \n\t" - - "xvadddp 32, 32, 33 \n\t" - "xvadddp 34, 34, 35 \n\t" - "xvadddp 36, 36, 37 \n\t" - "xvadddp 38, 38, 39 \n\t" - - "xvadddp 32, 32, 34 \n\t" - "xvadddp 36, 36, 38 \n\t" - - "xvadddp 32, 32, 36 \n\t" - - "xxswapd 33, 32 \n\t" - - "xsadddp 32, 32, 33 \n\t" - - "stxsdx 32, 0, %4 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (y1), // 3 - "r" (dot), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112), // 11 - "r" (pre) // 12 - : "cr0", "%0", "%2" , "%3", "memory" - ); - -} - - + double dot; + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + "dcbt 0, %3 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 48, 0, %3 \n\t" + "lxvd2x 41, %10, %2 \n\t" + "lxvd2x 49, %10, %3 \n\t" + "lxvd2x 42, %11, %2 \n\t" + "lxvd2x 50, %11, %3 \n\t" + "lxvd2x 43, %12, %2 \n\t" + "lxvd2x 51, %12, %3 \n\t" + "lxvd2x 44, %13, %2 \n\t" + "lxvd2x %x4, %13, %3 \n\t" + "lxvd2x 45, %14, %2 \n\t" + "lxvd2x %x5, %14, %3 \n\t" + "lxvd2x 46, %15, %2 \n\t" + "lxvd2x %x6, %15, %3 \n\t" + "lxvd2x 47, %16, %2 \n\t" + "lxvd2x %x7, %16, %3 \n\t" + + "addi %2, %2, 128 \n\t" + "addi %3, %3, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmaddadp 32, 40, 48 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 48, 0, %3 \n\t" + "xvmaddadp 33, 41, 49 \n\t" + "lxvd2x 41, %10, %2 \n\t" + "lxvd2x 49, %10, %3 \n\t" + "xvmaddadp 34, 42, 50 \n\t" + "lxvd2x 42, %11, %2 \n\t" + "lxvd2x 50, %11, %3 \n\t" + "xvmaddadp 35, 43, 51 \n\t" + "lxvd2x 43, %12, %2 \n\t" + "lxvd2x 51, %12, %3 \n\t" + "xvmaddadp 36, 44, %x4 \n\t" + "lxvd2x 44, %13, %2 \n\t" + "lxvd2x %x4, %13, %3 \n\t" + "xvmaddadp 37, 45, %x5 \n\t" + "lxvd2x 45, %14, %2 \n\t" + "lxvd2x %x5, %14, %3 \n\t" + "xvmaddadp 38, 46, %x6 \n\t" + "lxvd2x 46, %15, %2 \n\t" + "lxvd2x %x6, %15, %3 \n\t" + "xvmaddadp 39, 47, %x7 \n\t" + "lxvd2x 47, %16, %2 \n\t" + "lxvd2x %x7, %16, %3 \n\t" + + "addi %2, %2, 128 \n\t" + "addi %3, %3, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmaddadp 32, 40, 48 \n\t" + "xvmaddadp 33, 41, 49 \n\t" + "xvmaddadp 34, 42, 50 \n\t" + "xvmaddadp 35, 43, 51 \n\t" + "xvmaddadp 36, 44, %x4 \n\t" + "xvmaddadp 37, 45, %x5 \n\t" + "xvmaddadp 38, 46, %x6 \n\t" + "xvmaddadp 39, 47, %x7 \n\t" + + "xvadddp 32, 32, 33 \n\t" + "xvadddp 34, 34, 35 \n\t" + "xvadddp 36, 36, 37 \n\t" + "xvadddp 38, 38, 39 \n\t" + + "xvadddp 32, 32, 34 \n\t" + "xvadddp 36, 36, 38 \n\t" + + "xvadddp 32, 32, 36 \n\t" + + "xxswapd 33, 32 \n\t" + + "xsadddp %x0, 32, 33 \n" + + "#dot=%0 n=%1 x=%8=%2 y=%9=%3 o16=%10 o32=%11 o48=%12 o64=%13 o80=%14 o96=%15 o122=%16\n" + "#t0=%x4 t1=%x5 t2=%x6 t3=%x7" + : + "=d" (dot), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y), // 3 + "=wa" (t0), // 4 + "=wa" (t1), // 5 + "=wa" (t2), // 6 + "=wa" (t3) // 7 + : + "m" (*x), + "m" (*y), + "b" (16), // 10 + "b" (32), // 11 + "b" (48), // 12 + "b" (64), // 13 + "b" (80), // 14 + "b" (96), // 15 + "b" (112) // 16 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return dot; +} diff --git a/kernel/power/dgemv_n.c b/kernel/power/dgemv_n.c index 812d09d15f..57f9f9e728 100644 --- a/kernel/power/dgemv_n.c +++ b/kernel/power/dgemv_n.c @@ -47,18 +47,18 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_4x4 -static void dgemv_kernel_4x4(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT *alpha) +static void dgemv_kernel_4x4(BLASLONG n, FLOAT *a_ptr, BLASLONG lda, FLOAT *xo, FLOAT *y, FLOAT alpha) { BLASLONG i; - FLOAT *a0,*a1,*a2,*a3; FLOAT x[4] __attribute__ ((aligned (16)));; - a0 = ap[0]; - a1 = ap[1]; - a2 = ap[2]; - a3 = ap[3]; + FLOAT *a0 = a_ptr; + FLOAT *a1 = a0 + lda; + FLOAT *a2 = a1 + lda; + FLOAT *a3 = a2 + lda; + for ( i=0; i<4; i++) - x[i] = xo[i] * *alpha; + x[i] = xo[i] * alpha; for ( i=0; i< n; i+=4 ) { @@ -73,16 +73,13 @@ static void dgemv_kernel_4x4(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT #ifndef HAVE_KERNEL_4x2 -static void dgemv_kernel_4x2(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT *alpha) +static void dgemv_kernel_4x2(BLASLONG n, FLOAT *a0, FLOAT *a1, FLOAT *xo, FLOAT *y, FLOAT alpha) { BLASLONG i; - FLOAT *a0,*a1; FLOAT x[4] __attribute__ ((aligned (16)));; - a0 = ap[0]; - a1 = ap[1]; for ( i=0; i<2; i++) - x[i] = xo[i] * *alpha; + x[i] = xo[i] * alpha; for ( i=0; i< n; i+=4 ) { @@ -98,15 +95,13 @@ static void dgemv_kernel_4x2(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT #ifndef HAVE_KERNEL_4x1 -static void dgemv_kernel_4x1(BLASLONG n, FLOAT *ap, FLOAT *xo, FLOAT *y, FLOAT *alpha) +static void dgemv_kernel_4x1(BLASLONG n, FLOAT *a0, FLOAT *xo, FLOAT *y, FLOAT alpha) { BLASLONG i; - FLOAT *a0; FLOAT x[4] __attribute__ ((aligned (16)));; - a0 = ap; for ( i=0; i<1; i++) - x[i] = xo[i] * *alpha; + x[i] = xo[i] * alpha; for ( i=0; i< n; i+=4 ) { @@ -141,7 +136,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO { BLASLONG i; - BLASLONG j; FLOAT *a_ptr; FLOAT *x_ptr; FLOAT *y_ptr; @@ -151,13 +145,9 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO BLASLONG m3; BLASLONG n2; BLASLONG lda4 = lda << 2; - FLOAT *ap[4] __attribute__ ((aligned (16)));; FLOAT xbuffer[8] __attribute__ ((aligned (16)));; - FLOAT alpha_r[4] __attribute__ ((aligned (16)));; FLOAT *ybuffer; - alpha_r[0] = alpha; - if ( m < 1 ) return(0); if ( n < 1 ) return(0); @@ -187,11 +177,6 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO a_ptr = a; x_ptr = x; - ap[0] = a_ptr; - ap[1] = a_ptr + lda; - ap[2] = ap[1] + lda; - ap[3] = ap[2] + lda; - if ( inc_y != 1 ) memset(ybuffer,0,NB*8); else @@ -203,18 +188,14 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO for( i = 0; i < n1 ; i++) { - dgemv_kernel_4x4(NB,ap,x_ptr,ybuffer,alpha_r); - ap[0] += lda4; - ap[1] += lda4; - ap[2] += lda4; - ap[3] += lda4; + dgemv_kernel_4x4(NB,a_ptr,lda,x_ptr,ybuffer,alpha); a_ptr += lda4; x_ptr += 4; } if ( n2 & 2 ) { - dgemv_kernel_4x2(NB,ap,x_ptr,ybuffer,alpha_r); + dgemv_kernel_4x2(NB,a_ptr,a_ptr+lda,x_ptr,ybuffer,alpha); a_ptr += lda*2; x_ptr += 2; } @@ -222,7 +203,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO if ( n2 & 1 ) { - dgemv_kernel_4x1(NB,a_ptr,x_ptr,ybuffer,alpha_r); + dgemv_kernel_4x1(NB,a_ptr,x_ptr,ybuffer,alpha); a_ptr += lda; x_ptr += 1; @@ -243,11 +224,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO x_ptr += inc_x; xbuffer[3] = x_ptr[0]; x_ptr += inc_x; - dgemv_kernel_4x4(NB,ap,xbuffer,ybuffer,alpha_r); - ap[0] += lda4; - ap[1] += lda4; - ap[2] += lda4; - ap[3] += lda4; + dgemv_kernel_4x4(NB,a_ptr,lda,xbuffer,ybuffer,alpha); a_ptr += lda4; } @@ -255,7 +232,7 @@ int CNAME(BLASLONG m, BLASLONG n, BLASLONG dummy1, FLOAT alpha, FLOAT *a, BLASLO { xbuffer[0] = x_ptr[0]; x_ptr += inc_x; - dgemv_kernel_4x1(NB,a_ptr,xbuffer,ybuffer,alpha_r); + dgemv_kernel_4x1(NB,a_ptr,xbuffer,ybuffer,alpha); a_ptr += lda; } diff --git a/kernel/power/dgemv_n_microk_power8.c b/kernel/power/dgemv_n_microk_power8.c index 9eabe555cc..ae4fe90091 100644 --- a/kernel/power/dgemv_n_microk_power8.c +++ b/kernel/power/dgemv_n_microk_power8.c @@ -35,267 +35,265 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_4x4 1 -static void dgemv_kernel_4x4(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT *alpha) __attribute__ ((noinline)); - -static void dgemv_kernel_4x4(BLASLONG n, FLOAT **ap, FLOAT *xo, FLOAT *y, FLOAT *alpha) +static void dgemv_kernel_4x4 (long n, double *ap, long lda, double *x, double *y, double alpha) { - BLASLONG i=n; - BLASLONG o8 = 8; - BLASLONG o16 = 16; - BLASLONG o24 = 24; - BLASLONG pre = 384; - - FLOAT *a0,*a1,*a2,*a3; - FLOAT *y1=y+1; - FLOAT x[4] __attribute__ ((aligned (16)));; - a0 = ap[0]+1; - a1 = ap[1]+1; - a2 = ap[2]+1; - a3 = ap[3]+1; - - x[0]=xo[0] * *alpha; - x[1]=xo[1] * *alpha; - x[2]=xo[2] * *alpha; - x[3]=xo[3] * *alpha; + double *a0; + double *a1; + double *a2; + double *a3; + + __asm__ + ( + "lxvd2x 34, 0, %10 \n\t" // x0, x1 + "lxvd2x 35, %11, %10 \n\t" // x2, x3 + "xxspltd 32, %x9, 0 \n\t" // alpha, alpha + + "sldi %6, %13, 3 \n\t" // lda * sizeof (double) + + "xvmuldp 34, 34, 32 \n\t" // x0 * alpha, x1 * alpha + "xvmuldp 35, 35, 32 \n\t" // x2 * alpha, x3 * alpha + + "add %4, %3, %6 \n\t" // a0 = ap, a1 = a0 + lda + "add %6, %6, %6 \n\t" // 2 * lda + + "xxspltd 32, 34, 0 \n\t" // x0 * alpha, x0 * alpha + "xxspltd 33, 34, 1 \n\t" // x1 * alpha, x1 * alpha + "xxspltd 34, 35, 0 \n\t" // x2 * alpha, x2 * alpha + "xxspltd 35, 35, 1 \n\t" // x3 * alpha, x3 * alpha + + "add %5, %3, %6 \n\t" // a2 = a0 + 2 * lda + "add %6, %4, %6 \n\t" // a3 = a1 + 2 * lda + + "dcbt 0, %3 \n\t" + "dcbt 0, %4 \n\t" + "dcbt 0, %5 \n\t" + "dcbt 0, %6 \n\t" + "lxvd2x 40, 0, %3 \n\t" // a0[0], a0[1] + "lxvd2x 41, %11, %3 \n\t" // a0[2], a0[3] - __asm__ __volatile__ - ( - "lxvdsx 32, 0 , %1 \n\t" // x0 - "lxvdsx 33,%3 , %1 \n\t" // x1 - "lxvdsx 34,%4 , %1 \n\t" // x2 - "lxvdsx 35,%5 , %1 \n\t" // x3 - "addi %2 , %2 , -8 \n\t" - "addi %6 , %6 , -8 \n\t" - "addi %7 , %7 , -8 \n\t" - "addi %8 , %8 , -8 \n\t" - "addi %9 , %9 , -8 \n\t" - - "lxvd2x 48, 0, %6 \n\t" // a0[0], a0[1] - "lxvd2x 49,%4, %6 \n\t" // a0[2], a0[3] - - "lxvd2x 50, 0, %7 \n\t" // a1[0], a1[1] - "lxvd2x 51,%4, %7 \n\t" // a1[2], a1[3] + "lxvd2x 42, 0, %4 \n\t" // a1[0], a1[1] + "lxvd2x 43, %11, %4 \n\t" // a1[2], a1[3] - "lxvd2x 52, 0, %8 \n\t" // a2[0], a2[1] - "lxvd2x 53,%4, %8 \n\t" // a2[2], a2[3] + "lxvd2x 44, 0, %5 \n\t" // a2[0], a2[1] + "lxvd2x 45, %11, %5 \n\t" // a2[2], a2[3] - "lxvd2x 54, 0, %9 \n\t" // a3[0], a3[1] - "lxvd2x 55,%4, %9 \n\t" // a3[2], a3[3] + "lxvd2x 46, 0, %6 \n\t" // a3[0], a3[1] + "lxvd2x 47, %11, %6 \n\t" // a3[2], a3[3] - "addi %6, %6, 32 \n\t" - "addi %7, %7, 32 \n\t" - "addi %8, %8, 32 \n\t" - "addi %9, %9, 32 \n\t" + "dcbt 0, %2 \n\t" - "addic. %0 , %0 , -4 \n\t" - "ble 2f \n\t" + "addi %3, %3, 32 \n\t" + "addi %4, %4, 32 \n\t" + "addi %5, %5, 32 \n\t" + "addi %6, %6, 32 \n\t" - ".align 5 \n\t" - "1: \n\t" + "addic. %1, %1, -4 \n\t" + "ble 2f \n\t" - "dcbt %2, %10 \n\t" + ".p2align 5 \n" + "1: \n\t" - "lxvd2x 40, 0, %2 \n\t" // y0, y1 - "lxvd2x 41,%4, %2 \n\t" // y2, y3 - - "dcbt %6, %10 \n\t" - "dcbt %7, %10 \n\t" - "dcbt %8, %10 \n\t" - "dcbt %9, %10 \n\t" + "lxvd2x 36, 0, %2 \n\t" // y0, y1 + "lxvd2x 37, %11, %2 \n\t" // y2, y3 - "xvmaddadp 40, 48, 32 \n\t" - "xvmaddadp 41, 49, 32 \n\t" + "xvmaddadp 36, 40, 32 \n\t" + "xvmaddadp 37, 41, 32 \n\t" - "lxvd2x 48, 0, %6 \n\t" // a0[0], a0[1] - "lxvd2x 49,%4, %6 \n\t" // a0[2], a0[3] + "lxvd2x 40, 0, %3 \n\t" // a0[0], a0[1] + "lxvd2x 41, %11, %3 \n\t" // a0[2], a0[3] - "xvmaddadp 40, 50, 33 \n\t" - "addi %6, %6, 32 \n\t" - "xvmaddadp 41, 51, 33 \n\t" + "xvmaddadp 36, 42, 33 \n\t" + "addi %3, %3, 32 \n\t" + "xvmaddadp 37, 43, 33 \n\t" - "lxvd2x 50, 0, %7 \n\t" // a1[0], a1[1] - "lxvd2x 51,%4, %7 \n\t" // a1[2], a1[3] + "lxvd2x 42, 0, %4 \n\t" // a1[0], a1[1] + "lxvd2x 43, %11, %4 \n\t" // a1[2], a1[3] - "xvmaddadp 40, 52, 34 \n\t" - "addi %7, %7, 32 \n\t" - "xvmaddadp 41, 53, 34 \n\t" + "xvmaddadp 36, 44, 34 \n\t" + "addi %4, %4, 32 \n\t" + "xvmaddadp 37, 45, 34 \n\t" - "lxvd2x 52, 0, %8 \n\t" // a2[0], a2[1] - "lxvd2x 53,%4, %8 \n\t" // a2[2], a2[3] + "lxvd2x 44, 0, %5 \n\t" // a2[0], a2[1] + "lxvd2x 45, %11, %5 \n\t" // a2[2], a2[3] - "xvmaddadp 40, 54, 35 \n\t" - "addi %8, %8, 32 \n\t" - "xvmaddadp 41, 55, 35 \n\t" + "xvmaddadp 36, 46, 35 \n\t" + "addi %5, %5, 32 \n\t" + "xvmaddadp 37, 47, 35 \n\t" - "stxvd2x 40, 0, %2 \n\t" // y0, y1 - "stxvd2x 41,%4, %2 \n\t" // y2, y3 + "stxvd2x 36, 0, %2 \n\t" // y0, y1 + "stxvd2x 37, %11, %2 \n\t" // y2, y3 - "lxvd2x 54, 0, %9 \n\t" // a3[0], a3[1] - "lxvd2x 55,%4, %9 \n\t" // a3[2], a3[3] + "lxvd2x 46, 0, %6 \n\t" // a3[0], a3[1] + "lxvd2x 47, %11, %6 \n\t" // a3[2], a3[3] - "addi %9, %9, 32 \n\t" - "addi %2, %2, 32 \n\t" + "addi %6, %6, 32 \n\t" + "addi %2, %2, 32 \n\t" - "addic. %0 , %0 , -4 \n\t" - "ble 2f \n\t" + "addic. %1, %1, -4 \n\t" + "ble 2f \n\t" - "lxvd2x 40, 0, %2 \n\t" // y0, y1 - "lxvd2x 41,%4, %2 \n\t" // y2, y3 - - "xvmaddadp 40, 48, 32 \n\t" - "xvmaddadp 41, 49, 32 \n\t" + "lxvd2x 36, 0, %2 \n\t" // y0, y1 + "lxvd2x 37, %11, %2 \n\t" // y2, y3 - "lxvd2x 48, 0, %6 \n\t" // a0[0], a0[1] - "lxvd2x 49,%4, %6 \n\t" // a0[2], a0[3] + "xvmaddadp 36, 40, 32 \n\t" + "xvmaddadp 37, 41, 32 \n\t" - "xvmaddadp 40, 50, 33 \n\t" - "addi %6, %6, 32 \n\t" - "xvmaddadp 41, 51, 33 \n\t" + "lxvd2x 40, 0, %3 \n\t" // a0[0], a0[1] + "lxvd2x 41, %11, %3 \n\t" // a0[2], a0[3] - "lxvd2x 50, 0, %7 \n\t" // a1[0], a1[1] - "lxvd2x 51,%4, %7 \n\t" // a1[2], a1[3] + "xvmaddadp 36, 42, 33 \n\t" + "addi %3, %3, 32 \n\t" + "xvmaddadp 37, 43, 33 \n\t" - "xvmaddadp 40, 52, 34 \n\t" - "addi %7, %7, 32 \n\t" - "xvmaddadp 41, 53, 34 \n\t" + "lxvd2x 42, 0, %4 \n\t" // a1[0], a1[1] + "lxvd2x 43, %11, %4 \n\t" // a1[2], a1[3] - "lxvd2x 52, 0, %8 \n\t" // a2[0], a2[1] - "lxvd2x 53,%4, %8 \n\t" // a2[2], a2[3] + "xvmaddadp 36, 44, 34 \n\t" + "addi %4, %4, 32 \n\t" + "xvmaddadp 37, 45, 34 \n\t" - "xvmaddadp 40, 54, 35 \n\t" - "addi %8, %8, 32 \n\t" - "xvmaddadp 41, 55, 35 \n\t" + "lxvd2x 44, 0, %5 \n\t" // a2[0], a2[1] + "lxvd2x 45, %11, %5 \n\t" // a2[2], a2[3] - "stxvd2x 40, 0, %2 \n\t" // y0, y1 - "stxvd2x 41,%4, %2 \n\t" // y2, y3 + "xvmaddadp 36, 46, 35 \n\t" + "addi %5, %5, 32 \n\t" + "xvmaddadp 37, 47, 35 \n\t" - "lxvd2x 54, 0, %9 \n\t" // a3[0], a3[1] - "lxvd2x 55,%4, %9 \n\t" // a3[2], a3[3] + "stxvd2x 36, 0, %2 \n\t" // y0, y1 + "stxvd2x 37, %11, %2 \n\t" // y2, y3 - "addi %9, %9, 32 \n\t" - "addi %2, %2, 32 \n\t" + "lxvd2x 46, 0, %6 \n\t" // a3[0], a3[1] + "lxvd2x 47, %11, %6 \n\t" // a3[2], a3[3] - "addic. %0 , %0 , -4 \n\t" - "ble 2f \n\t" + "addi %6, %6, 32 \n\t" + "addi %2, %2, 32 \n\t" + "addic. %1, %1, -4 \n\t" + "ble 2f \n\t" - "lxvd2x 40, 0, %2 \n\t" // y0, y1 - "lxvd2x 41,%4, %2 \n\t" // y2, y3 - - "xvmaddadp 40, 48, 32 \n\t" - "xvmaddadp 41, 49, 32 \n\t" - "lxvd2x 48, 0, %6 \n\t" // a0[0], a0[1] - "lxvd2x 49,%4, %6 \n\t" // a0[2], a0[3] + "lxvd2x 36, 0, %2 \n\t" // y0, y1 + "lxvd2x 37, %11, %2 \n\t" // y2, y3 - "xvmaddadp 40, 50, 33 \n\t" - "addi %6, %6, 32 \n\t" - "xvmaddadp 41, 51, 33 \n\t" + "xvmaddadp 36, 40, 32 \n\t" + "xvmaddadp 37, 41, 32 \n\t" - "lxvd2x 50, 0, %7 \n\t" // a1[0], a1[1] - "lxvd2x 51,%4, %7 \n\t" // a1[2], a1[3] + "lxvd2x 40, 0, %3 \n\t" // a0[0], a0[1] + "lxvd2x 41, %11, %3 \n\t" // a0[2], a0[3] - "xvmaddadp 40, 52, 34 \n\t" - "addi %7, %7, 32 \n\t" - "xvmaddadp 41, 53, 34 \n\t" + "xvmaddadp 36, 42, 33 \n\t" + "addi %3, %3, 32 \n\t" + "xvmaddadp 37, 43, 33 \n\t" - "lxvd2x 52, 0, %8 \n\t" // a2[0], a2[1] - "lxvd2x 53,%4, %8 \n\t" // a2[2], a2[3] + "lxvd2x 42, 0, %4 \n\t" // a1[0], a1[1] + "lxvd2x 43, %11, %4 \n\t" // a1[2], a1[3] - "xvmaddadp 40, 54, 35 \n\t" - "addi %8, %8, 32 \n\t" - "xvmaddadp 41, 55, 35 \n\t" + "xvmaddadp 36, 44, 34 \n\t" + "addi %4, %4, 32 \n\t" + "xvmaddadp 37, 45, 34 \n\t" - "stxvd2x 40, 0, %2 \n\t" // y0, y1 - "stxvd2x 41,%4, %2 \n\t" // y2, y3 + "lxvd2x 44, 0, %5 \n\t" // a2[0], a2[1] + "lxvd2x 45, %11, %5 \n\t" // a2[2], a2[3] - "lxvd2x 54, 0, %9 \n\t" // a3[0], a3[1] - "lxvd2x 55,%4, %9 \n\t" // a3[2], a3[3] + "xvmaddadp 36, 46, 35 \n\t" + "addi %5, %5, 32 \n\t" + "xvmaddadp 37, 47, 35 \n\t" - "addi %9, %9, 32 \n\t" - "addi %2, %2, 32 \n\t" + "stxvd2x 36, 0, %2 \n\t" // y0, y1 + "stxvd2x 37, %11, %2 \n\t" // y2, y3 - "addic. %0 , %0 , -4 \n\t" - "ble 2f \n\t" + "lxvd2x 46, 0, %6 \n\t" // a3[0], a3[1] + "lxvd2x 47, %11, %6 \n\t" // a3[2], a3[3] + "addi %6, %6, 32 \n\t" + "addi %2, %2, 32 \n\t" - "lxvd2x 40, 0, %2 \n\t" // y0, y1 - "lxvd2x 41,%4, %2 \n\t" // y2, y3 - - "xvmaddadp 40, 48, 32 \n\t" - "xvmaddadp 41, 49, 32 \n\t" + "addic. %1, %1, -4 \n\t" + "ble 2f \n\t" - "lxvd2x 48, 0, %6 \n\t" // a0[0], a0[1] - "lxvd2x 49,%4, %6 \n\t" // a0[2], a0[3] - "xvmaddadp 40, 50, 33 \n\t" - "addi %6, %6, 32 \n\t" - "xvmaddadp 41, 51, 33 \n\t" + "lxvd2x 36, 0, %2 \n\t" // y0, y1 + "lxvd2x 37, %11, %2 \n\t" // y2, y3 - "lxvd2x 50, 0, %7 \n\t" // a1[0], a1[1] - "lxvd2x 51,%4, %7 \n\t" // a1[2], a1[3] + "xvmaddadp 36, 40, 32 \n\t" + "xvmaddadp 37, 41, 32 \n\t" - "xvmaddadp 40, 52, 34 \n\t" - "addi %7, %7, 32 \n\t" - "xvmaddadp 41, 53, 34 \n\t" + "lxvd2x 40, 0, %3 \n\t" // a0[0], a0[1] + "lxvd2x 41, %11, %3 \n\t" // a0[2], a0[3] - "lxvd2x 52, 0, %8 \n\t" // a2[0], a2[1] - "lxvd2x 53,%4, %8 \n\t" // a2[2], a2[3] + "xvmaddadp 36, 42, 33 \n\t" + "addi %3, %3, 32 \n\t" + "xvmaddadp 37, 43, 33 \n\t" - "xvmaddadp 40, 54, 35 \n\t" - "addi %8, %8, 32 \n\t" - "xvmaddadp 41, 55, 35 \n\t" + "lxvd2x 42, 0, %4 \n\t" // a1[0], a1[1] + "lxvd2x 43, %11, %4 \n\t" // a1[2], a1[3] - "stxvd2x 40, 0, %2 \n\t" // y0, y1 - "stxvd2x 41,%4, %2 \n\t" // y2, y3 + "xvmaddadp 36, 44, 34 \n\t" + "addi %4, %4, 32 \n\t" + "xvmaddadp 37, 45, 34 \n\t" - "lxvd2x 54, 0, %9 \n\t" // a3[0], a3[1] - "lxvd2x 55,%4, %9 \n\t" // a3[2], a3[3] + "lxvd2x 44, 0, %5 \n\t" // a2[0], a2[1] + "lxvd2x 45, %11, %5 \n\t" // a2[2], a2[3] - "addi %9, %9, 32 \n\t" - "addi %2, %2, 32 \n\t" + "xvmaddadp 36, 46, 35 \n\t" + "addi %5, %5, 32 \n\t" + "xvmaddadp 37, 47, 35 \n\t" - "addic. %0 , %0 , -4 \n\t" - "bgt 1b \n\t" + "stxvd2x 36, 0, %2 \n\t" // y0, y1 + "stxvd2x 37, %11, %2 \n\t" // y2, y3 - "2: \n\t" + "lxvd2x 46, 0, %6 \n\t" // a3[0], a3[1] + "lxvd2x 47, %11, %6 \n\t" // a3[2], a3[3] - "lxvd2x 40, 0, %2 \n\t" // y0, y1 - "lxvd2x 41,%4, %2 \n\t" // y2, y3 + "addi %6, %6, 32 \n\t" + "addi %2, %2, 32 \n\t" - "xvmaddadp 40, 48, 32 \n\t" - "xvmaddadp 41, 49, 32 \n\t" + "addic. %1, %1, -4 \n\t" + "bgt 1b \n" - "xvmaddadp 40, 50, 33 \n\t" - "xvmaddadp 41, 51, 33 \n\t" + "2: \n\t" - "xvmaddadp 40, 52, 34 \n\t" - "xvmaddadp 41, 53, 34 \n\t" + "lxvd2x 36, 0, %2 \n\t" // y0, y1 + "lxvd2x 37, %11, %2 \n\t" // y2, y3 - "xvmaddadp 40, 54, 35 \n\t" - "xvmaddadp 41, 55, 35 \n\t" + "xvmaddadp 36, 40, 32 \n\t" + "xvmaddadp 37, 41, 32 \n\t" - "stxvd2x 40, 0, %2 \n\t" // y0, y1 - "stxvd2x 41,%4, %2 \n\t" // y2, y3 + "xvmaddadp 36, 42, 33 \n\t" + "xvmaddadp 37, 43, 33 \n\t" - : - : - "r" (i), // 0 - "r" (x), // 1 - "r" (y1), // 2 - "r" (o8), // 3 - "r" (o16), // 4 - "r" (o24), // 5 - "r" (a0), // 6 - "r" (a1), // 7 - "r" (a2), // 8 - "r" (a3), // 9 - "r" (pre) // 10 - : "cr0", "%0", "%2" , "%6", "%7", "%8", "%9", "memory" - ); + "xvmaddadp 36, 44, 34 \n\t" + "xvmaddadp 37, 45, 34 \n\t" -} + "xvmaddadp 36, 46, 35 \n\t" + "xvmaddadp 37, 47, 35 \n\t" + "stxvd2x 36, 0, %2 \n\t" // y0, y1 + "stxvd2x 37, %11, %2 \n" // y2, y3 + "#n=%1 ap=%8=%12 lda=%13 x=%7=%10 y=%0=%2 alpha=%9 o16=%11\n" + "#a0=%3 a1=%4 a2=%5 a3=%6" + : + "+m" (*y), + "+r" (n), // 1 + "+b" (y), // 2 + "=b" (a0), // 3 + "=b" (a1), // 4 + "=&b" (a2), // 5 + "=&b" (a3) // 6 + : + "m" (*x), + "m" (*ap), + "d" (alpha), // 9 + "r" (x), // 10 + "b" (16), // 11 + "3" (ap), // 12 + "4" (lda) // 13 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/drot.c b/kernel/power/drot.c index c93f69b12b..3e107486f6 100644 --- a/kernel/power/drot.c +++ b/kernel/power/drot.c @@ -46,7 +46,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_16 -static void drot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) +static void drot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT c, FLOAT s) { BLASLONG i=0; @@ -56,8 +56,6 @@ static void drot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) FLOAT y00, y01, y02, y03; FLOAT *x1=x; FLOAT *y1=y; - FLOAT c1=*c; - FLOAT s1=*s; while ( i 0 ) { - c1[0]=c; - c1[1]=c; - c1[2]=c; - c1[3]=c; - s1[0]=s; - s1[1]=s; - s1[2]=s; - s1[3]=s; - drot_kernel_16(n1, x1, y1, c1, s1); + drot_kernel_16(n1, x1, y1, c, s); i=n1; } diff --git a/kernel/power/drot_microk_power8.c b/kernel/power/drot_microk_power8.c index 4444ac7eb7..016b7764d6 100644 --- a/kernel/power/drot_microk_power8.c +++ b/kernel/power/drot_microk_power8.c @@ -38,174 +38,176 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_16 1 -static void drot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) __attribute__ ((noinline)); - -static void drot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) +static void drot_kernel_16 (long n, double *x, double *y, double c, double s) { + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + __vector double t4; + __vector double t5; + __vector double t6; + __vector double t7; + __asm__ + ( + "xxspltd 36, %x13, 0 \n\t" // load c to both dwords + "xxspltd 37, %x14, 0 \n\t" // load s to both dwords - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - - __asm__ __volatile__ - ( - - "lxsdx 36 , %5, %3 \n\t" // load c - "lxsdx 37 , %5, %4 \n\t" // load s - "addi %8 , %8, -8 \n\t" - "addi %9 , %9, -8 \n\t" - - "xxspltd 36 , 36, 0 \n\t" - "xxspltd 37 , 37, 0 \n\t" - - "lxvd2x 32, 0, %1 \n\t" // load x - "lxvd2x 33, %5, %1 \n\t" - "lxvd2x 34, %6, %1 \n\t" - "lxvd2x 35, %7, %1 \n\t" - - "lxvd2x 40, 0, %2 \n\t" // load y - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "addi %1, %1, 64 \n\t" - "addi %2, %2, 64 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "xvmuldp 48, 32, 36 \n\t" // c * x - "xvmuldp 49, 33, 36 \n\t" - "xvmuldp 50, 34, 36 \n\t" - "xvmuldp 51, 35, 36 \n\t" - - "xvmuldp 56, 40, 36 \n\t" // c * y - "xvmuldp 57, 41, 36 \n\t" - "xvmuldp 58, 42, 36 \n\t" - "xvmuldp 59, 43, 36 \n\t" - - "xvmuldp 52, 32, 37 \n\t" // s * x - "xvmuldp 53, 33, 37 \n\t" - - "lxvd2x 32, 0, %1 \n\t" // load x - "lxvd2x 33, %5, %1 \n\t" - - "xvmuldp 54, 34, 37 \n\t" - "xvmuldp 55, 35, 37 \n\t" - - "lxvd2x 34, %6, %1 \n\t" - "lxvd2x 35, %7, %1 \n\t" - - "xvmuldp 60, 40, 37 \n\t" // s * y - "xvmuldp 61, 41, 37 \n\t" - - "lxvd2x 40, 0, %2 \n\t" // load y - "lxvd2x 41, %5, %2 \n\t" - - "xvmuldp 62, 42, 37 \n\t" - "xvmuldp 63, 43, 37 \n\t" - - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "xvadddp 48, 48 , 60 \n\t" // c * x + s * y - "xvadddp 49, 49 , 61 \n\t" // c * x + s * y - - "addi %1, %1, 64 \n\t" - "addi %2, %2, 64 \n\t" - - "xvadddp 50, 50 , 62 \n\t" // c * x + s * y - "xvadddp 51, 51 , 63 \n\t" // c * x + s * y - - "xvsubdp 56, 56 , 52 \n\t" // c * y - s * x - "xvsubdp 57, 57 , 53 \n\t" // c * y - s * x - "xvsubdp 58, 58 , 54 \n\t" // c * y - s * x - "xvsubdp 59, 59 , 55 \n\t" // c * y - s * x - - "stxvd2x 48, 0, %8 \n\t" // store x - "stxvd2x 49, %5, %8 \n\t" - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" - - "stxvd2x 56, 0, %9 \n\t" // store y - "stxvd2x 57, %5, %9 \n\t" - "stxvd2x 58, %6, %9 \n\t" - "stxvd2x 59, %7, %9 \n\t" - - "addi %8, %8, 64 \n\t" - "addi %9, %9, 64 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmuldp 48, 32, 36 \n\t" // c * x - "xvmuldp 49, 33, 36 \n\t" - "xvmuldp 50, 34, 36 \n\t" - "xvmuldp 51, 35, 36 \n\t" - - "xvmuldp 56, 40, 36 \n\t" // c * y - "xvmuldp 57, 41, 36 \n\t" - "xvmuldp 58, 42, 36 \n\t" - "xvmuldp 59, 43, 36 \n\t" - - "xvmuldp 52, 32, 37 \n\t" // s * x - "xvmuldp 53, 33, 37 \n\t" - "xvmuldp 54, 34, 37 \n\t" - "xvmuldp 55, 35, 37 \n\t" - - "xvmuldp 60, 40, 37 \n\t" // s * y - "xvmuldp 61, 41, 37 \n\t" - "xvmuldp 62, 42, 37 \n\t" - "xvmuldp 63, 43, 37 \n\t" - - "xvadddp 48, 48 , 60 \n\t" // c * x + s * y - "xvadddp 49, 49 , 61 \n\t" // c * x + s * y - "xvadddp 50, 50 , 62 \n\t" // c * x + s * y - "xvadddp 51, 51 , 63 \n\t" // c * x + s * y - - "xvsubdp 56, 56 , 52 \n\t" // c * y - s * x - "xvsubdp 57, 57 , 53 \n\t" // c * y - s * x - "xvsubdp 58, 58 , 54 \n\t" // c * y - s * x - "xvsubdp 59, 59 , 55 \n\t" // c * y - s * x - - "stxvd2x 48, 0, %8 \n\t" // store x - "stxvd2x 49, %5, %8 \n\t" - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" + "lxvd2x 32, 0, %3 \n\t" // load x + "lxvd2x 33, %15, %3 \n\t" + "lxvd2x 34, %16, %3 \n\t" + "lxvd2x 35, %17, %3 \n\t" - "stxvd2x 56, 0, %9 \n\t" // store y - "stxvd2x 57, %5, %9 \n\t" - "stxvd2x 58, %6, %9 \n\t" - "stxvd2x 59, %7, %9 \n\t" + "lxvd2x 48, 0, %4 \n\t" // load y + "lxvd2x 49, %15, %4 \n\t" + "lxvd2x 50, %16, %4 \n\t" + "lxvd2x 51, %17, %4 \n\t" + "addi %3, %3, 64 \n\t" + "addi %4, %4, 64 \n\t" + "addic. %2, %2, -8 \n\t" + "ble 2f \n\t" - : - : - "r" (i), // 0 - "r" (x1), // 1 - "r" (y1), // 2 - "r" (c), // 3 - "r" (s), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (x2), // 8 - "r" (y2) // 9 - : "cr0", "%0", "%1" , "%2", "%8", "%9", "memory" - ); + ".p2align 5 \n" + "1: \n\t" -} + "xvmuldp 40, 32, 36 \n\t" // c * x + "xvmuldp 41, 33, 36 \n\t" + "xvmuldp 42, 34, 36 \n\t" + "xvmuldp 43, 35, 36 \n\t" + "xvmuldp %x5, 48, 36 \n\t" // c * y + "xvmuldp %x6, 49, 36 \n\t" + "xvmuldp %x7, 50, 36 \n\t" + "xvmuldp %x8, 51, 36 \n\t" + "xvmuldp 44, 32, 37 \n\t" // s * x + "xvmuldp 45, 33, 37 \n\t" + + "lxvd2x 32, 0, %3 \n\t" // load x + "lxvd2x 33, %15, %3 \n\t" + + "xvmuldp 46, 34, 37 \n\t" + "xvmuldp 47, 35, 37 \n\t" + + "lxvd2x 34, %16, %3 \n\t" + "lxvd2x 35, %17, %3 \n\t" + + "xvmuldp %x9, 48, 37 \n\t" // s * y + "xvmuldp %x10, 49, 37 \n\t" + + "lxvd2x 48, 0, %4 \n\t" // load y + "lxvd2x 49, %15, %4 \n\t" + + "xvmuldp %x11, 50, 37 \n\t" + "xvmuldp %x12, 51, 37 \n\t" + + "lxvd2x 50, %16, %4 \n\t" + "lxvd2x 51, %17, %4 \n\t" + + "xvadddp 40, 40, %x9 \n\t" // c * x + s * y + "xvadddp 41, 41, %x10 \n\t" // c * x + s * y + + "addi %3, %3, -64 \n\t" + "addi %4, %4, -64 \n\t" + + "xvadddp 42, 42, %x11 \n\t" // c * x + s * y + "xvadddp 43, 43, %x12 \n\t" // c * x + s * y + + "xvsubdp %x5, %x5, 44 \n\t" // c * y - s * x + "xvsubdp %x6, %x6, 45 \n\t" // c * y - s * x + "xvsubdp %x7, %x7, 46 \n\t" // c * y - s * x + "xvsubdp %x8, %x8, 47 \n\t" // c * y - s * x + + "stxvd2x 40, 0, %3 \n\t" // store x + "stxvd2x 41, %15, %3 \n\t" + "stxvd2x 42, %16, %3 \n\t" + "stxvd2x 43, %17, %3 \n\t" + + "stxvd2x %x5, 0, %4 \n\t" // store y + "stxvd2x %x6, %15, %4 \n\t" + "stxvd2x %x7, %16, %4 \n\t" + "stxvd2x %x8, %17, %4 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %4, %4, 128 \n\t" + + "addic. %2, %2, -8 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmuldp 40, 32, 36 \n\t" // c * x + "xvmuldp 41, 33, 36 \n\t" + "xvmuldp 42, 34, 36 \n\t" + "xvmuldp 43, 35, 36 \n\t" + + "xvmuldp %x5, 48, 36 \n\t" // c * y + "xvmuldp %x6, 49, 36 \n\t" + "xvmuldp %x7, 50, 36 \n\t" + "xvmuldp %x8, 51, 36 \n\t" + + "xvmuldp 44, 32, 37 \n\t" // s * x + "xvmuldp 45, 33, 37 \n\t" + "xvmuldp 46, 34, 37 \n\t" + "xvmuldp 47, 35, 37 \n\t" + + "xvmuldp %x9, 48, 37 \n\t" // s * y + "xvmuldp %x10, 49, 37 \n\t" + "xvmuldp %x11, 50, 37 \n\t" + "xvmuldp %x12, 51, 37 \n\t" + + "addi %3, %3, -64 \n\t" + "addi %4, %4, -64 \n\t" + + "xvadddp 40, 40, %x9 \n\t" // c * x + s * y + "xvadddp 41, 41, %x10 \n\t" // c * x + s * y + "xvadddp 42, 42, %x11 \n\t" // c * x + s * y + "xvadddp 43, 43, %x12 \n\t" // c * x + s * y + + "xvsubdp %x5, %x5, 44 \n\t" // c * y - s * x + "xvsubdp %x6, %x6, 45 \n\t" // c * y - s * x + "xvsubdp %x7, %x7, 46 \n\t" // c * y - s * x + "xvsubdp %x8, %x8, 47 \n\t" // c * y - s * x + + "stxvd2x 40, 0, %3 \n\t" // store x + "stxvd2x 41, %15, %3 \n\t" + "stxvd2x 42, %16, %3 \n\t" + "stxvd2x 43, %17, %3 \n\t" + + "stxvd2x %x5, 0, %4 \n\t" // store y + "stxvd2x %x6, %15, %4 \n\t" + "stxvd2x %x7, %16, %4 \n\t" + "stxvd2x %x8, %17, %4 \n" + + "#n=%2 x=%0=%3 y=%1=%4 c=%13 s=%14 o16=%15 o32=%16 o48=%17\n" + "#t0=%x5 t1=%x6 t2=%x7 t3=%x8 t4=%x9 t5=%x10 t6=%x11 t7=%x12" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y), // 4 + "=wa" (t0), // 5 + "=wa" (t1), // 6 + "=wa" (t2), // 7 + "=wa" (t3), // 8 + "=wa" (t4), // 9 + "=wa" (t5), // 10 + "=wa" (t6), // 11 + "=wa" (t7) // 12 + : + "d" (c), // 13 + "d" (s), // 14 + "b" (16), // 15 + "b" (32), // 16 + "b" (48) // 17 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); +} diff --git a/kernel/power/dscal.c b/kernel/power/dscal.c index c62a563158..f32dc4bad6 100644 --- a/kernel/power/dscal.c +++ b/kernel/power/dscal.c @@ -41,11 +41,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(HAVE_KERNEL_8) -static void dscal_kernel_8( BLASLONG n, FLOAT *da , FLOAT *x ) +static void dscal_kernel_8 (BLASLONG n, FLOAT *x, FLOAT alpha) { BLASLONG i; - FLOAT alpha = *da; for( i=0; i 0 ) { - FLOAT alpha[2]; - alpha[0]=da; - alpha[1]=da; - dscal_kernel_8_zero(n1 , alpha , x); + dscal_kernel_8_zero(n1, x); j=n1; } @@ -123,10 +119,7 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, BLAS BLASLONG n1 = n & -16; if ( n1 > 0 ) { - FLOAT alpha[2]; - alpha[0]=da; - alpha[1]=da; - dscal_kernel_8(n1 , alpha , x); + dscal_kernel_8(n1, x, da); j=n1; } while(j < n) diff --git a/kernel/power/dscal_microk_power8.c b/kernel/power/dscal_microk_power8.c index d90c3d80cb..04898eb3d5 100644 --- a/kernel/power/dscal_microk_power8.c +++ b/kernel/power/dscal_microk_power8.c @@ -35,185 +35,149 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_8 1 -static void dscal_kernel_8( BLASLONG n, FLOAT *alpha, FLOAT *x) __attribute__ ((noinline)); - -static void dscal_kernel_8( BLASLONG n, FLOAT *alpha, FLOAT *x) +static void dscal_kernel_8 (long n, double *x, double alpha) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *x2=x+1; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "lxsdx 33, 0, %3 \n\t" - "xxspltd 32, 33, 0 \n\t" - "addi %1, %1, -8 \n\t" - - "dcbt %2, %4 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %4 \n\t" - - "xvmuldp 48, 40, 32 \n\t" - "xvmuldp 49, 41, 32 \n\t" - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "xvmuldp 50, 42, 32 \n\t" - "xvmuldp 51, 43, 32 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "xvmuldp 52, 44, 32 \n\t" - "xvmuldp 53, 45, 32 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "xvmuldp 54, 46, 32 \n\t" - "xvmuldp 55, 47, 32 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "stxvd2x 48, 0, %1 \n\t" - "stxvd2x 49, %5, %1 \n\t" - "stxvd2x 50, %6, %1 \n\t" - "stxvd2x 51, %7, %1 \n\t" - "stxvd2x 52, %8, %1 \n\t" - "stxvd2x 53, %9, %1 \n\t" - "stxvd2x 54, %10, %1 \n\t" - "stxvd2x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmuldp 48, 40, 32 \n\t" - "xvmuldp 49, 41, 32 \n\t" - "xvmuldp 50, 42, 32 \n\t" - "xvmuldp 51, 43, 32 \n\t" - "xvmuldp 52, 44, 32 \n\t" - "xvmuldp 53, 45, 32 \n\t" - "xvmuldp 54, 46, 32 \n\t" - "xvmuldp 55, 47, 32 \n\t" - - "stxvd2x 48, 0, %1 \n\t" - "stxvd2x 49, %5, %1 \n\t" - "stxvd2x 50, %6, %1 \n\t" - "stxvd2x 51, %7, %1 \n\t" - "stxvd2x 52, %8, %1 \n\t" - "stxvd2x 53, %9, %1 \n\t" - "stxvd2x 54, %10, %1 \n\t" - "stxvd2x 55, %11, %1 \n\t" - - : - : - "r" (i), // 0 - "r" (x2), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - -static void dscal_kernel_8_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) __attribute__ ((noinline)); - -static void dscal_kernel_8_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xxspltd %x3, %x3, 0 \n\t" + + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %4, %2 \n\t" + "lxvd2x 34, %5, %2 \n\t" + "lxvd2x 35, %6, %2 \n\t" + "lxvd2x 36, %7, %2 \n\t" + "lxvd2x 37, %8, %2 \n\t" + "lxvd2x 38, %9, %2 \n\t" + "lxvd2x 39, %10, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmuldp 40, 32, %x3 \n\t" + "xvmuldp 41, 33, %x3 \n\t" + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %4, %2 \n\t" + "xvmuldp 42, 34, %x3 \n\t" + "xvmuldp 43, 35, %x3 \n\t" + "lxvd2x 34, %5, %2 \n\t" + "lxvd2x 35, %6, %2 \n\t" + "xvmuldp 44, 36, %x3 \n\t" + "xvmuldp 45, 37, %x3 \n\t" + "lxvd2x 36, %7, %2 \n\t" + "lxvd2x 37, %8, %2 \n\t" + "xvmuldp 46, 38, %x3 \n\t" + "xvmuldp 47, 39, %x3 \n\t" + "lxvd2x 38, %9, %2 \n\t" + "lxvd2x 39, %10, %2 \n\t" + + "addi %2, %2, -128 \n\t" + + "stxvd2x 40, 0, %2 \n\t" + "stxvd2x 41, %4, %2 \n\t" + "stxvd2x 42, %5, %2 \n\t" + "stxvd2x 43, %6, %2 \n\t" + "stxvd2x 44, %7, %2 \n\t" + "stxvd2x 45, %8, %2 \n\t" + "stxvd2x 46, %9, %2 \n\t" + "stxvd2x 47, %10, %2 \n\t" + + "addi %2, %2, 256 \n\t" + + "addic. %1, %1, -16 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmuldp 40, 32, %x3 \n\t" + "xvmuldp 41, 33, %x3 \n\t" + "xvmuldp 42, 34, %x3 \n\t" + "xvmuldp 43, 35, %x3 \n\t" + + "addi %2, %2, -128 \n\t" + + "xvmuldp 44, 36, %x3 \n\t" + "xvmuldp 45, 37, %x3 \n\t" + "xvmuldp 46, 38, %x3 \n\t" + "xvmuldp 47, 39, %x3 \n\t" + + "stxvd2x 40, 0, %2 \n\t" + "stxvd2x 41, %4, %2 \n\t" + "stxvd2x 42, %5, %2 \n\t" + "stxvd2x 43, %6, %2 \n\t" + "stxvd2x 44, %7, %2 \n\t" + "stxvd2x 45, %8, %2 \n\t" + "stxvd2x 46, %9, %2 \n\t" + "stxvd2x 47, %10, %2 \n" + + "#n=%1 alpha=%3 x=%0=%2 o16=%4 o32=%5 o48=%6 o64=%7 o80=%8 o96=%9 o112=%10" + : + "+m" (*x), + "+r" (n), // 1 + "+b" (x) // 2 + : + "d" (alpha), // 3 + "b" (16), // 4 + "b" (32), // 5 + "b" (48), // 6 + "b" (64), // 7 + "b" (80), // 8 + "b" (96), // 9 + "b" (112) // 10 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} + + +static void dscal_kernel_8_zero (long n, double *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *x2=x+1; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "xxlxor 32 , 32 , 32 \n\t" - "addi %1, %1, -8 \n\t" - - - ".align 5 \n\t" - "1: \n\t" - - "stxvd2x 32, 0, %1 \n\t" - "stxvd2x 32, %5, %1 \n\t" - "stxvd2x 32, %6, %1 \n\t" - "stxvd2x 32, %7, %1 \n\t" - "stxvd2x 32, %8, %1 \n\t" - "stxvd2x 32, %9, %1 \n\t" - "stxvd2x 32, %10, %1 \n\t" - "stxvd2x 32, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (x2), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __vector double t0; + + __asm__ + ( + "xxlxor %x3, %x3, %x3 \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x %x3, 0, %2 \n\t" + "stxvd2x %x3, %4, %2 \n\t" + "stxvd2x %x3, %5, %2 \n\t" + "stxvd2x %x3, %6, %2 \n\t" + "stxvd2x %x3, %7, %2 \n\t" + "stxvd2x %x3, %8, %2 \n\t" + "stxvd2x %x3, %9, %2 \n\t" + "stxvd2x %x3, %10, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "bgt 1b \n" + + "#n=%1 x=%0=%2 t0=%x3 o16=%4 o32=%5 o48=%6 o64=%7 o80=%8 o96=%9 o112=%10" + : + "=m" (*x), + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0) // 3 + : + "b" (16), // 4 + "b" (32), // 5 + "b" (48), // 6 + "b" (64), // 7 + "b" (80), // 8 + "b" (96), // 9 + "b" (112) // 10 + : + "cr0" + ); +} diff --git a/kernel/power/dswap_microk_power8.c b/kernel/power/dswap_microk_power8.c index 77747c3b95..31eff34491 100644 --- a/kernel/power/dswap_microk_power8.c +++ b/kernel/power/dswap_microk_power8.c @@ -35,146 +35,124 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void dswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void dswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void dswap_kernel_32 (long n, double *x, double *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "addi %3, %3, -8 \n\t" - "addi %4, %4, -8 \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "lxvd2x 32, 0, %2 \n\t" - "lxvd2x 33, %5, %2 \n\t" - "lxvd2x 34, %6, %2 \n\t" - "lxvd2x 35, %7, %2 \n\t" - "lxvd2x 36, %8, %2 \n\t" - "lxvd2x 37, %9, %2 \n\t" - "lxvd2x 38, %10, %2 \n\t" - "lxvd2x 39, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 48, 0, %1 \n\t" - "lxvd2x 49, %5, %1 \n\t" - "lxvd2x 50, %6, %1 \n\t" - "lxvd2x 51, %7, %1 \n\t" - "lxvd2x 52, %8, %1 \n\t" - "lxvd2x 53, %9, %1 \n\t" - "lxvd2x 54, %10, %1 \n\t" - "lxvd2x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "lxvd2x 56, 0, %1 \n\t" - "lxvd2x 57, %5, %1 \n\t" - "lxvd2x 58, %6, %1 \n\t" - "lxvd2x 59, %7, %1 \n\t" - "lxvd2x 60, %8, %1 \n\t" - "lxvd2x 61, %9, %1 \n\t" - "lxvd2x 62, %10, %1 \n\t" - "lxvd2x 63, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvd2x 32, 0, %3 \n\t" - "stxvd2x 33, %5, %3 \n\t" - "stxvd2x 34, %6, %3 \n\t" - "stxvd2x 35, %7, %3 \n\t" - "stxvd2x 36, %8, %3 \n\t" - "stxvd2x 37, %9, %3 \n\t" - "stxvd2x 38, %10, %3 \n\t" - "stxvd2x 39, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvd2x 40, 0, %3 \n\t" - "stxvd2x 41, %5, %3 \n\t" - "stxvd2x 42, %6, %3 \n\t" - "stxvd2x 43, %7, %3 \n\t" - "stxvd2x 44, %8, %3 \n\t" - "stxvd2x 45, %9, %3 \n\t" - "stxvd2x 46, %10, %3 \n\t" - "stxvd2x 47, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvd2x 48, 0, %4 \n\t" - "stxvd2x 49, %5, %4 \n\t" - "stxvd2x 50, %6, %4 \n\t" - "stxvd2x 51, %7, %4 \n\t" - "stxvd2x 52, %8, %4 \n\t" - "stxvd2x 53, %9, %4 \n\t" - "stxvd2x 54, %10, %4 \n\t" - "stxvd2x 55, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "stxvd2x 56, 0, %4 \n\t" - "stxvd2x 57, %5, %4 \n\t" - "stxvd2x 58, %6, %4 \n\t" - "stxvd2x 59, %7, %4 \n\t" - "stxvd2x 60, %8, %4 \n\t" - "stxvd2x 61, %9, %4 \n\t" - "stxvd2x 62, %10, %4 \n\t" - "stxvd2x 63, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (y2), // 3 - "r" (x2), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "%3", "%4", "memory" - ); - -} - - + __asm__ + ( + ".p2align 5 \n" + "1: \n\t" + + "lxvd2x 32, 0, %4 \n\t" + "lxvd2x 33, %5, %4 \n\t" + "lxvd2x 34, %6, %4 \n\t" + "lxvd2x 35, %7, %4 \n\t" + "lxvd2x 36, %8, %4 \n\t" + "lxvd2x 37, %9, %4 \n\t" + "lxvd2x 38, %10, %4 \n\t" + "lxvd2x 39, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "lxvd2x 40, 0, %4 \n\t" + "lxvd2x 41, %5, %4 \n\t" + "lxvd2x 42, %6, %4 \n\t" + "lxvd2x 43, %7, %4 \n\t" + "lxvd2x 44, %8, %4 \n\t" + "lxvd2x 45, %9, %4 \n\t" + "lxvd2x 46, %10, %4 \n\t" + "lxvd2x 47, %11, %4 \n\t" + + "addi %4, %4, -128 \n\t" + + "lxvd2x 48, 0, %3 \n\t" + "lxvd2x 49, %5, %3 \n\t" + "lxvd2x 50, %6, %3 \n\t" + "lxvd2x 51, %7, %3 \n\t" + "lxvd2x 0, %8, %3 \n\t" + "lxvd2x 1, %9, %3 \n\t" + "lxvd2x 2, %10, %3 \n\t" + "lxvd2x 3, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "lxvd2x 4, 0, %3 \n\t" + "lxvd2x 5, %5, %3 \n\t" + "lxvd2x 6, %6, %3 \n\t" + "lxvd2x 7, %7, %3 \n\t" + "lxvd2x 8, %8, %3 \n\t" + "lxvd2x 9, %9, %3 \n\t" + "lxvd2x 10, %10, %3 \n\t" + "lxvd2x 11, %11, %3 \n\t" + + "addi %3, %3, -128 \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 48, 0, %4 \n\t" + "stxvd2x 49, %5, %4 \n\t" + "stxvd2x 50, %6, %4 \n\t" + "stxvd2x 51, %7, %4 \n\t" + "stxvd2x 0, %8, %4 \n\t" + "stxvd2x 1, %9, %4 \n\t" + "stxvd2x 2, %10, %4 \n\t" + "stxvd2x 3, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "stxvd2x 4, 0, %4 \n\t" + "stxvd2x 5, %5, %4 \n\t" + "stxvd2x 6, %6, %4 \n\t" + "stxvd2x 7, %7, %4 \n\t" + "stxvd2x 8, %8, %4 \n\t" + "stxvd2x 9, %9, %4 \n\t" + "stxvd2x 10, %10, %4 \n\t" + "stxvd2x 11, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "addic. %2, %2, -32 \n\t" + "bgt 1b \n" + + "#n=%2 x=%0=%3 y=%1=%4 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y) // 4 + : + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51","vs0","vs1","vs2","vs3", + "vs4","vs5","vs6","vs7","vs8","vs9","vs10","vs11" + ); +} diff --git a/kernel/power/sasum.c b/kernel/power/sasum.c index 43311f2bad..fb10b1d27e 100644 --- a/kernel/power/sasum.c +++ b/kernel/power/sasum.c @@ -38,7 +38,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(DOUBLE) -#define ABS fabs +#error supports float only #else @@ -53,7 +53,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_32 -static void sasum_kernel_32(BLASLONG n, FLOAT *x1, FLOAT *svec) +static FLOAT sasum_kernel_32(BLASLONG n, FLOAT *x1) { BLASLONG i=0; @@ -92,11 +92,7 @@ static void sasum_kernel_32(BLASLONG n, FLOAT *x1, FLOAT *svec) } - svec[0] = sum0+sum1+sum2+sum3; - svec[1] = 0.0; - svec[2] = 0.0; - svec[3] = 0.0; - + return sum0+sum1+sum2+sum3; } #endif @@ -105,7 +101,6 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) { BLASLONG i=0; FLOAT sumf = 0.0; - FLOAT svec[4] __attribute__ ((aligned (16)));; BLASLONG n1; if (n <= 0 || inc_x <= 0) return(sumf); @@ -117,8 +112,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) if ( n1 > 0 ) { - sasum_kernel_32(n1, x, svec); - sumf = svec[0] + svec[1]+svec[2]+svec[3]; + sumf = sasum_kernel_32(n1, x); i=n1; } diff --git a/kernel/power/sasum_microk_power8.c b/kernel/power/sasum_microk_power8.c index 847fffe048..4bb515de85 100644 --- a/kernel/power/sasum_microk_power8.c +++ b/kernel/power/sasum_microk_power8.c @@ -34,144 +34,145 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_32 1 -static void sasum_kernel_32( BLASLONG n, FLOAT *x, FLOAT *svec) __attribute__ ((noinline)); -static void sasum_kernel_32( BLASLONG n, FLOAT *x, FLOAT *svec) +static float sasum_kernel_32 (long n, float *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "dcbt %2 , %4 \n\t" - - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2 , %4 \n\t" - - "xvabssp 48, 40 \n\t" - "xvabssp 49, 41 \n\t" - "xvabssp 50, 42 \n\t" - "xvabssp 51, 43 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - - "xvabssp 52, 44 \n\t" - "xvabssp 53, 45 \n\t" - - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - - "xvabssp 54, 46 \n\t" - "xvabssp 55, 47 \n\t" - - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - - "xvaddsp 32, 32, 48 \n\t" - "xvaddsp 33, 33, 49 \n\t" - - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "xvaddsp 34, 34, 50 \n\t" - "xvaddsp 35, 35, 51 \n\t" - "addi %2, %2, 128 \n\t" - "xvaddsp 36, 36, 52 \n\t" - "xvaddsp 37, 37, 53 \n\t" - "addic. %0 , %0 , -32 \n\t" - "xvaddsp 38, 38, 54 \n\t" - "xvaddsp 39, 39, 55 \n\t" - - "bgt 1b \n\t" - - "2: \n\t" - - - "xvabssp 48, 40 \n\t" - "xvabssp 49, 41 \n\t" - "xvabssp 50, 42 \n\t" - "xvabssp 51, 43 \n\t" - "xvabssp 52, 44 \n\t" - "xvabssp 53, 45 \n\t" - "xvabssp 54, 46 \n\t" - "xvabssp 55, 47 \n\t" - - "xvaddsp 32, 32, 48 \n\t" - "xvaddsp 33, 33, 49 \n\t" - "xvaddsp 34, 34, 50 \n\t" - "xvaddsp 35, 35, 51 \n\t" - "xvaddsp 36, 36, 52 \n\t" - "xvaddsp 37, 37, 53 \n\t" - "xvaddsp 38, 38, 54 \n\t" - "xvaddsp 39, 39, 55 \n\t" - - "xvaddsp 32, 32, 33 \n\t" - "xvaddsp 34, 34, 35 \n\t" - "xvaddsp 36, 36, 37 \n\t" - "xvaddsp 38, 38, 39 \n\t" - - "xvaddsp 32, 32, 34 \n\t" - "xvaddsp 36, 36, 38 \n\t" - - "xvaddsp 32, 32, 36 \n\t" - - - "stxvw4x 32, 0, %3 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (svec), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2", "memory" - ); - -} - - + float sum; + __vector float t0; + __vector float t1; + __vector float t2; + __vector float t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvabssp 48, 40 \n\t" + "xvabssp 49, 41 \n\t" + "xvabssp 50, 42 \n\t" + "xvabssp 51, 43 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + + "xvabssp %x3, 44 \n\t" + "xvabssp %x4, 45 \n\t" + + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + + "xvabssp %x5, 46 \n\t" + "xvabssp %x6, 47 \n\t" + + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + + "xvaddsp 32, 32, 48 \n\t" + "xvaddsp 33, 33, 49 \n\t" + + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "xvaddsp 34, 34, 50 \n\t" + "xvaddsp 35, 35, 51 \n\t" + "addi %2, %2, 128 \n\t" + "xvaddsp 36, 36, %x3 \n\t" + "xvaddsp 37, 37, %x4 \n\t" + "addic. %1, %1, -32 \n\t" + "xvaddsp 38, 38, %x5 \n\t" + "xvaddsp 39, 39, %x6 \n\t" + + "bgt 1b \n" + + "2: \n\t" + + "xvabssp 48, 40 \n\t" + "xvabssp 49, 41 \n\t" + "xvabssp 50, 42 \n\t" + "xvabssp 51, 43 \n\t" + "xvabssp %x3, 44 \n\t" + "xvabssp %x4, 45 \n\t" + "xvabssp %x5, 46 \n\t" + "xvabssp %x6, 47 \n\t" + + "xvaddsp 32, 32, 48 \n\t" + "xvaddsp 33, 33, 49 \n\t" + "xvaddsp 34, 34, 50 \n\t" + "xvaddsp 35, 35, 51 \n\t" + "xvaddsp 36, 36, %x3 \n\t" + "xvaddsp 37, 37, %x4 \n\t" + "xvaddsp 38, 38, %x5 \n\t" + "xvaddsp 39, 39, %x6 \n\t" + + "xvaddsp 32, 32, 33 \n\t" + "xvaddsp 34, 34, 35 \n\t" + "xvaddsp 36, 36, 37 \n\t" + "xvaddsp 38, 38, 39 \n\t" + + "xvaddsp 32, 32, 34 \n\t" + "xvaddsp 36, 36, 38 \n\t" + + "xvaddsp 32, 32, 36 \n\t" + + "xxsldwi 33, 32, 32, 2 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xxsldwi 33, 32, 32, 1 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xscvspdp %x0, 32 \n" + + "#n=%1 x=%3=%2 sum=%0 o16=%8 o32=%9 o48=%10 o64=%11 o80=%12 o96=%13 o112=%14\n" + "#t0=%x3 t1=%x4 t2=%x5 t3=%x6" + : + "=f" (sum), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0), // 3 + "=wa" (t1), // 4 + "=wa" (t2), // 5 + "=wa" (t3) // 6 + : + "m" (*x), + "b" (16), // 8 + "b" (32), // 9 + "b" (48), // 10 + "b" (64), // 11 + "b" (80), // 12 + "b" (96), // 13 + "b" (112) // 14 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return sum; +} diff --git a/kernel/power/scopy_microk_power8.c b/kernel/power/scopy_microk_power8.c index 2e08e3561f..7a54d5e1eb 100644 --- a/kernel/power/scopy_microk_power8.c +++ b/kernel/power/scopy_microk_power8.c @@ -35,97 +35,78 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void scopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void scopy_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void scopy_kernel_32 (long n, float *x, float *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "stxvw4x 40, 0, %1 \n\t" - "stxvw4x 41, %5, %1 \n\t" - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "stxvw4x 42, %6, %1 \n\t" - "stxvw4x 43, %7, %1 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "stxvw4x 44, %8, %1 \n\t" - "stxvw4x 45, %9, %1 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "stxvw4x 46, %10, %1 \n\t" - "stxvw4x 47, %11, %1 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "stxvw4x 40, 0, %1 \n\t" - "stxvw4x 41, %5, %1 \n\t" - "stxvw4x 42, %6, %1 \n\t" - "stxvw4x 43, %7, %1 \n\t" - "stxvw4x 44, %8, %1 \n\t" - "stxvw4x 45, %9, %1 \n\t" - "stxvw4x 46, %10, %1 \n\t" - "stxvw4x 47, %11, %1 \n\t" - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __asm__ + ( + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n" + + "#n=%1 x=%4=%2 y=%0=%3 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "=m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y) // 3 + : + "m" (*x), + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/sdot.c b/kernel/power/sdot.c index 52fb1fe244..31f4734857 100644 --- a/kernel/power/sdot.c +++ b/kernel/power/sdot.c @@ -42,7 +42,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_16 -static void sdot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) +static FLOAT sdot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y) { BLASLONG register i = 0; FLOAT dot = 0.0; @@ -61,8 +61,7 @@ static void sdot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) i+=8 ; } - *d += dot; - + return dot; } #endif @@ -82,8 +81,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG inc_y) BLASLONG n1 = n & -32; if ( n1 ) - sdot_kernel_16(n1, x, y , &dot ); - + dot = sdot_kernel_16(n1, x, y); i = n1; while(i < n) diff --git a/kernel/power/sdot_microk_power8.c b/kernel/power/sdot_microk_power8.c index 6dd588acdc..bfe100c8b8 100644 --- a/kernel/power/sdot_microk_power8.c +++ b/kernel/power/sdot_microk_power8.c @@ -34,146 +34,142 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_16 1 -static void sdot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y , FLOAT *dot) __attribute__ ((noinline)); -static void sdot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *dot) +static float sdot_kernel_16 (long n, float *x, float *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - FLOAT tempdot[4]; - - - __asm__ __volatile__ - ( - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "dcbt %2, %12 \n\t" - "dcbt %3, %12 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 48, 0, %3 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 49, %5, %3 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 50, %6, %3 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 51, %7, %3 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 52, %8, %3 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 53, %9, %3 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 54, %10, %3 \n\t" - "lxvw4x 47, %11, %2 \n\t" - "lxvw4x 55, %11, %3 \n\t" - - "addi %2, %2, 128 \n\t" - "addi %3, %3, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %12 \n\t" - "dcbt %3, %12 \n\t" - - "xvmaddasp 32, 40, 48 \n\t" - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 48, 0, %3 \n\t" - "xvmaddasp 33, 41, 49 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 49, %5, %3 \n\t" - "xvmaddasp 34, 42, 50 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 50, %6, %3 \n\t" - "xvmaddasp 35, 43, 51 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 51, %7, %3 \n\t" - "xvmaddasp 36, 44, 52 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 52, %8, %3 \n\t" - "xvmaddasp 37, 45, 53 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 53, %9, %3 \n\t" - "xvmaddasp 38, 46, 54 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 54, %10, %3 \n\t" - "xvmaddasp 39, 47, 55 \n\t" - - "lxvw4x 47, %11, %2 \n\t" - "lxvw4x 55, %11, %3 \n\t" - - - "addi %2, %2, 128 \n\t" - "addi %3, %3, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmaddasp 32, 40, 48 \n\t" - "xvmaddasp 33, 41, 49 \n\t" - "xvmaddasp 34, 42, 50 \n\t" - "xvmaddasp 35, 43, 51 \n\t" - "xvmaddasp 36, 44, 52 \n\t" - "xvmaddasp 37, 45, 53 \n\t" - "xvmaddasp 38, 46, 54 \n\t" - "xvmaddasp 39, 47, 55 \n\t" - - "xvaddsp 32, 32 , 33 \n\t" - "xvaddsp 34, 34 , 35 \n\t" - "xvaddsp 36, 36 , 37 \n\t" - "xvaddsp 38, 38 , 39 \n\t" - - "xvaddsp 32, 32 , 34 \n\t" - "xvaddsp 36, 36 , 38 \n\t" - - "xvaddsp 32, 32 , 36 \n\t" - - "stxvw4x 32, 0 , %4 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (y1), // 3 - "r" (tempdot), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112), // 11 - "r" (pre) // 12 - : "cr0", "%0", "%2" , "%3", "memory" - ); - - *dot = tempdot[0] + tempdot[1] + tempdot[2] + tempdot[3]; - - -} - - + float dot; + __vector float t0; + __vector float t1; + __vector float t2; + __vector float t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + "dcbt 0, %3 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 48, 0, %3 \n\t" + "lxvd2x 41, %10, %2 \n\t" + "lxvd2x 49, %10, %3 \n\t" + "lxvd2x 42, %11, %2 \n\t" + "lxvd2x 50, %11, %3 \n\t" + "lxvd2x 43, %12, %2 \n\t" + "lxvd2x 51, %12, %3 \n\t" + "lxvd2x 44, %13, %2 \n\t" + "lxvd2x %x4, %13, %3 \n\t" + "lxvd2x 45, %14, %2 \n\t" + "lxvd2x %x5, %14, %3 \n\t" + "lxvd2x 46, %15, %2 \n\t" + "lxvd2x %x6, %15, %3 \n\t" + "lxvd2x 47, %16, %2 \n\t" + "lxvd2x %x7, %16, %3 \n\t" + + "addi %2, %2, 128 \n\t" + "addi %3, %3, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmaddasp 32, 40, 48 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 48, 0, %3 \n\t" + "xvmaddasp 33, 41, 49 \n\t" + "lxvd2x 41, %10, %2 \n\t" + "lxvd2x 49, %10, %3 \n\t" + "xvmaddasp 34, 42, 50 \n\t" + "lxvd2x 42, %11, %2 \n\t" + "lxvd2x 50, %11, %3 \n\t" + "xvmaddasp 35, 43, 51 \n\t" + "lxvd2x 43, %12, %2 \n\t" + "lxvd2x 51, %12, %3 \n\t" + "xvmaddasp 36, 44, %x4 \n\t" + "lxvd2x 44, %13, %2 \n\t" + "lxvd2x %x4, %13, %3 \n\t" + "xvmaddasp 37, 45, %x5 \n\t" + "lxvd2x 45, %14, %2 \n\t" + "lxvd2x %x5, %14, %3 \n\t" + "xvmaddasp 38, 46, %x6 \n\t" + "lxvd2x 46, %15, %2 \n\t" + "lxvd2x %x6, %15, %3 \n\t" + "xvmaddasp 39, 47, %x7 \n\t" + "lxvd2x 47, %16, %2 \n\t" + "lxvd2x %x7, %16, %3 \n\t" + + "addi %2, %2, 128 \n\t" + "addi %3, %3, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmaddasp 32, 40, 48 \n\t" + "xvmaddasp 33, 41, 49 \n\t" + "xvmaddasp 34, 42, 50 \n\t" + "xvmaddasp 35, 43, 51 \n\t" + "xvmaddasp 36, 44, %x4 \n\t" + "xvmaddasp 37, 45, %x5 \n\t" + "xvmaddasp 38, 46, %x6 \n\t" + "xvmaddasp 39, 47, %x7 \n\t" + + "xvaddsp 32, 32, 33 \n\t" + "xvaddsp 34, 34, 35 \n\t" + "xvaddsp 36, 36, 37 \n\t" + "xvaddsp 38, 38, 39 \n\t" + + "xvaddsp 32, 32, 34 \n\t" + "xvaddsp 36, 36, 38 \n\t" + + "xvaddsp 32, 32, 36 \n\t" + + "xxsldwi 33, 32, 32, 2 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xxsldwi 33, 32, 32, 1 \n\t" + "xvaddsp 32, 32, 33 \n\t" + + "xscvspdp %x0, 32 \n" + + "#dot=%0 n=%1 x=%8=%2 y=%9=%3 o16=%10 o32=%11 o48=%12 o64=%13 o80=%14 o96=%15 o122=%16\n" + "#t0=%x4 t1=%x5 t2=%x6 t3=%x7" + : + "=f" (dot), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y), // 3 + "=wa" (t0), // 4 + "=wa" (t1), // 5 + "=wa" (t2), // 6 + "=wa" (t3) // 7 + : + "m" (*x), + "m" (*y), + "b" (16), // 10 + "b" (32), // 11 + "b" (48), // 12 + "b" (64), // 13 + "b" (80), // 14 + "b" (96), // 15 + "b" (112) // 16 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return dot; +} diff --git a/kernel/power/srot.c b/kernel/power/srot.c index d464846a4a..d2910ff875 100644 --- a/kernel/power/srot.c +++ b/kernel/power/srot.c @@ -46,7 +46,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_16 -static void srot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) +static void srot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT c, FLOAT s) { BLASLONG i=0; @@ -56,8 +56,6 @@ static void srot_kernel_16(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) FLOAT y00, y01, y02, y03; FLOAT *x1=x; FLOAT *y1=y; - FLOAT c1=*c; - FLOAT s1=*s; while ( i 0 ) { - c1[0]=c; - c1[1]=c; - c1[2]=c; - c1[3]=c; - s1[0]=s; - s1[1]=s; - s1[2]=s; - s1[3]=s; - srot_kernel_16(n1, x1, y1, c1, s1); + srot_kernel_16(n1, x1, y1, c, s); i=n1; } diff --git a/kernel/power/srot_microk_power8.c b/kernel/power/srot_microk_power8.c index ade65500f2..6eecb60a1a 100644 --- a/kernel/power/srot_microk_power8.c +++ b/kernel/power/srot_microk_power8.c @@ -38,171 +38,179 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_16 1 -static void srot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) __attribute__ ((noinline)); - -static void srot_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *c, FLOAT *s) +static void srot_kernel_16 (long n, float *x, float *y, float c, float s) { + __vector float t0; + __vector float t1; + __vector float t2; + __vector float t3; + __vector float t4; + __vector float t5; + __vector float t6; + __vector float t7; + __asm__ + ( + "xscvdpspn 36, %x13 \n\t" // load c to all words + "xxspltw 36, 36, 0 \n\t" - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - - __asm__ __volatile__ - ( - - "lxvw4x 36 , 0, %3 \n\t" // load c - "lxvw4x 37 , 0, %4 \n\t" // load s - "addi %8 , %8, -4 \n\t" - "addi %9 , %9, -4 \n\t" - - "lxvw4x 32, 0, %1 \n\t" // load x - "lxvw4x 33, %5, %1 \n\t" - "lxvw4x 34, %6, %1 \n\t" - "lxvw4x 35, %7, %1 \n\t" - - "lxvw4x 40, 0, %2 \n\t" // load y - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - - "addi %1, %1, 64 \n\t" - "addi %2, %2, 64 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "xvmulsp 48, 32, 36 \n\t" // c * x - "xvmulsp 49, 33, 36 \n\t" - "xvmulsp 50, 34, 36 \n\t" - "xvmulsp 51, 35, 36 \n\t" - - "xvmulsp 56, 40, 36 \n\t" // c * y - "xvmulsp 57, 41, 36 \n\t" - "xvmulsp 58, 42, 36 \n\t" - "xvmulsp 59, 43, 36 \n\t" - - "xvmulsp 52, 32, 37 \n\t" // s * x - "xvmulsp 53, 33, 37 \n\t" - - "lxvw4x 32, 0, %1 \n\t" // load x - "lxvw4x 33, %5, %1 \n\t" - - "xvmulsp 54, 34, 37 \n\t" - "xvmulsp 55, 35, 37 \n\t" - - "lxvw4x 34, %6, %1 \n\t" - "lxvw4x 35, %7, %1 \n\t" - - "xvmulsp 60, 40, 37 \n\t" // s * y - "xvmulsp 61, 41, 37 \n\t" - - "lxvw4x 40, 0, %2 \n\t" // load y - "lxvw4x 41, %5, %2 \n\t" - - "xvmulsp 62, 42, 37 \n\t" - "xvmulsp 63, 43, 37 \n\t" - - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - - "xvaddsp 48, 48 , 60 \n\t" // c * x + s * y - "xvaddsp 49, 49 , 61 \n\t" // c * x + s * y - - "addi %1, %1, 64 \n\t" - "addi %2, %2, 64 \n\t" - - "xvaddsp 50, 50 , 62 \n\t" // c * x + s * y - "xvaddsp 51, 51 , 63 \n\t" // c * x + s * y - - "xvsubsp 56, 56 , 52 \n\t" // c * y - s * x - "xvsubsp 57, 57 , 53 \n\t" // c * y - s * x - "xvsubsp 58, 58 , 54 \n\t" // c * y - s * x - "xvsubsp 59, 59 , 55 \n\t" // c * y - s * x - - "stxvw4x 48, 0, %8 \n\t" // store x - "stxvw4x 49, %5, %8 \n\t" - "stxvw4x 50, %6, %8 \n\t" - "stxvw4x 51, %7, %8 \n\t" - - "stxvw4x 56, 0, %9 \n\t" // store y - "stxvw4x 57, %5, %9 \n\t" - "stxvw4x 58, %6, %9 \n\t" - "stxvw4x 59, %7, %9 \n\t" - - "addi %8, %8, 64 \n\t" - "addi %9, %9, 64 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmulsp 48, 32, 36 \n\t" // c * x - "xvmulsp 49, 33, 36 \n\t" - "xvmulsp 50, 34, 36 \n\t" - "xvmulsp 51, 35, 36 \n\t" - - "xvmulsp 56, 40, 36 \n\t" // c * y - "xvmulsp 57, 41, 36 \n\t" - "xvmulsp 58, 42, 36 \n\t" - "xvmulsp 59, 43, 36 \n\t" - - "xvmulsp 52, 32, 37 \n\t" // s * x - "xvmulsp 53, 33, 37 \n\t" - "xvmulsp 54, 34, 37 \n\t" - "xvmulsp 55, 35, 37 \n\t" - - "xvmulsp 60, 40, 37 \n\t" // s * y - "xvmulsp 61, 41, 37 \n\t" - "xvmulsp 62, 42, 37 \n\t" - "xvmulsp 63, 43, 37 \n\t" - - "xvaddsp 48, 48 , 60 \n\t" // c * x + s * y - "xvaddsp 49, 49 , 61 \n\t" // c * x + s * y - "xvaddsp 50, 50 , 62 \n\t" // c * x + s * y - "xvaddsp 51, 51 , 63 \n\t" // c * x + s * y - - "xvsubsp 56, 56 , 52 \n\t" // c * y - s * x - "xvsubsp 57, 57 , 53 \n\t" // c * y - s * x - "xvsubsp 58, 58 , 54 \n\t" // c * y - s * x - "xvsubsp 59, 59 , 55 \n\t" // c * y - s * x + "xscvdpspn 37, %x14 \n\t" // load s to all words + "xxspltw 37, 37, 0 \n\t" - "stxvw4x 48, 0, %8 \n\t" // store x - "stxvw4x 49, %5, %8 \n\t" - "stxvw4x 50, %6, %8 \n\t" - "stxvw4x 51, %7, %8 \n\t" + "lxvd2x 32, 0, %3 \n\t" // load x + "lxvd2x 33, %15, %3 \n\t" + "lxvd2x 34, %16, %3 \n\t" + "lxvd2x 35, %17, %3 \n\t" - "stxvw4x 56, 0, %9 \n\t" // store y - "stxvw4x 57, %5, %9 \n\t" - "stxvw4x 58, %6, %9 \n\t" - "stxvw4x 59, %7, %9 \n\t" + "lxvd2x 48, 0, %4 \n\t" // load y + "lxvd2x 49, %15, %4 \n\t" + "lxvd2x 50, %16, %4 \n\t" + "lxvd2x 51, %17, %4 \n\t" + "addi %3, %3, 64 \n\t" + "addi %4, %4, 64 \n\t" + "addic. %2, %2, -16 \n\t" + "ble 2f \n\t" - : - : - "r" (i), // 0 - "r" (x1), // 1 - "r" (y1), // 2 - "r" (c), // 3 - "r" (s), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (x2), // 8 - "r" (y2) // 9 - : "cr0", "%0", "%1" , "%2", "%8", "%9", "memory" - ); + ".p2align 5 \n" + "1: \n\t" -} + "xvmulsp 40, 32, 36 \n\t" // c * x + "xvmulsp 41, 33, 36 \n\t" + "xvmulsp 42, 34, 36 \n\t" + "xvmulsp 43, 35, 36 \n\t" + "xvmulsp %x5, 48, 36 \n\t" // c * y + "xvmulsp %x6, 49, 36 \n\t" + "xvmulsp %x7, 50, 36 \n\t" + "xvmulsp %x8, 51, 36 \n\t" + "xvmulsp 44, 32, 37 \n\t" // s * x + "xvmulsp 45, 33, 37 \n\t" + + "lxvd2x 32, 0, %3 \n\t" // load x + "lxvd2x 33, %15, %3 \n\t" + + "xvmulsp 46, 34, 37 \n\t" + "xvmulsp 47, 35, 37 \n\t" + + "lxvd2x 34, %16, %3 \n\t" + "lxvd2x 35, %17, %3 \n\t" + + "xvmulsp %x9, 48, 37 \n\t" // s * y + "xvmulsp %x10, 49, 37 \n\t" + + "lxvd2x 48, 0, %4 \n\t" // load y + "lxvd2x 49, %15, %4 \n\t" + + "xvmulsp %x11, 50, 37 \n\t" + "xvmulsp %x12, 51, 37 \n\t" + + "lxvd2x 50, %16, %4 \n\t" + "lxvd2x 51, %17, %4 \n\t" + + "xvaddsp 40, 40, %x9 \n\t" // c * x + s * y + "xvaddsp 41, 41, %x10 \n\t" // c * x + s * y + + "addi %3, %3, -64 \n\t" + "addi %4, %4, -64 \n\t" + + "xvaddsp 42, 42, %x11 \n\t" // c * x + s * y + "xvaddsp 43, 43, %x12 \n\t" // c * x + s * y + + "xvsubsp %x5, %x5, 44 \n\t" // c * y - s * x + "xvsubsp %x6, %x6, 45 \n\t" // c * y - s * x + "xvsubsp %x7, %x7, 46 \n\t" // c * y - s * x + "xvsubsp %x8, %x8, 47 \n\t" // c * y - s * x + + "stxvd2x 40, 0, %3 \n\t" // store x + "stxvd2x 41, %15, %3 \n\t" + "stxvd2x 42, %16, %3 \n\t" + "stxvd2x 43, %17, %3 \n\t" + + "stxvd2x %x5, 0, %4 \n\t" // store y + "stxvd2x %x6, %15, %4 \n\t" + "stxvd2x %x7, %16, %4 \n\t" + "stxvd2x %x8, %17, %4 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %4, %4, 128 \n\t" + + "addic. %2, %2, -16 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmulsp 40, 32, 36 \n\t" // c * x + "xvmulsp 41, 33, 36 \n\t" + "xvmulsp 42, 34, 36 \n\t" + "xvmulsp 43, 35, 36 \n\t" + + "xvmulsp %x5, 48, 36 \n\t" // c * y + "xvmulsp %x6, 49, 36 \n\t" + "xvmulsp %x7, 50, 36 \n\t" + "xvmulsp %x8, 51, 36 \n\t" + + "xvmulsp 44, 32, 37 \n\t" // s * x + "xvmulsp 45, 33, 37 \n\t" + "xvmulsp 46, 34, 37 \n\t" + "xvmulsp 47, 35, 37 \n\t" + + "xvmulsp %x9, 48, 37 \n\t" // s * y + "xvmulsp %x10, 49, 37 \n\t" + "xvmulsp %x11, 50, 37 \n\t" + "xvmulsp %x12, 51, 37 \n\t" + + "addi %3, %3, -64 \n\t" + "addi %4, %4, -64 \n\t" + + "xvaddsp 40, 40, %x9 \n\t" // c * x + s * y + "xvaddsp 41, 41, %x10 \n\t" // c * x + s * y + "xvaddsp 42, 42, %x11 \n\t" // c * x + s * y + "xvaddsp 43, 43, %x12 \n\t" // c * x + s * y + + "xvsubsp %x5, %x5, 44 \n\t" // c * y - s * x + "xvsubsp %x6, %x6, 45 \n\t" // c * y - s * x + "xvsubsp %x7, %x7, 46 \n\t" // c * y - s * x + "xvsubsp %x8, %x8, 47 \n\t" // c * y - s * x + + "stxvd2x 40, 0, %3 \n\t" // store x + "stxvd2x 41, %15, %3 \n\t" + "stxvd2x 42, %16, %3 \n\t" + "stxvd2x 43, %17, %3 \n\t" + + "stxvd2x %x5, 0, %4 \n\t" // store y + "stxvd2x %x6, %15, %4 \n\t" + "stxvd2x %x7, %16, %4 \n\t" + "stxvd2x %x8, %17, %4 \n" + + "#n=%2 x=%0=%3 y=%1=%4 c=%13 s=%14 o16=%15 o32=%16 o48=%17\n" + "#t0=%x5 t1=%x6 t2=%x7 t3=%x8 t4=%x9 t5=%x10 t6=%x11 t7=%x12" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y), // 4 + "=wa" (t0), // 5 + "=wa" (t1), // 6 + "=wa" (t2), // 7 + "=wa" (t3), // 8 + "=wa" (t4), // 9 + "=wa" (t5), // 10 + "=wa" (t6), // 11 + "=wa" (t7) // 12 + : + "f" (c), // 13 + "f" (s), // 14 + "b" (16), // 15 + "b" (32), // 16 + "b" (48) // 17 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); +} diff --git a/kernel/power/sscal.c b/kernel/power/sscal.c index c6ef5e9695..bd5cdc43fe 100644 --- a/kernel/power/sscal.c +++ b/kernel/power/sscal.c @@ -42,11 +42,10 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if !defined(HAVE_KERNEL_16) -static void sscal_kernel_16( BLASLONG n, FLOAT *da , FLOAT *x ) +static void sscal_kernel_16 (BLASLONG n, FLOAT *x, FLOAT alpha) { BLASLONG i; - FLOAT alpha = *da; for( i=0; i 0 ) { - alpha[0]=da; - alpha[1]=da; - alpha[2]=da; - alpha[3]=da; - sscal_kernel_16_zero(n1 , alpha , x); + sscal_kernel_16_zero(n1, x); j=n1; } @@ -127,11 +121,7 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da, FLOAT *x, BLAS BLASLONG n1 = n & -32; if ( n1 > 0 ) { - alpha[0]=da; - alpha[1]=da; - alpha[2]=da; - alpha[3]=da; - sscal_kernel_16(n1 , alpha , x); + sscal_kernel_16(n1, x, da); j=n1; } while(j < n) diff --git a/kernel/power/sscal_microk_power8.c b/kernel/power/sscal_microk_power8.c index 963cec7776..058ff3399b 100644 --- a/kernel/power/sscal_microk_power8.c +++ b/kernel/power/sscal_microk_power8.c @@ -35,184 +35,150 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_16 1 -static void sscal_kernel_16( BLASLONG n, FLOAT *alpha, FLOAT *x) __attribute__ ((noinline)); - -static void sscal_kernel_16( BLASLONG n, FLOAT *alpha, FLOAT *x) +static void sscal_kernel_16 (long n, float *x, float alpha) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *x2=x+1; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "lxvw4x 32, 0, %3 \n\t" - "addi %1, %1, -4 \n\t" - - "dcbt %2, %4 \n\t" - - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %4 \n\t" - - "xvmulsp 48, 40, 32 \n\t" - "xvmulsp 49, 41, 32 \n\t" - "lxvw4x 40, 0, %2 \n\t" - "lxvw4x 41, %5, %2 \n\t" - "xvmulsp 50, 42, 32 \n\t" - "xvmulsp 51, 43, 32 \n\t" - "lxvw4x 42, %6, %2 \n\t" - "lxvw4x 43, %7, %2 \n\t" - "xvmulsp 52, 44, 32 \n\t" - "xvmulsp 53, 45, 32 \n\t" - "lxvw4x 44, %8, %2 \n\t" - "lxvw4x 45, %9, %2 \n\t" - "xvmulsp 54, 46, 32 \n\t" - "xvmulsp 55, 47, 32 \n\t" - "lxvw4x 46, %10, %2 \n\t" - "lxvw4x 47, %11, %2 \n\t" - - "stxvw4x 48, 0, %1 \n\t" - "stxvw4x 49, %5, %1 \n\t" - "stxvw4x 50, %6, %1 \n\t" - "stxvw4x 51, %7, %1 \n\t" - "stxvw4x 52, %8, %1 \n\t" - "stxvw4x 53, %9, %1 \n\t" - "stxvw4x 54, %10, %1 \n\t" - "stxvw4x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmulsp 48, 40, 32 \n\t" - "xvmulsp 49, 41, 32 \n\t" - "xvmulsp 50, 42, 32 \n\t" - "xvmulsp 51, 43, 32 \n\t" - "xvmulsp 52, 44, 32 \n\t" - "xvmulsp 53, 45, 32 \n\t" - "xvmulsp 54, 46, 32 \n\t" - "xvmulsp 55, 47, 32 \n\t" - - "stxvw4x 48, 0, %1 \n\t" - "stxvw4x 49, %5, %1 \n\t" - "stxvw4x 50, %6, %1 \n\t" - "stxvw4x 51, %7, %1 \n\t" - "stxvw4x 52, %8, %1 \n\t" - "stxvw4x 53, %9, %1 \n\t" - "stxvw4x 54, %10, %1 \n\t" - "stxvw4x 55, %11, %1 \n\t" - - : - : - "r" (i), // 0 - "r" (x2), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - -static void sscal_kernel_16_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) __attribute__ ((noinline)); - -static void sscal_kernel_16_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xscvdpspn %x3, %x3 \n\t" + "xxspltw %x3, %x3, 0 \n\t" + + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %4, %2 \n\t" + "lxvd2x 34, %5, %2 \n\t" + "lxvd2x 35, %6, %2 \n\t" + "lxvd2x 36, %7, %2 \n\t" + "lxvd2x 37, %8, %2 \n\t" + "lxvd2x 38, %9, %2 \n\t" + "lxvd2x 39, %10, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmulsp 40, 32, %x3 \n\t" + "xvmulsp 41, 33, %x3 \n\t" + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %4, %2 \n\t" + "xvmulsp 42, 34, %x3 \n\t" + "xvmulsp 43, 35, %x3 \n\t" + "lxvd2x 34, %5, %2 \n\t" + "lxvd2x 35, %6, %2 \n\t" + "xvmulsp 44, 36, %x3 \n\t" + "xvmulsp 45, 37, %x3 \n\t" + "lxvd2x 36, %7, %2 \n\t" + "lxvd2x 37, %8, %2 \n\t" + "xvmulsp 46, 38, %x3 \n\t" + "xvmulsp 47, 39, %x3 \n\t" + "lxvd2x 38, %9, %2 \n\t" + "lxvd2x 39, %10, %2 \n\t" + + "addi %2, %2, -128 \n\t" + + "stxvd2x 40, 0, %2 \n\t" + "stxvd2x 41, %4, %2 \n\t" + "stxvd2x 42, %5, %2 \n\t" + "stxvd2x 43, %6, %2 \n\t" + "stxvd2x 44, %7, %2 \n\t" + "stxvd2x 45, %8, %2 \n\t" + "stxvd2x 46, %9, %2 \n\t" + "stxvd2x 47, %10, %2 \n\t" + + "addi %2, %2, 256 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmulsp 40, 32, %x3 \n\t" + "xvmulsp 41, 33, %x3 \n\t" + "xvmulsp 42, 34, %x3 \n\t" + "xvmulsp 43, 35, %x3 \n\t" + + "addi %2, %2, -128 \n\t" + + "xvmulsp 44, 36, %x3 \n\t" + "xvmulsp 45, 37, %x3 \n\t" + "xvmulsp 46, 38, %x3 \n\t" + "xvmulsp 47, 39, %x3 \n\t" + + "stxvd2x 40, 0, %2 \n\t" + "stxvd2x 41, %4, %2 \n\t" + "stxvd2x 42, %5, %2 \n\t" + "stxvd2x 43, %6, %2 \n\t" + "stxvd2x 44, %7, %2 \n\t" + "stxvd2x 45, %8, %2 \n\t" + "stxvd2x 46, %9, %2 \n\t" + "stxvd2x 47, %10, %2 \n" + + "#n=%1 alpha=%3 x=%0=%2 o16=%4 o32=%5 o48=%6 o64=%7 o80=%8 o96=%9 o112=%10" + : + "+m" (*x), + "+r" (n), // 1 + "+b" (x), // 2 + "+f" (alpha) // 3 + : + "b" (16), // 4 + "b" (32), // 5 + "b" (48), // 6 + "b" (64), // 7 + "b" (80), // 8 + "b" (96), // 9 + "b" (112) // 10 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} + + +static void sscal_kernel_16_zero (long n, float *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *x2=x+1; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "xxlxor 32 , 32 , 32 \n\t" - "addi %1, %1, -4 \n\t" - - - ".align 5 \n\t" - "1: \n\t" - - "stxvw4x 32, 0, %1 \n\t" - "stxvw4x 32, %5, %1 \n\t" - "stxvw4x 32, %6, %1 \n\t" - "stxvw4x 32, %7, %1 \n\t" - "stxvw4x 32, %8, %1 \n\t" - "stxvw4x 32, %9, %1 \n\t" - "stxvw4x 32, %10, %1 \n\t" - "stxvw4x 32, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (x2), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __vector float t0; + + __asm__ + ( + "xxlxor %x3, %x3, %x3 \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x %x3, 0, %2 \n\t" + "stxvd2x %x3, %4, %2 \n\t" + "stxvd2x %x3, %5, %2 \n\t" + "stxvd2x %x3, %6, %2 \n\t" + "stxvd2x %x3, %7, %2 \n\t" + "stxvd2x %x3, %8, %2 \n\t" + "stxvd2x %x3, %9, %2 \n\t" + "stxvd2x %x3, %10, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -32 \n\t" + "bgt 1b \n" + + "#n=%1 x=%0=%2 t0=%x3 o16=%4 o32=%5 o48=%6 o64=%7 o80=%8 o96=%9 o112=%10" + : + "=m" (*x), + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0) // 3 + : + "b" (16), // 4 + "b" (32), // 5 + "b" (48), // 6 + "b" (64), // 7 + "b" (80), // 8 + "b" (96), // 9 + "b" (112) // 10 + : + "cr0" + ); +} diff --git a/kernel/power/sswap_microk_power8.c b/kernel/power/sswap_microk_power8.c index c48e743de4..cfefdd6eff 100644 --- a/kernel/power/sswap_microk_power8.c +++ b/kernel/power/sswap_microk_power8.c @@ -35,102 +35,74 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_32 1 -static void sswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void sswap_kernel_32( BLASLONG n, FLOAT *x, FLOAT *y) +static void sswap_kernel_32 (long n, float *x, float *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "addi %3, %3, -4 \n\t" - "addi %4, %4, -4 \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "lxvw4x 32, 0, %2 \n\t" - "lxvw4x 33, %5, %2 \n\t" - "lxvw4x 34, %6, %2 \n\t" - "lxvw4x 35, %7, %2 \n\t" - "lxvw4x 36, %8, %2 \n\t" - "lxvw4x 37, %9, %2 \n\t" - "lxvw4x 38, %10, %2 \n\t" - "lxvw4x 39, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvw4x 48, 0, %1 \n\t" - "lxvw4x 49, %5, %1 \n\t" - "lxvw4x 50, %6, %1 \n\t" - "lxvw4x 51, %7, %1 \n\t" - "lxvw4x 52, %8, %1 \n\t" - "lxvw4x 53, %9, %1 \n\t" - "lxvw4x 54, %10, %1 \n\t" - "lxvw4x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvw4x 32, 0, %3 \n\t" - "stxvw4x 33, %5, %3 \n\t" - "stxvw4x 34, %6, %3 \n\t" - "stxvw4x 35, %7, %3 \n\t" - "stxvw4x 36, %8, %3 \n\t" - "stxvw4x 37, %9, %3 \n\t" - "stxvw4x 38, %10, %3 \n\t" - "stxvw4x 39, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvw4x 48, 0, %4 \n\t" - "stxvw4x 49, %5, %4 \n\t" - "stxvw4x 50, %6, %4 \n\t" - "stxvw4x 51, %7, %4 \n\t" - "stxvw4x 52, %8, %4 \n\t" - "stxvw4x 53, %9, %4 \n\t" - "stxvw4x 54, %10, %4 \n\t" - "stxvw4x 55, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "addic. %0 , %0 , -32 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (y2), // 3 - "r" (x2), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "%3", "%4", "memory" - ); - -} - - + __asm__ + ( + ".p2align 5 \n" + "1: \n\t" + + "lxvd2x 32, 0, %4 \n\t" + "lxvd2x 33, %5, %4 \n\t" + "lxvd2x 34, %6, %4 \n\t" + "lxvd2x 35, %7, %4 \n\t" + "lxvd2x 36, %8, %4 \n\t" + "lxvd2x 37, %9, %4 \n\t" + "lxvd2x 38, %10, %4 \n\t" + "lxvd2x 39, %11, %4 \n\t" + + "lxvd2x 40, 0, %3 \n\t" + "lxvd2x 41, %5, %3 \n\t" + "lxvd2x 42, %6, %3 \n\t" + "lxvd2x 43, %7, %3 \n\t" + "lxvd2x 44, %8, %3 \n\t" + "lxvd2x 45, %9, %3 \n\t" + "lxvd2x 46, %10, %3 \n\t" + "lxvd2x 47, %11, %3 \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %4 \n\t" + "stxvd2x 41, %5, %4 \n\t" + "stxvd2x 42, %6, %4 \n\t" + "stxvd2x 43, %7, %4 \n\t" + "stxvd2x 44, %8, %4 \n\t" + "stxvd2x 45, %9, %4 \n\t" + "stxvd2x 46, %10, %4 \n\t" + "stxvd2x 47, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "addic. %2, %2, -32 \n\t" + "bgt 1b \n" + + "#n=%2 x=%0=%3 y=%1=%4 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y) // 4 + : + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/zasum.c b/kernel/power/zasum.c index abd6ec08a5..0b6b87d46d 100644 --- a/kernel/power/zasum.c +++ b/kernel/power/zasum.c @@ -53,7 +53,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_8 -static void zasum_kernel_8(BLASLONG n, FLOAT *x1, FLOAT *svec) +static FLOAT zasum_kernel_8(BLASLONG n, FLOAT *x1) { BLASLONG i=0; @@ -92,9 +92,7 @@ static void zasum_kernel_8(BLASLONG n, FLOAT *x1, FLOAT *svec) } - svec[0] = sum0+sum1+sum2+sum3; - svec[1] = 0.0; - + return sum0+sum1+sum2+sum3; } #endif @@ -104,7 +102,6 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) BLASLONG i=0; BLASLONG ip=0; FLOAT sumf = 0.0; - FLOAT svec[2] __attribute__ ((aligned (16)));; BLASLONG n1; BLASLONG inc_x2; @@ -117,8 +114,7 @@ FLOAT CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x) if ( n1 > 0 ) { - zasum_kernel_8(n1, x, svec); - sumf = svec[0] + svec[1]; + sumf = zasum_kernel_8(n1, x); i=n1; ip=2*n1; } diff --git a/kernel/power/zasum_microk_power8.c b/kernel/power/zasum_microk_power8.c index b9f6c0ac60..82366902d5 100644 --- a/kernel/power/zasum_microk_power8.c +++ b/kernel/power/zasum_microk_power8.c @@ -34,144 +34,140 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_8 1 -static void zasum_kernel_8( BLASLONG n, FLOAT *x, FLOAT *svec) __attribute__ ((noinline)); -static void zasum_kernel_8( BLASLONG n, FLOAT *x, FLOAT *svec) +static double zasum_kernel_8 (long n, double *x) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "dcbt %2 , %4 \n\t" - - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2 , %4 \n\t" - - "xvabsdp 48, 40 \n\t" - "xvabsdp 49, 41 \n\t" - "xvabsdp 50, 42 \n\t" - "xvabsdp 51, 43 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - - "xvabsdp 52, 44 \n\t" - "xvabsdp 53, 45 \n\t" - - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "xvabsdp 54, 46 \n\t" - "xvabsdp 55, 47 \n\t" - - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - - "xvadddp 32, 32, 48 \n\t" - "xvadddp 33, 33, 49 \n\t" - - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "xvadddp 34, 34, 50 \n\t" - "xvadddp 35, 35, 51 \n\t" - "addi %2, %2, 128 \n\t" - "xvadddp 36, 36, 52 \n\t" - "xvadddp 37, 37, 53 \n\t" - "addic. %0 , %0 , -8 \n\t" - "xvadddp 38, 38, 54 \n\t" - "xvadddp 39, 39, 55 \n\t" - - "bgt 1b \n\t" - - "2: \n\t" - - - "xvabsdp 48, 40 \n\t" - "xvabsdp 49, 41 \n\t" - "xvabsdp 50, 42 \n\t" - "xvabsdp 51, 43 \n\t" - "xvabsdp 52, 44 \n\t" - "xvabsdp 53, 45 \n\t" - "xvabsdp 54, 46 \n\t" - "xvabsdp 55, 47 \n\t" - - "xvadddp 32, 32, 48 \n\t" - "xvadddp 33, 33, 49 \n\t" - "xvadddp 34, 34, 50 \n\t" - "xvadddp 35, 35, 51 \n\t" - "xvadddp 36, 36, 52 \n\t" - "xvadddp 37, 37, 53 \n\t" - "xvadddp 38, 38, 54 \n\t" - "xvadddp 39, 39, 55 \n\t" - - "xvadddp 32, 32, 33 \n\t" - "xvadddp 34, 34, 35 \n\t" - "xvadddp 36, 36, 37 \n\t" - "xvadddp 38, 38, 39 \n\t" - - "xvadddp 32, 32, 34 \n\t" - "xvadddp 36, 36, 38 \n\t" - - "xvadddp 32, 32, 36 \n\t" - - - "stxvd2x 32, 0, %3 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (svec), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2", "memory" - ); - -} - - + double sum; + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -8 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvabsdp 48, 40 \n\t" + "xvabsdp 49, 41 \n\t" + "xvabsdp 50, 42 \n\t" + "xvabsdp 51, 43 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %8, %2 \n\t" + + "xvabsdp %x3, 44 \n\t" + "xvabsdp %x4, 45 \n\t" + + "lxvd2x 42, %9, %2 \n\t" + "lxvd2x 43, %10, %2 \n\t" + + "xvabsdp %x5, 46 \n\t" + "xvabsdp %x6, 47 \n\t" + + "lxvd2x 44, %11, %2 \n\t" + "lxvd2x 45, %12, %2 \n\t" + + "xvadddp 32, 32, 48 \n\t" + "xvadddp 33, 33, 49 \n\t" + + "lxvd2x 46, %13, %2 \n\t" + "lxvd2x 47, %14, %2 \n\t" + + "xvadddp 34, 34, 50 \n\t" + "xvadddp 35, 35, 51 \n\t" + "addi %2, %2, 128 \n\t" + "xvadddp 36, 36, %x3 \n\t" + "xvadddp 37, 37, %x4 \n\t" + "addic. %1, %1, -8 \n\t" + "xvadddp 38, 38, %x5 \n\t" + "xvadddp 39, 39, %x6 \n\t" + + "bgt 1b \n" + + "2: \n\t" + + "xvabsdp 48, 40 \n\t" + "xvabsdp 49, 41 \n\t" + "xvabsdp 50, 42 \n\t" + "xvabsdp 51, 43 \n\t" + "xvabsdp %x3, 44 \n\t" + "xvabsdp %x4, 45 \n\t" + "xvabsdp %x5, 46 \n\t" + "xvabsdp %x6, 47 \n\t" + + "xvadddp 32, 32, 48 \n\t" + "xvadddp 33, 33, 49 \n\t" + "xvadddp 34, 34, 50 \n\t" + "xvadddp 35, 35, 51 \n\t" + "xvadddp 36, 36, %x3 \n\t" + "xvadddp 37, 37, %x4 \n\t" + "xvadddp 38, 38, %x5 \n\t" + "xvadddp 39, 39, %x6 \n\t" + + "xvadddp 32, 32, 33 \n\t" + "xvadddp 34, 34, 35 \n\t" + "xvadddp 36, 36, 37 \n\t" + "xvadddp 38, 38, 39 \n\t" + + "xvadddp 32, 32, 34 \n\t" + "xvadddp 36, 36, 38 \n\t" + + "xvadddp 32, 32, 36 \n\t" + + "xxswapd 33, 32 \n\t" + "xsadddp %x0, 32, 33 \n" + + "#n=%1 x=%3=%2 sum=%0 o16=%8 o32=%9 o48=%10 o64=%11 o80=%12 o96=%13 o112=%14\n" + "#t0=%x3 t1=%x4 t2=%x5 t3=%x6" + : + "=d" (sum), // 0 + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0), // 3 + "=wa" (t1), // 4 + "=wa" (t2), // 5 + "=wa" (t3) // 6 + : + "m" (*x), + "b" (16), // 8 + "b" (32), // 9 + "b" (48), // 10 + "b" (64), // 11 + "b" (80), // 12 + "b" (96), // 13 + "b" (112) // 14 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); + + return sum; +} diff --git a/kernel/power/zaxpy.c b/kernel/power/zaxpy.c index 0ee0c1bf95..dd7ab6c3cc 100644 --- a/kernel/power/zaxpy.c +++ b/kernel/power/zaxpy.c @@ -78,7 +78,6 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, { BLASLONG i=0; BLASLONG ix=0,iy=0; - FLOAT da[4]; if ( n <= 0 ) return(0); @@ -89,11 +88,7 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r, FLOAT da_i, if ( n1 ) { - da[0] = da_r; - da[1] = da_r; - da[2] = da_i; - da[3] = da_i; - zaxpy_kernel_4(n1, x, y , da ); + zaxpy_kernel_4 (n1, x, y, da_r, da_i); ix = 2 * n1; } i = n1; diff --git a/kernel/power/zaxpy_microk_power8.c b/kernel/power/zaxpy_microk_power8.c index c8a529fd92..124614f62e 100644 --- a/kernel/power/zaxpy_microk_power8.c +++ b/kernel/power/zaxpy_microk_power8.c @@ -35,216 +35,225 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_4 1 -static void zaxpy_kernel_4( BLASLONG n, FLOAT *x, FLOAT *y , FLOAT *alpha) __attribute__ ((noinline)); - -static void zaxpy_kernel_4( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *alpha) +static void zaxpy_kernel_4 (long n, double *x, double *y, + double alpha_r, double alpha_i) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *y2=y+1; - BLASLONG pre = 384; - #if !defined(CONJ) - FLOAT mvec[2] = { -1.0, 1.0 }; + static const double mvec[2] = { -1.0, 1.0 }; #else - FLOAT mvec[2] = { 1.0, -1.0 }; + static const double mvec[2] = { 1.0, -1.0 }; #endif - - - __asm__ __volatile__ - ( - - "lxsdx 34, 0 , %4 \n\t" // alpha_r - "lxsdx 35, %5, %4 \n\t" // alpha_i - "xxspltd 32, 34, 0 \n\t" - "xxspltd 33, 35, 0 \n\t" - - "lxvd2x 36, 0, %9 \n\t" // mvec + const double *mvecp = mvec; + + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + __vector double t4; + __vector double t5; + __vector double t6; + __vector double t7; + __vector double t8; + __vector double t9; + __vector double t10; + __vector double t11; + long ytmp; + + __asm__ + ( + "xxspltd 32, %x19, 0 \n\t" // alpha_r + "xxspltd 33, %x20, 0 \n\t" // alpha_i + + "lxvd2x 36, 0, %21 \n\t" // mvec #if !defined(CONJ) - "xvmuldp 33, 33 , 36 \n\t" // alpha_i * mvec + "xvmuldp 33, 33, 36 \n\t" // alpha_i * mvec #else - "xvmuldp 32, 32 , 36 \n\t" // alpha_r * mvec + "xvmuldp 32, 32, 36 \n\t" // alpha_r * mvec #endif - "addi %8, %8, -8 \n\t" - - "dcbt %2, %10 \n\t" - "dcbt %3, %10 \n\t" - - - "lxvd2x 40, 0, %2 \n\t" // x0 - "lxvd2x 41, %5, %2 \n\t" // x1 - "lxvd2x 42, %6, %2 \n\t" // x2 - "lxvd2x 43, %7, %2 \n\t" // x3 - - "lxvd2x 48, 0, %3 \n\t" // y0 - "lxvd2x 49, %5, %3 \n\t" // y1 - "lxvd2x 50, %6, %3 \n\t" // y2 - "lxvd2x 51, %7, %3 \n\t" // y3 - - "xxswapd 56, 40 \n\t" // exchange real and imag part - "xxswapd 57, 41 \n\t" // exchange real and imag part - "xxswapd 58, 42 \n\t" // exchange real and imag part - "xxswapd 59, 43 \n\t" // exchange real and imag part - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "lxvd2x 44, 0, %2 \n\t" // x4 - "lxvd2x 45, %5, %2 \n\t" // x5 - "lxvd2x 46, %6, %2 \n\t" // x6 - "lxvd2x 47, %7, %2 \n\t" // x7 - - "lxvd2x 52, 0, %3 \n\t" // y4 - "lxvd2x 53, %5, %3 \n\t" // y5 - "lxvd2x 54, %6, %3 \n\t" // y6 - "lxvd2x 55, %7, %3 \n\t" // y7 - - "xxswapd 60, 44 \n\t" // exchange real and imag part - "xxswapd 61, 45 \n\t" // exchange real and imag part - "xxswapd 62, 46 \n\t" // exchange real and imag part - "xxswapd 63, 47 \n\t" // exchange real and imag part - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %10 \n\t" - "dcbt %3, %10 \n\t" - - "xvmaddadp 48, 40, 32 \n\t" // alpha_r * x0_r , alpha_r * x0_i - "xvmaddadp 49, 41, 32 \n\t" - "lxvd2x 40, 0, %2 \n\t" // x0 - "lxvd2x 41, %5, %2 \n\t" // x1 - "xvmaddadp 50, 42, 32 \n\t" - "xvmaddadp 51, 43, 32 \n\t" - "lxvd2x 42, %6, %2 \n\t" // x2 - "lxvd2x 43, %7, %2 \n\t" // x3 - - "xvmaddadp 52, 44, 32 \n\t" - "addi %2, %2, 64 \n\t" - "xvmaddadp 53, 45, 32 \n\t" - "lxvd2x 44, 0, %2 \n\t" // x4 - "lxvd2x 45, %5, %2 \n\t" // x5 - "xvmaddadp 54, 46, 32 \n\t" - "xvmaddadp 55, 47, 32 \n\t" - "lxvd2x 46, %6, %2 \n\t" // x6 - "lxvd2x 47, %7, %2 \n\t" // x7 - - "xvmaddadp 48, 56, 33 \n\t" // alpha_i * x0_i , alpha_i * x0_r - "addi %2, %2, 64 \n\t" - "xvmaddadp 49, 57, 33 \n\t" - "xvmaddadp 50, 58, 33 \n\t" - "xvmaddadp 51, 59, 33 \n\t" - - "xvmaddadp 52, 60, 33 \n\t" - "xvmaddadp 53, 61, 33 \n\t" - "xvmaddadp 54, 62, 33 \n\t" - "xvmaddadp 55, 63, 33 \n\t" - - "stxvd2x 48, 0, %8 \n\t" - "stxvd2x 49, %5, %8 \n\t" - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - "stxvd2x 52, 0, %8 \n\t" - "stxvd2x 53, %5, %8 \n\t" - "stxvd2x 54, %6, %8 \n\t" - "stxvd2x 55, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - "xxswapd 56, 40 \n\t" // exchange real and imag part - "xxswapd 57, 41 \n\t" // exchange real and imag part - "lxvd2x 48, 0, %3 \n\t" // y0 - "lxvd2x 49, %5, %3 \n\t" // y1 - "xxswapd 58, 42 \n\t" // exchange real and imag part - "xxswapd 59, 43 \n\t" // exchange real and imag part - "lxvd2x 50, %6, %3 \n\t" // y2 - "lxvd2x 51, %7, %3 \n\t" // y3 - - "xxswapd 60, 44 \n\t" // exchange real and imag part - "addi %3, %3, 64 \n\t" - "xxswapd 61, 45 \n\t" // exchange real and imag part - "lxvd2x 52, 0, %3 \n\t" // y4 - "lxvd2x 53, %5, %3 \n\t" // y5 - "xxswapd 62, 46 \n\t" // exchange real and imag part - "xxswapd 63, 47 \n\t" // exchange real and imag part - "lxvd2x 54, %6, %3 \n\t" // y6 - "lxvd2x 55, %7, %3 \n\t" // y7 - - "addi %3, %3, 64 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmaddadp 48, 40, 32 \n\t" // alpha_r * x0_r , alpha_r * x0_i - "xvmaddadp 49, 41, 32 \n\t" - "xvmaddadp 50, 42, 32 \n\t" - "xvmaddadp 51, 43, 32 \n\t" - - "xvmaddadp 52, 44, 32 \n\t" - "xvmaddadp 53, 45, 32 \n\t" - "xvmaddadp 54, 46, 32 \n\t" - "xvmaddadp 55, 47, 32 \n\t" - - "xvmaddadp 48, 56, 33 \n\t" // alpha_i * x0_i , alpha_i * x0_r - "xvmaddadp 49, 57, 33 \n\t" - "xvmaddadp 50, 58, 33 \n\t" - "xvmaddadp 51, 59, 33 \n\t" - - "xvmaddadp 52, 60, 33 \n\t" - "xvmaddadp 53, 61, 33 \n\t" - "xvmaddadp 54, 62, 33 \n\t" - "xvmaddadp 55, 63, 33 \n\t" - - - "stxvd2x 48, 0, %8 \n\t" - "stxvd2x 49, %5, %8 \n\t" - "stxvd2x 50, %6, %8 \n\t" - "stxvd2x 51, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - "stxvd2x 52, 0, %8 \n\t" - "stxvd2x 53, %5, %8 \n\t" - "stxvd2x 54, %6, %8 \n\t" - "stxvd2x 55, %7, %8 \n\t" - - "addi %8, %8, 64 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (y1), // 3 - "r" (alpha), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (y2), // 8 - "r" (mvec), // 9 - "r" (pre) // 10 - : "cr0", "%0", "%2" , "%3", "%8", "memory" - ); - -} - - + "mr %16, %3 \n\t" + "dcbt 0, %2 \n\t" + "dcbt 0, %3 \n\t" + + + "lxvd2x 40, 0, %2 \n\t" // x0 + "lxvd2x 41, %22, %2 \n\t" // x1 + "lxvd2x 42, %23, %2 \n\t" // x2 + "lxvd2x 43, %24, %2 \n\t" // x3 + + "lxvd2x 48, 0, %3 \n\t" // y0 + "lxvd2x 49, %22, %3 \n\t" // y1 + "lxvd2x 50, %23, %3 \n\t" // y2 + "lxvd2x 51, %24, %3 \n\t" // y3 + + "xxswapd %x8, 40 \n\t" // exchange real and imag part + "xxswapd %x9, 41 \n\t" // exchange real and imag part + "xxswapd %x10, 42 \n\t" // exchange real and imag part + "xxswapd %x11, 43 \n\t" // exchange real and imag part + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "lxvd2x 44, 0, %2 \n\t" // x4 + "lxvd2x 45, %22, %2 \n\t" // x5 + "lxvd2x 46, %23, %2 \n\t" // x6 + "lxvd2x 47, %24, %2 \n\t" // x7 + + "lxvd2x %x4, 0, %3 \n\t" // y4 + "lxvd2x %x5, %22, %3 \n\t" // y5 + "lxvd2x %x6, %23, %3 \n\t" // y6 + "lxvd2x %x7, %24, %3 \n\t" // y7 + + "xxswapd %x12, 44 \n\t" // exchange real and imag part + "xxswapd %x13, 45 \n\t" // exchange real and imag part + "xxswapd %x14, 46 \n\t" // exchange real and imag part + "xxswapd %x15, 47 \n\t" // exchange real and imag part + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "addic. %1, %1, -8 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmaddadp 48, 40, 32 \n\t" // alpha_r * x0_r , alpha_r * x0_i + "xvmaddadp 49, 41, 32 \n\t" + "lxvd2x 40, 0, %2 \n\t" // x0 + "lxvd2x 41, %22, %2 \n\t" // x1 + "xvmaddadp 50, 42, 32 \n\t" + "xvmaddadp 51, 43, 32 \n\t" + "lxvd2x 42, %23, %2 \n\t" // x2 + "lxvd2x 43, %24, %2 \n\t" // x3 + + "xvmaddadp %x4, 44, 32 \n\t" + "addi %2, %2, 64 \n\t" + "xvmaddadp %x5, 45, 32 \n\t" + "lxvd2x 44, 0, %2 \n\t" // x4 + "lxvd2x 45, %22, %2 \n\t" // x5 + "xvmaddadp %x6, 46, 32 \n\t" + "xvmaddadp %x7, 47, 32 \n\t" + "lxvd2x 46, %23, %2 \n\t" // x6 + "lxvd2x 47, %24, %2 \n\t" // x7 + + "xvmaddadp 48, %x8, 33 \n\t" // alpha_i * x0_i , alpha_i * x0_r + "addi %2, %2, 64 \n\t" + "xvmaddadp 49, %x9, 33 \n\t" + "xvmaddadp 50, %x10, 33 \n\t" + "xvmaddadp 51, %x11, 33 \n\t" + + "xvmaddadp %x4, %x12, 33 \n\t" + "xvmaddadp %x5, %x13, 33 \n\t" + "xvmaddadp %x6, %x14, 33 \n\t" + "xvmaddadp %x7, %x15, 33 \n\t" + + "stxvd2x 48, 0, %16 \n\t" + "stxvd2x 49, %22, %16 \n\t" + "stxvd2x 50, %23, %16 \n\t" + "stxvd2x 51, %24, %16 \n\t" + + "addi %16, %16, 64 \n\t" + + "stxvd2x %x4, 0, %16 \n\t" + "stxvd2x %x5, %22, %16 \n\t" + "stxvd2x %x6, %23, %16 \n\t" + "stxvd2x %x7, %24, %16 \n\t" + + "addi %16, %16, 64 \n\t" + + "xxswapd %x8, 40 \n\t" // exchange real and imag part + "xxswapd %x9, 41 \n\t" // exchange real and imag part + "lxvd2x 48, 0, %3 \n\t" // y0 + "lxvd2x 49, %22, %3 \n\t" // y1 + "xxswapd %x10, 42 \n\t" // exchange real and imag part + "xxswapd %x11, 43 \n\t" // exchange real and imag part + "lxvd2x 50, %23, %3 \n\t" // y2 + "lxvd2x 51, %24, %3 \n\t" // y3 + + "xxswapd %x12, 44 \n\t" // exchange real and imag part + "addi %3, %3, 64 \n\t" + "xxswapd %x13, 45 \n\t" // exchange real and imag part + "lxvd2x %x4, 0, %3 \n\t" // y4 + "lxvd2x %x5, %22, %3 \n\t" // y5 + "xxswapd %x14, 46 \n\t" // exchange real and imag part + "xxswapd %x15, 47 \n\t" // exchange real and imag part + "lxvd2x %x6, %23, %3 \n\t" // y6 + "lxvd2x %x7, %24, %3 \n\t" // y7 + + "addi %3, %3, 64 \n\t" + + "addic. %1, %1, -8 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmaddadp 48, 40, 32 \n\t" // alpha_r * x0_r , alpha_r * x0_i + "xvmaddadp 49, 41, 32 \n\t" + "xvmaddadp 50, 42, 32 \n\t" + "xvmaddadp 51, 43, 32 \n\t" + + "xvmaddadp %x4, 44, 32 \n\t" + "xvmaddadp %x5, 45, 32 \n\t" + "xvmaddadp %x6, 46, 32 \n\t" + "xvmaddadp %x7, 47, 32 \n\t" + + "xvmaddadp 48, %x8, 33 \n\t" // alpha_i * x0_i , alpha_i * x0_r + "xvmaddadp 49, %x9, 33 \n\t" + "xvmaddadp 50, %x10, 33 \n\t" + "xvmaddadp 51, %x11, 33 \n\t" + + "xvmaddadp %x4, %x12, 33 \n\t" + "xvmaddadp %x5, %x13, 33 \n\t" + "xvmaddadp %x6, %x14, 33 \n\t" + "xvmaddadp %x7, %x15, 33 \n\t" + + "stxvd2x 48, 0, %16 \n\t" + "stxvd2x 49, %22, %16 \n\t" + "stxvd2x 50, %23, %16 \n\t" + "stxvd2x 51, %24, %16 \n\t" + + "addi %16, %16, 64 \n\t" + + "stxvd2x %x4, 0, %16 \n\t" + "stxvd2x %x5, %22, %16 \n\t" + "stxvd2x %x6, %23, %16 \n\t" + "stxvd2x %x7, %24, %16 \n" + + "#n=%1 x=%17=%2 y=%0=%3 alpha=(%19,%20) mvecp=%18=%16 o16=%22 o32=%23 o48=%24 ytmp=%16\n" + "#t0=%x4 t1=%x5 t2=%x6 t3=%x7 t4=%x8 t5=%x9 t6=%x10 t7=%x11 t8=%x12 t9=%x13 t10=%x14 t11=%x15" + : + "+m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y), // 3 + "=wa" (t0), // 4 + "=wa" (t1), // 5 + "=wa" (t2), // 6 + "=wa" (t3), // 7 + "=wa" (t4), // 8 + "=wa" (t5), // 9 + "=wa" (t6), // 10 + "=wa" (t7), // 11 + "=wa" (t8), // 12 + "=wa" (t9), // 13 + "=wa" (t10), // 14 + "=wa" (t11), // 15 + "=b" (ytmp) // 16 + : + "m" (*x), + "m" (*mvecp), + "d" (alpha_r), // 19 + "d" (alpha_i), // 20 + "16" (mvecp), // 21 + "b" (16), // 22 + "b" (32), // 23 + "b" (48) // 24 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); +} diff --git a/kernel/power/zcopy_microk_power8.c b/kernel/power/zcopy_microk_power8.c index 73abe084eb..5ca34b6332 100644 --- a/kernel/power/zcopy_microk_power8.c +++ b/kernel/power/zcopy_microk_power8.c @@ -35,140 +35,121 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_16 1 -static void zcopy_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void zcopy_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y) +static void zcopy_kernel_16 (long n, FLOAT *x, FLOAT *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 50, 0, %2 \n\t" - "lxvd2x 51, %5, %2 \n\t" - "lxvd2x 52, %6, %2 \n\t" - "lxvd2x 53, %7, %2 \n\t" - "lxvd2x 54, %8, %2 \n\t" - "lxvd2x 55, %9, %2 \n\t" - "lxvd2x 56, %10, %2 \n\t" - "lxvd2x 57, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "stxvd2x 40, 0, %1 \n\t" - "stxvd2x 41, %5, %1 \n\t" - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "stxvd2x 42, %6, %1 \n\t" - "stxvd2x 43, %7, %1 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "stxvd2x 44, %8, %1 \n\t" - "stxvd2x 45, %9, %1 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "stxvd2x 46, %10, %1 \n\t" - "stxvd2x 47, %11, %1 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "stxvd2x 50, 0, %1 \n\t" - "stxvd2x 51, %5, %1 \n\t" - "lxvd2x 50, 0, %2 \n\t" - "lxvd2x 51, %5, %2 \n\t" - "stxvd2x 52, %6, %1 \n\t" - "stxvd2x 53, %7, %1 \n\t" - "lxvd2x 52, %6, %2 \n\t" - "lxvd2x 53, %7, %2 \n\t" - "stxvd2x 54, %8, %1 \n\t" - "stxvd2x 55, %9, %1 \n\t" - "lxvd2x 54, %8, %2 \n\t" - "lxvd2x 55, %9, %2 \n\t" - "stxvd2x 56, %10, %1 \n\t" - "stxvd2x 57, %11, %1 \n\t" - "lxvd2x 56, %10, %2 \n\t" - "lxvd2x 57, %11, %2 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "stxvd2x 40, 0, %1 \n\t" - "stxvd2x 41, %5, %1 \n\t" - "stxvd2x 42, %6, %1 \n\t" - "stxvd2x 43, %7, %1 \n\t" - "stxvd2x 44, %8, %1 \n\t" - "stxvd2x 45, %9, %1 \n\t" - "stxvd2x 46, %10, %1 \n\t" - "stxvd2x 47, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvd2x 50, 0, %1 \n\t" - "stxvd2x 51, %5, %1 \n\t" - "stxvd2x 52, %6, %1 \n\t" - "stxvd2x 53, %7, %1 \n\t" - "stxvd2x 54, %8, %1 \n\t" - "stxvd2x 55, %9, %1 \n\t" - "stxvd2x 56, %10, %1 \n\t" - "stxvd2x 57, %11, %1 \n\t" - - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __asm__ + ( + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "lxvd2x 32, 0, %2 \n\t" + "lxvd2x 33, %5, %2 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "lxvd2x 34, %6, %2 \n\t" + "lxvd2x 35, %7, %2 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "lxvd2x 36, %8, %2 \n\t" + "lxvd2x 37, %9, %2 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + "lxvd2x 38, %10, %2 \n\t" + "lxvd2x 39, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "lxvd2x 40, 0, %2 \n\t" + "lxvd2x 41, %5, %2 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "lxvd2x 42, %6, %2 \n\t" + "lxvd2x 43, %7, %2 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "lxvd2x 44, %8, %2 \n\t" + "lxvd2x 45, %9, %2 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + "lxvd2x 46, %10, %2 \n\t" + "lxvd2x 47, %11, %2 \n\t" + + "addi %3, %3, 128 \n\t" + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -16 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n" + + "#n=%1 x=%4=%2 y=%0=%3 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "=m" (*y), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y) // 3 + : + "m" (*x), + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47" + ); +} diff --git a/kernel/power/zdot.c b/kernel/power/zdot.c index 1205b34b64..b83f832b13 100644 --- a/kernel/power/zdot.c +++ b/kernel/power/zdot.c @@ -34,7 +34,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #include "common.h" -#include #if defined(POWER8) @@ -44,8 +43,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_8 -static void zdot_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) __attribute__ ((noinline)); - static void zdot_kernel_8(BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *d) { BLASLONG register i = 0; diff --git a/kernel/power/zdot_microk_power8.c b/kernel/power/zdot_microk_power8.c index 296d3d4698..71078b66c9 100644 --- a/kernel/power/zdot_microk_power8.c +++ b/kernel/power/zdot_microk_power8.c @@ -34,186 +34,174 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **************************************************************************************/ #define HAVE_KERNEL_8 1 -static void zdot_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y , FLOAT *dot) __attribute__ ((noinline)); -static void zdot_kernel_8( BLASLONG n, FLOAT *x, FLOAT *y, FLOAT *dot) +static void zdot_kernel_8 (long n, double *x, double *y, double *dot) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - FLOAT *x1=x; - FLOAT *y1=y; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - "xxlxor 32,32,32 \n\t" - "xxlxor 33,33,33 \n\t" - "xxlxor 34,34,34 \n\t" - "xxlxor 35,35,35 \n\t" - "xxlxor 36,36,36 \n\t" - "xxlxor 37,37,37 \n\t" - "xxlxor 38,38,38 \n\t" - "xxlxor 39,39,39 \n\t" - - "dcbt %2, %8 \n\t" - "dcbt %3, %8 \n\t" - - "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i - "lxvd2x 48, 0, %3 \n\t" // y0_r, y0_i - "lxvd2x 41, %5, %2 \n\t" // x1_r, x1_i - "lxvd2x 49, %5, %3 \n\t" // y1_r, y1_i - "lxvd2x 42, %6, %2 \n\t" // x2_r, x2_i - "lxvd2x 50, %6, %3 \n\t" // y2_r, y2_i - "lxvd2x 43, %7, %2 \n\t" // x3_r, x3_i - "lxvd2x 51, %7, %3 \n\t" // y3_r, y3_i - - "xxswapd 52,48 \n\t" // y0_i, y0_r - "xxswapd 53,49 \n\t" // y1_i, y1_r - "xxswapd 54,50 \n\t" // y2_i, y2_r - "xxswapd 55,51 \n\t" // y3_i, y3_r - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - - "lxvd2x 44, 0, %2 \n\t" // x0_r, x0_i - "lxvd2x 56, 0, %3 \n\t" // y0_r, y0_i - "lxvd2x 45, %5, %2 \n\t" // x1_r, x1_i - "lxvd2x 57, %5, %3 \n\t" // y1_r, y1_i - "lxvd2x 46, %6, %2 \n\t" // x2_r, x2_i - "lxvd2x 58, %6, %3 \n\t" // y2_r, y2_i - "lxvd2x 47, %7, %2 \n\t" // x3_r, x3_i - "lxvd2x 59, %7, %3 \n\t" // y3_r, y3_i - - "xxswapd 60,56 \n\t" // y0_i, y0_r - "xxswapd 61,57 \n\t" // y1_i, y1_r - "xxswapd 62,58 \n\t" // y2_i, y2_r - "xxswapd 63,59 \n\t" // y3_i, y3_r - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %8 \n\t" - "dcbt %3, %8 \n\t" - - "xvmaddadp 32, 40, 48 \n\t" // x0_r * y0_r , x0_i * y0_i - "lxvd2x 48, 0, %3 \n\t" // y0_r, y0_i - "xvmaddadp 34, 41, 49 \n\t" // x1_r * y1_r , x1_i * y1_i - "lxvd2x 49, %5, %3 \n\t" // y1_r, y1_i - - "xvmaddadp 36, 42, 50 \n\t" // x2_r * y2_r , x2_i * y2_i - "lxvd2x 50, %6, %3 \n\t" // y2_r, y2_i - "xvmaddadp 38, 43, 51 \n\t" // x3_r * y3_r , x3_i * y3_i - "lxvd2x 51, %7, %3 \n\t" // y3_r, y3_i - - "xvmaddadp 33, 40, 52 \n\t" // x0_r * y0_i , x0_i * y0_r - "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i - "xvmaddadp 35, 41, 53 \n\t" // x1_r * y1_i , x1_i * y1_r - "lxvd2x 41, %5, %2 \n\t" // x1_r, x1_i - - "xvmaddadp 37, 42, 54 \n\t" // x2_r * y2_i , x2_i * y2_r - "lxvd2x 42, %6, %2 \n\t" // x2_r, x2_i - "xvmaddadp 39, 43, 55 \n\t" // x3_r * y3_i , x3_i * y3_r - "lxvd2x 43, %7, %2 \n\t" // x3_r, x3_i - - "xxswapd 52,48 \n\t" // y0_i, y0_r - "xxswapd 53,49 \n\t" // y1_i, y1_r - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "xxswapd 54,50 \n\t" // y2_i, y2_r - "xxswapd 55,51 \n\t" // y3_i, y3_r - - "xvmaddadp 32, 44, 56 \n\t" // x0_r * y0_r , x0_i * y0_i - "lxvd2x 56, 0, %3 \n\t" // y0_r, y0_i - "xvmaddadp 34, 45, 57 \n\t" // x1_r * y1_r , x1_i * y1_i - "lxvd2x 57, %5, %3 \n\t" // y1_r, y1_i - "xvmaddadp 36, 46, 58 \n\t" // x2_r * y2_r , x2_i * y2_i - "lxvd2x 58, %6, %3 \n\t" // y2_r, y2_i - "xvmaddadp 38, 47, 59 \n\t" // x3_r * y3_r , x3_i * y3_i - "lxvd2x 59, %7, %3 \n\t" // y3_r, y3_i - - "xvmaddadp 33, 44, 60 \n\t" // x0_r * y0_i , x0_i * y0_r - "lxvd2x 44, 0, %2 \n\t" // x0_r, x0_i - "xvmaddadp 35, 45, 61 \n\t" // x1_r * y1_i , x1_i * y1_r - "lxvd2x 45, %5, %2 \n\t" // x1_r, x1_i - "xvmaddadp 37, 46, 62 \n\t" // x2_r * y2_i , x2_i * y2_r - "lxvd2x 46, %6, %2 \n\t" // x2_r, x2_i - "xvmaddadp 39, 47, 63 \n\t" // x3_r * y3_i , x3_i * y3_r - "lxvd2x 47, %7, %2 \n\t" // x3_r, x3_i - - "xxswapd 60,56 \n\t" // y0_i, y0_r - "xxswapd 61,57 \n\t" // y1_i, y1_r - - "addi %2, %2, 64 \n\t" - "addi %3, %3, 64 \n\t" - - "xxswapd 62,58 \n\t" // y2_i, y2_r - "xxswapd 63,59 \n\t" // y3_i, y3_r - - "addic. %0 , %0 , -8 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmaddadp 32, 40, 48 \n\t" // x0_r * y0_r , x0_i * y0_i - "xvmaddadp 34, 41, 49 \n\t" // x1_r * y1_r , x1_i * y1_i - "xvmaddadp 36, 42, 50 \n\t" // x2_r * y2_r , x2_i * y2_i - "xvmaddadp 38, 43, 51 \n\t" // x3_r * y3_r , x3_i * y3_i - - "xvmaddadp 33, 40, 52 \n\t" // x0_r * y0_i , x0_i * y0_r - "xvmaddadp 35, 41, 53 \n\t" // x1_r * y1_i , x1_i * y1_r - "xvmaddadp 37, 42, 54 \n\t" // x2_r * y2_i , x2_i * y2_r - "xvmaddadp 39, 43, 55 \n\t" // x3_r * y3_i , x3_i * y3_r - - "xvmaddadp 32, 44, 56 \n\t" // x0_r * y0_r , x0_i * y0_i - "xvmaddadp 34, 45, 57 \n\t" // x1_r * y1_r , x1_i * y1_i - "xvmaddadp 36, 46, 58 \n\t" // x2_r * y2_r , x2_i * y2_i - "xvmaddadp 38, 47, 59 \n\t" // x3_r * y3_r , x3_i * y3_i - - "xvmaddadp 33, 44, 60 \n\t" // x0_r * y0_i , x0_i * y0_r - "xvmaddadp 35, 45, 61 \n\t" // x1_r * y1_i , x1_i * y1_r - "xvmaddadp 37, 46, 62 \n\t" // x2_r * y2_i , x2_i * y2_r - "xvmaddadp 39, 47, 63 \n\t" // x3_r * y3_i , x3_i * y3_r - - - "xvadddp 32, 32, 34 \n\t" - "xvadddp 36, 36, 38 \n\t" - - "xvadddp 33, 33, 35 \n\t" - "xvadddp 37, 37, 39 \n\t" - - "xvadddp 32, 32, 36 \n\t" - "xvadddp 33, 33, 37 \n\t" - - "stxvd2x 32, 0, %4 \n\t" - "stxvd2x 33, %5, %4 \n\t" - - : - : - "r" (i), // 0 - "r" (n), // 1 - "r" (x1), // 2 - "r" (y1), // 3 - "r" (dot), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (pre) // 8 - : "cr0", "%0", "%2" , "%3", "memory" - ); - -} - - + __asm__ + ( + "dcbt 0, %2 \n\t" + "dcbt 0, %3 \n\t" + + "xxlxor 32, 32, 32 \n\t" + "xxlxor 33, 33, 33 \n\t" + "xxlxor 34, 34, 34 \n\t" + "xxlxor 35, 35, 35 \n\t" + "xxlxor 36, 36, 36 \n\t" + "xxlxor 37, 37, 37 \n\t" + "xxlxor 38, 38, 38 \n\t" + "xxlxor 39, 39, 39 \n\t" + + "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i + "lxvd2x 48, 0, %3 \n\t" // y0_r, y0_i + "lxvd2x 41, %7, %2 \n\t" // x1_r, x1_i + "lxvd2x 49, %7, %3 \n\t" // y1_r, y1_i + "lxvd2x 42, %8, %2 \n\t" // x2_r, x2_i + "lxvd2x 50, %8, %3 \n\t" // y2_r, y2_i + "lxvd2x 43, %9, %2 \n\t" // x3_r, x3_i + "lxvd2x 51, %9, %3 \n\t" // y3_r, y3_i + + "xxswapd 0, 48 \n\t" // y0_i, y0_r + "xxswapd 1, 49 \n\t" // y1_i, y1_r + "xxswapd 2, 50 \n\t" // y2_i, y2_r + "xxswapd 3, 51 \n\t" // y3_i, y3_r + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "lxvd2x 44, 0, %2 \n\t" // x0_r, x0_i + "lxvd2x 4, 0, %3 \n\t" // y0_r, y0_i + "lxvd2x 45, %7, %2 \n\t" // x1_r, x1_i + "lxvd2x 5, %7, %3 \n\t" // y1_r, y1_i + "lxvd2x 46, %8, %2 \n\t" // x2_r, x2_i + "lxvd2x 6, %8, %3 \n\t" // y2_r, y2_i + "lxvd2x 47, %9, %2 \n\t" // x3_r, x3_i + "lxvd2x 7, %9, %3 \n\t" // y3_r, y3_i + + "xxswapd 8, 4 \n\t" // y0_i, y0_r + "xxswapd 9, 5 \n\t" // y1_i, y1_r + "xxswapd 10, 6 \n\t" // y2_i, y2_r + "xxswapd 11, 7 \n\t" // y3_i, y3_r + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "addic. %1, %1, -8 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmaddadp 32, 40, 48 \n\t" // x0_r * y0_r , x0_i * y0_i + "lxvd2x 48, 0, %3 \n\t" // y0_r, y0_i + "xvmaddadp 34, 41, 49 \n\t" // x1_r * y1_r , x1_i * y1_i + "lxvd2x 49, %7, %3 \n\t" // y1_r, y1_i + + "xvmaddadp 36, 42, 50 \n\t" // x2_r * y2_r , x2_i * y2_i + "lxvd2x 50, %8, %3 \n\t" // y2_r, y2_i + "xvmaddadp 38, 43, 51 \n\t" // x3_r * y3_r , x3_i * y3_i + "lxvd2x 51, %9, %3 \n\t" // y3_r, y3_i + + "xvmaddadp 33, 40, 0 \n\t" // x0_r * y0_i , x0_i * y0_r + "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i + "xvmaddadp 35, 41, 1 \n\t" // x1_r * y1_i , x1_i * y1_r + "lxvd2x 41, %7, %2 \n\t" // x1_r, x1_i + + "xvmaddadp 37, 42, 2 \n\t" // x2_r * y2_i , x2_i * y2_r + "lxvd2x 42, %8, %2 \n\t" // x2_r, x2_i + "xvmaddadp 39, 43, 3 \n\t" // x3_r * y3_i , x3_i * y3_r + "lxvd2x 43, %9, %2 \n\t" // x3_r, x3_i + + "xxswapd 0,48 \n\t" // y0_i, y0_r + "xxswapd 1,49 \n\t" // y1_i, y1_r + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "xxswapd 2,50 \n\t" // y2_i, y2_r + "xxswapd 3,51 \n\t" // y3_i, y3_r + + "xvmaddadp 32, 44, 4 \n\t" // x0_r * y0_r , x0_i * y0_i + "lxvd2x 4, 0, %3 \n\t" // y0_r, y0_i + "xvmaddadp 34, 45, 5 \n\t" // x1_r * y1_r , x1_i * y1_i + "lxvd2x 5, %7, %3 \n\t" // y1_r, y1_i + "xvmaddadp 36, 46, 6 \n\t" // x2_r * y2_r , x2_i * y2_i + "lxvd2x 6, %8, %3 \n\t" // y2_r, y2_i + "xvmaddadp 38, 47, 7 \n\t" // x3_r * y3_r , x3_i * y3_i + "lxvd2x 7, %9, %3 \n\t" // y3_r, y3_i + + "xvmaddadp 33, 44, 8 \n\t" // x0_r * y0_i , x0_i * y0_r + "lxvd2x 44, 0, %2 \n\t" // x0_r, x0_i + "xvmaddadp 35, 45, 9 \n\t" // x1_r * y1_i , x1_i * y1_r + "lxvd2x 45, %7, %2 \n\t" // x1_r, x1_i + "xvmaddadp 37, 46, 10 \n\t" // x2_r * y2_i , x2_i * y2_r + "lxvd2x 46, %8, %2 \n\t" // x2_r, x2_i + "xvmaddadp 39, 47, 11 \n\t" // x3_r * y3_i , x3_i * y3_r + "lxvd2x 47, %9, %2 \n\t" // x3_r, x3_i + + "xxswapd 8,4 \n\t" // y0_i, y0_r + "xxswapd 9,5 \n\t" // y1_i, y1_r + + "addi %2, %2, 64 \n\t" + "addi %3, %3, 64 \n\t" + + "xxswapd 10,6 \n\t" // y2_i, y2_r + "xxswapd 11,7 \n\t" // y3_i, y3_r + + "addic. %1, %1, -8 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmaddadp 32, 40, 48 \n\t" // x0_r * y0_r , x0_i * y0_i + "xvmaddadp 34, 41, 49 \n\t" // x1_r * y1_r , x1_i * y1_i + "xvmaddadp 36, 42, 50 \n\t" // x2_r * y2_r , x2_i * y2_i + "xvmaddadp 38, 43, 51 \n\t" // x3_r * y3_r , x3_i * y3_i + + "xvmaddadp 33, 40, 0 \n\t" // x0_r * y0_i , x0_i * y0_r + "xvmaddadp 35, 41, 1 \n\t" // x1_r * y1_i , x1_i * y1_r + "xvmaddadp 37, 42, 2 \n\t" // x2_r * y2_i , x2_i * y2_r + "xvmaddadp 39, 43, 3 \n\t" // x3_r * y3_i , x3_i * y3_r + + "xvmaddadp 32, 44, 4 \n\t" // x0_r * y0_r , x0_i * y0_i + "xvmaddadp 34, 45, 5 \n\t" // x1_r * y1_r , x1_i * y1_i + "xvmaddadp 36, 46, 6 \n\t" // x2_r * y2_r , x2_i * y2_i + "xvmaddadp 38, 47, 7 \n\t" // x3_r * y3_r , x3_i * y3_i + + "xvmaddadp 33, 44, 8 \n\t" // x0_r * y0_i , x0_i * y0_r + "xvmaddadp 35, 45, 9 \n\t" // x1_r * y1_i , x1_i * y1_r + "xvmaddadp 37, 46, 10 \n\t" // x2_r * y2_i , x2_i * y2_r + "xvmaddadp 39, 47, 11 \n\t" // x3_r * y3_i , x3_i * y3_r + + "xvadddp 32, 32, 34 \n\t" + "xvadddp 36, 36, 38 \n\t" + + "xvadddp 33, 33, 35 \n\t" + "xvadddp 37, 37, 39 \n\t" + + "xvadddp 32, 32, 36 \n\t" + "xvadddp 33, 33, 37 \n\t" + + "stxvd2x 32, 0, %6 \n\t" + "stxvd2x 33, %7, %6 \n" + + "#n=%1 x=%4=%2 y=%5=%3 dot=%0=%6 o16=%7 o32=%8 o48=%9" + : + "=m" (*dot), + "+r" (n), // 1 + "+b" (x), // 2 + "+b" (y) // 3 + : + "m" (*x), + "m" (*y), + "b" (dot), // 6 + "b" (16), // 7 + "b" (32), // 8 + "b" (48) // 9 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51","vs0","vs1","vs2","vs3", + "vs4","vs5","vs6","vs7","vs8","vs9","vs10","vs11" + ); +} diff --git a/kernel/power/zscal.c b/kernel/power/zscal.c index 410fc9840a..14d677f249 100644 --- a/kernel/power/zscal.c +++ b/kernel/power/zscal.c @@ -47,15 +47,15 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #ifndef HAVE_KERNEL_8 -static void zscal_kernel_8(BLASLONG n, FLOAT *x, FLOAT *alpha) +static void zscal_kernel_8(BLASLONG n, FLOAT *x, FLOAT da_r, FLOAT da_i) { BLASLONG i=0; FLOAT *x1=x; - FLOAT alpha_r1=alpha[0]; - FLOAT alpha_r2=alpha[1]; - FLOAT alpha_i1=alpha[2]; - FLOAT alpha_i2=alpha[3]; + FLOAT alpha_r1=da_r; + FLOAT alpha_r2=da_r; + FLOAT alpha_i1=-da_i; + FLOAT alpha_i2=da_i; FLOAT temp00, temp01, temp10, temp11, temp20, temp21, temp30, temp31; FLOAT x0_r, x0_i, x1_r, x1_i, x2_r, x2_i, x3_r, x3_i; @@ -116,7 +116,6 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r,FLOAT da_i, F BLASLONG inc_x2; BLASLONG ip = 0; FLOAT temp; - FLOAT alpha[4] __attribute__ ((aligned (16)));; BLASLONG n1; if ( n <= 0 ) @@ -147,11 +146,7 @@ int CNAME(BLASLONG n, BLASLONG dummy0, BLASLONG dummy1, FLOAT da_r,FLOAT da_i, F n1 = n & -8; if ( n1 > 0 ) { - alpha[0] = da_r; - alpha[1] = da_r; - alpha[2] = -da_i; - alpha[3] = da_i; - zscal_kernel_8(n1, x, alpha); + zscal_kernel_8(n1, x, da_r, da_i); i=n1; ip = n1 * 2; diff --git a/kernel/power/zscal_microk_power8.c b/kernel/power/zscal_microk_power8.c index 5e09d8d793..aba9029a04 100644 --- a/kernel/power/zscal_microk_power8.c +++ b/kernel/power/zscal_microk_power8.c @@ -38,187 +38,202 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_8 1 -static void zscal_kernel_8( BLASLONG n, FLOAT *x, FLOAT *alpha) __attribute__ ((noinline)); - -static void zscal_kernel_8( BLASLONG n, FLOAT *x, FLOAT *alpha) +static void zscal_kernel_8 (long n, double *x, double alpha_r, double alpha_i) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *x2=x+1; - BLASLONG pre = 384; - - __asm__ __volatile__ - ( - - "lxvd2x 32, 0, %3 \n\t" // alpha_r , alpha_r - "lxvd2x 33, %5, %3 \n\t" // -alpha_i , alpha_i - "addi %1, %1, -8 \n\t" - - "dcbt %2, %4 \n\t" - - "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "ble 2f \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "dcbt %2, %4 \n\t" - - "xvmuldp 48, 40, 32 \n\t" // x0_r * alpha_r, x0_i * alpha_r - "xvmuldp 49, 41, 32 \n\t" - "xvmuldp 50, 42, 32 \n\t" - "xvmuldp 51, 43, 32 \n\t" - "xvmuldp 52, 44, 32 \n\t" - "xvmuldp 53, 45, 32 \n\t" - "xvmuldp 54, 46, 32 \n\t" - "xvmuldp 55, 47, 32 \n\t" - - "xxswapd 56, 40 \n\t" - "xxswapd 57, 41 \n\t" - "xxswapd 58, 42 \n\t" - "xxswapd 59, 43 \n\t" - "xxswapd 60, 44 \n\t" - "xxswapd 61, 45 \n\t" - "xxswapd 62, 46 \n\t" - "xxswapd 63, 47 \n\t" - - "xvmuldp 56, 56, 33 \n\t" // x0_i * -alpha_i, x0_r * alpha_i - "xvmuldp 57, 57, 33 \n\t" - - "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i - "lxvd2x 41, %5, %2 \n\t" - - "xvmuldp 58, 58, 33 \n\t" - "xvmuldp 59, 59, 33 \n\t" - - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - - "xvmuldp 60, 60, 33 \n\t" - "xvmuldp 61, 61, 33 \n\t" - - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - - "xvmuldp 62, 62, 33 \n\t" - "xvmuldp 63, 63, 33 \n\t" - - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "xvadddp 48, 48 , 56 \n\t" - "xvadddp 49, 49 , 57 \n\t" - "xvadddp 50, 50 , 58 \n\t" - "xvadddp 51, 51 , 59 \n\t" - - "stxvd2x 48, 0, %1 \n\t" - "stxvd2x 49, %5, %1 \n\t" - - "xvadddp 52, 52 , 60 \n\t" - "xvadddp 53, 53 , 61 \n\t" - - "stxvd2x 50, %6, %1 \n\t" - "stxvd2x 51, %7, %1 \n\t" - - "xvadddp 54, 54 , 62 \n\t" - "xvadddp 55, 55 , 63 \n\t" - - "stxvd2x 52, %8, %1 \n\t" - "stxvd2x 53, %9, %1 \n\t" - "stxvd2x 54, %10, %1 \n\t" - "stxvd2x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - "addi %2, %2, 128 \n\t" - - "addic. %0 , %0 , -8 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - "xvmuldp 48, 40, 32 \n\t" // x0_r * alpha_r, x0_i * alpha_r - "xvmuldp 49, 41, 32 \n\t" - "xvmuldp 50, 42, 32 \n\t" - "xvmuldp 51, 43, 32 \n\t" - "xvmuldp 52, 44, 32 \n\t" - "xvmuldp 53, 45, 32 \n\t" - "xvmuldp 54, 46, 32 \n\t" - "xvmuldp 55, 47, 32 \n\t" - - "xxswapd 56, 40 \n\t" - "xxswapd 57, 41 \n\t" - "xxswapd 58, 42 \n\t" - "xxswapd 59, 43 \n\t" - "xxswapd 60, 44 \n\t" - "xxswapd 61, 45 \n\t" - "xxswapd 62, 46 \n\t" - "xxswapd 63, 47 \n\t" - - "xvmuldp 56, 56, 33 \n\t" // x0_i * -alpha_i, x0_r * alpha_i - "xvmuldp 57, 57, 33 \n\t" - "xvmuldp 58, 58, 33 \n\t" - "xvmuldp 59, 59, 33 \n\t" - "xvmuldp 60, 60, 33 \n\t" - "xvmuldp 61, 61, 33 \n\t" - "xvmuldp 62, 62, 33 \n\t" - "xvmuldp 63, 63, 33 \n\t" - - "xvadddp 48, 48 , 56 \n\t" - "xvadddp 49, 49 , 57 \n\t" - "xvadddp 50, 50 , 58 \n\t" - "xvadddp 51, 51 , 59 \n\t" - "xvadddp 52, 52 , 60 \n\t" - "xvadddp 53, 53 , 61 \n\t" - "xvadddp 54, 54 , 62 \n\t" - "xvadddp 55, 55 , 63 \n\t" - - "stxvd2x 48, 0, %1 \n\t" - "stxvd2x 49, %5, %1 \n\t" - "stxvd2x 50, %6, %1 \n\t" - "stxvd2x 51, %7, %1 \n\t" - "stxvd2x 52, %8, %1 \n\t" - "stxvd2x 53, %9, %1 \n\t" - "stxvd2x 54, %10, %1 \n\t" - "stxvd2x 55, %11, %1 \n\t" - - - : - : - "r" (i), // 0 - "r" (x2), // 1 - "r" (x1), // 2 - "r" (alpha), // 3 - "r" (pre), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "memory" - ); - -} - - + __vector double t0; + __vector double t1; + __vector double t2; + __vector double t3; + __vector double t4; + __vector double t5; + __vector double t6; + __vector double t7; + __vector double t8; + __vector double t9; + __vector double t10; + __vector double t11; + + __asm__ + ( + "dcbt 0, %2 \n\t" + + "xsnegdp 33, %x16 \n\t" // -alpha_i + "xxspltd 32, %x15, 0 \n\t" // alpha_r , alpha_r + "xxmrghd 33, 33, %x16 \n\t" // -alpha_i , alpha_i + + "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i + "lxvd2x 41, %17, %2 \n\t" + "lxvd2x 42, %18, %2 \n\t" + "lxvd2x 43, %19, %2 \n\t" + "lxvd2x 44, %20, %2 \n\t" + "lxvd2x 45, %21, %2 \n\t" + "lxvd2x 46, %22, %2 \n\t" + "lxvd2x 47, %23, %2 \n\t" + + "addi %2, %2, 128 \n\t" + + "addic. %1, %1, -8 \n\t" + "ble 2f \n\t" + + ".p2align 5 \n" + "1: \n\t" + + "xvmuldp 48, 40, 32 \n\t" // x0_r * alpha_r, x0_i * alpha_r + "xvmuldp 49, 41, 32 \n\t" + "xvmuldp 50, 42, 32 \n\t" + "xvmuldp 51, 43, 32 \n\t" + "xvmuldp %x3, 44, 32 \n\t" + "xvmuldp %x4, 45, 32 \n\t" + "xvmuldp %x5, 46, 32 \n\t" + "xvmuldp %x6, 47, 32 \n\t" + + "xxswapd %x7, 40 \n\t" + "xxswapd %x8, 41 \n\t" + "xxswapd %x9, 42 \n\t" + "xxswapd %x10, 43 \n\t" + "xxswapd %x11, 44 \n\t" + "xxswapd %x12, 45 \n\t" + "xxswapd %x13, 46 \n\t" + "xxswapd %x14, 47 \n\t" + + "xvmuldp %x7, %x7, 33 \n\t" // x0_i * -alpha_i, x0_r * alpha_i + "xvmuldp %x8, %x8, 33 \n\t" + + "lxvd2x 40, 0, %2 \n\t" // x0_r, x0_i + "lxvd2x 41, %17, %2 \n\t" + + "xvmuldp %x9, %x9, 33 \n\t" + "xvmuldp %x10, %x10, 33 \n\t" + + "lxvd2x 42, %18, %2 \n\t" + "lxvd2x 43, %19, %2 \n\t" + + "xvmuldp %x11, %x11, 33 \n\t" + "xvmuldp %x12, %x12, 33 \n\t" + + "lxvd2x 44, %20, %2 \n\t" + "lxvd2x 45, %21, %2 \n\t" + + "xvmuldp %x13, %x13, 33 \n\t" + "xvmuldp %x14, %x14, 33 \n\t" + + "lxvd2x 46, %22, %2 \n\t" + "lxvd2x 47, %23, %2 \n\t" + + "addi %2, %2, -128 \n\t" + + "xvadddp 48, 48, %x7 \n\t" + "xvadddp 49, 49, %x8 \n\t" + "xvadddp 50, 50, %x9 \n\t" + "xvadddp 51, 51, %x10 \n\t" + + "stxvd2x 48, 0, %2 \n\t" + "stxvd2x 49, %17, %2 \n\t" + + "xvadddp %x3, %x3, %x11 \n\t" + "xvadddp %x4, %x4, %x12 \n\t" + + "stxvd2x 50, %18, %2 \n\t" + "stxvd2x 51, %19, %2 \n\t" + + "xvadddp %x5, %x5, %x13 \n\t" + "xvadddp %x6, %x6, %x14 \n\t" + + "stxvd2x %x3, %20, %2 \n\t" + "stxvd2x %x4, %21, %2 \n\t" + "stxvd2x %x5, %22, %2 \n\t" + "stxvd2x %x6, %23, %2 \n\t" + + "addi %2, %2, 256 \n\t" + + "addic. %1, %1, -8 \n\t" + "bgt 1b \n" + + "2: \n\t" + + "xvmuldp 48, 40, 32 \n\t" // x0_r * alpha_r, x0_i * alpha_r + "xvmuldp 49, 41, 32 \n\t" + "xvmuldp 50, 42, 32 \n\t" + "xvmuldp 51, 43, 32 \n\t" + "xvmuldp %x3, 44, 32 \n\t" + "xvmuldp %x4, 45, 32 \n\t" + "xvmuldp %x5, 46, 32 \n\t" + "xvmuldp %x6, 47, 32 \n\t" + + "xxswapd %x7, 40 \n\t" + "xxswapd %x8, 41 \n\t" + "xxswapd %x9, 42 \n\t" + "xxswapd %x10, 43 \n\t" + "xxswapd %x11, 44 \n\t" + "xxswapd %x12, 45 \n\t" + "xxswapd %x13, 46 \n\t" + "xxswapd %x14, 47 \n\t" + + "addi %2, %2, -128 \n\t" + + "xvmuldp %x7, %x7, 33 \n\t" // x0_i * -alpha_i, x0_r * alpha_i + "xvmuldp %x8, %x8, 33 \n\t" + "xvmuldp %x9, %x9, 33 \n\t" + "xvmuldp %x10, %x10, 33 \n\t" + "xvmuldp %x11, %x11, 33 \n\t" + "xvmuldp %x12, %x12, 33 \n\t" + "xvmuldp %x13, %x13, 33 \n\t" + "xvmuldp %x14, %x14, 33 \n\t" + + "xvadddp 48, 48, %x7 \n\t" + "xvadddp 49, 49, %x8 \n\t" + "xvadddp 50, 50, %x9 \n\t" + "xvadddp 51, 51, %x10 \n\t" + + "stxvd2x 48, 0, %2 \n\t" + "stxvd2x 49, %17, %2 \n\t" + + "xvadddp %x3, %x3, %x11 \n\t" + "xvadddp %x4, %x4, %x12 \n\t" + + "stxvd2x 50, %18, %2 \n\t" + "stxvd2x 51, %19, %2 \n\t" + + "xvadddp %x5, %x5, %x13 \n\t" + "xvadddp %x6, %x6, %x14 \n\t" + + "stxvd2x %x3, %20, %2 \n\t" + "stxvd2x %x4, %21, %2 \n\t" + "stxvd2x %x5, %22, %2 \n\t" + "stxvd2x %x6, %23, %2 \n" + + "#n=%1 x=%0=%2 alpha=(%15,%16) o16=%17 o32=%18 o48=%19 o64=%20 o80=%21 o96=%22 o112=%23\n" + "#t0=%x3 t1=%x4 t2=%x5 t3=%x6 t4=%x7 t5=%x8 t6=%x9 t7=%x10 t8=%x11 t9=%x12 t10=%x13 t11=%x14" + : + "+m" (*x), + "+r" (n), // 1 + "+b" (x), // 2 + "=wa" (t0), // 3 + "=wa" (t1), // 4 + "=wa" (t2), // 5 + "=wa" (t3), // 6 + "=wa" (t4), // 7 + "=wa" (t5), // 8 + "=wa" (t6), // 9 + "=wa" (t7), // 10 + "=wa" (t8), // 11 + "=wa" (t9), // 12 + "=wa" (t10), // 13 + "=wa" (t11) // 14 + : + "d" (alpha_r), // 15 + "d" (alpha_i), // 16 + "b" (16), // 17 + "b" (32), // 18 + "b" (48), // 19 + "b" (64), // 20 + "b" (80), // 21 + "b" (96), // 22 + "b" (112) // 23 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51" + ); +} diff --git a/kernel/power/zswap_microk_power8.c b/kernel/power/zswap_microk_power8.c index 9e5623752f..54391ba5dc 100644 --- a/kernel/power/zswap_microk_power8.c +++ b/kernel/power/zswap_microk_power8.c @@ -35,146 +35,123 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HAVE_KERNEL_16 1 -static void zswap_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y) __attribute__ ((noinline)); - -static void zswap_kernel_16( BLASLONG n, FLOAT *x, FLOAT *y) +static void +zswap_kernel_16 (long n, double *x, double *y) { - - - BLASLONG i = n; - BLASLONG o16 = 16; - BLASLONG o32 = 32; - BLASLONG o48 = 48; - BLASLONG o64 = 64; - BLASLONG o80 = 80; - BLASLONG o96 = 96; - BLASLONG o112 = 112; - FLOAT *x1=x; - FLOAT *y1=y; - FLOAT *x2=x+1; - FLOAT *y2=y+1; - BLASLONG pre = 384; - BLASLONG alpha=0; - - __asm__ __volatile__ - ( - - "addi %3, %3, -8 \n\t" - "addi %4, %4, -8 \n\t" - - ".align 5 \n\t" - "1: \n\t" - - "lxvd2x 32, 0, %2 \n\t" - "lxvd2x 33, %5, %2 \n\t" - "lxvd2x 34, %6, %2 \n\t" - "lxvd2x 35, %7, %2 \n\t" - "lxvd2x 36, %8, %2 \n\t" - "lxvd2x 37, %9, %2 \n\t" - "lxvd2x 38, %10, %2 \n\t" - "lxvd2x 39, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 40, 0, %2 \n\t" - "lxvd2x 41, %5, %2 \n\t" - "lxvd2x 42, %6, %2 \n\t" - "lxvd2x 43, %7, %2 \n\t" - "lxvd2x 44, %8, %2 \n\t" - "lxvd2x 45, %9, %2 \n\t" - "lxvd2x 46, %10, %2 \n\t" - "lxvd2x 47, %11, %2 \n\t" - - "addi %2, %2, 128 \n\t" - - "lxvd2x 48, 0, %1 \n\t" - "lxvd2x 49, %5, %1 \n\t" - "lxvd2x 50, %6, %1 \n\t" - "lxvd2x 51, %7, %1 \n\t" - "lxvd2x 52, %8, %1 \n\t" - "lxvd2x 53, %9, %1 \n\t" - "lxvd2x 54, %10, %1 \n\t" - "lxvd2x 55, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "lxvd2x 56, 0, %1 \n\t" - "lxvd2x 57, %5, %1 \n\t" - "lxvd2x 58, %6, %1 \n\t" - "lxvd2x 59, %7, %1 \n\t" - "lxvd2x 60, %8, %1 \n\t" - "lxvd2x 61, %9, %1 \n\t" - "lxvd2x 62, %10, %1 \n\t" - "lxvd2x 63, %11, %1 \n\t" - - "addi %1, %1, 128 \n\t" - - "stxvd2x 32, 0, %3 \n\t" - "stxvd2x 33, %5, %3 \n\t" - "stxvd2x 34, %6, %3 \n\t" - "stxvd2x 35, %7, %3 \n\t" - "stxvd2x 36, %8, %3 \n\t" - "stxvd2x 37, %9, %3 \n\t" - "stxvd2x 38, %10, %3 \n\t" - "stxvd2x 39, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvd2x 40, 0, %3 \n\t" - "stxvd2x 41, %5, %3 \n\t" - "stxvd2x 42, %6, %3 \n\t" - "stxvd2x 43, %7, %3 \n\t" - "stxvd2x 44, %8, %3 \n\t" - "stxvd2x 45, %9, %3 \n\t" - "stxvd2x 46, %10, %3 \n\t" - "stxvd2x 47, %11, %3 \n\t" - - "addi %3, %3, 128 \n\t" - - "stxvd2x 48, 0, %4 \n\t" - "stxvd2x 49, %5, %4 \n\t" - "stxvd2x 50, %6, %4 \n\t" - "stxvd2x 51, %7, %4 \n\t" - "stxvd2x 52, %8, %4 \n\t" - "stxvd2x 53, %9, %4 \n\t" - "stxvd2x 54, %10, %4 \n\t" - "stxvd2x 55, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "stxvd2x 56, 0, %4 \n\t" - "stxvd2x 57, %5, %4 \n\t" - "stxvd2x 58, %6, %4 \n\t" - "stxvd2x 59, %7, %4 \n\t" - "stxvd2x 60, %8, %4 \n\t" - "stxvd2x 61, %9, %4 \n\t" - "stxvd2x 62, %10, %4 \n\t" - "stxvd2x 63, %11, %4 \n\t" - - "addi %4, %4, 128 \n\t" - - "addic. %0 , %0 , -16 \n\t" - "bgt 1b \n\t" - - "2: \n\t" - - : - : - "r" (i), // 0 - "r" (y1), // 1 - "r" (x1), // 2 - "r" (y2), // 3 - "r" (x2), // 4 - "r" (o16), // 5 - "r" (o32), // 6 - "r" (o48), // 7 - "r" (o64), // 8 - "r" (o80), // 9 - "r" (o96), // 10 - "r" (o112) // 11 - : "cr0", "%0", "%2" , "%1", "%3", "%4", "memory" - ); - -} - - + __asm__ + ( + ".p2align 5 \n" + "1: \n\t" + "lxvd2x 32, 0, %4 \n\t" + "lxvd2x 33, %5, %4 \n\t" + "lxvd2x 34, %6, %4 \n\t" + "lxvd2x 35, %7, %4 \n\t" + "lxvd2x 36, %8, %4 \n\t" + "lxvd2x 37, %9, %4 \n\t" + "lxvd2x 38, %10, %4 \n\t" + "lxvd2x 39, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "lxvd2x 40, 0, %4 \n\t" + "lxvd2x 41, %5, %4 \n\t" + "lxvd2x 42, %6, %4 \n\t" + "lxvd2x 43, %7, %4 \n\t" + "lxvd2x 44, %8, %4 \n\t" + "lxvd2x 45, %9, %4 \n\t" + "lxvd2x 46, %10, %4 \n\t" + "lxvd2x 47, %11, %4 \n\t" + + "addi %4, %4, -128 \n\t" + + "lxvd2x 48, 0, %3 \n\t" + "lxvd2x 49, %5, %3 \n\t" + "lxvd2x 50, %6, %3 \n\t" + "lxvd2x 51, %7, %3 \n\t" + "lxvd2x 0, %8, %3 \n\t" + "lxvd2x 1, %9, %3 \n\t" + "lxvd2x 2, %10, %3 \n\t" + "lxvd2x 3, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "lxvd2x 4, 0, %3 \n\t" + "lxvd2x 5, %5, %3 \n\t" + "lxvd2x 6, %6, %3 \n\t" + "lxvd2x 7, %7, %3 \n\t" + "lxvd2x 8, %8, %3 \n\t" + "lxvd2x 9, %9, %3 \n\t" + "lxvd2x 10, %10, %3 \n\t" + "lxvd2x 11, %11, %3 \n\t" + + "addi %3, %3, -128 \n\t" + + "stxvd2x 32, 0, %3 \n\t" + "stxvd2x 33, %5, %3 \n\t" + "stxvd2x 34, %6, %3 \n\t" + "stxvd2x 35, %7, %3 \n\t" + "stxvd2x 36, %8, %3 \n\t" + "stxvd2x 37, %9, %3 \n\t" + "stxvd2x 38, %10, %3 \n\t" + "stxvd2x 39, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 40, 0, %3 \n\t" + "stxvd2x 41, %5, %3 \n\t" + "stxvd2x 42, %6, %3 \n\t" + "stxvd2x 43, %7, %3 \n\t" + "stxvd2x 44, %8, %3 \n\t" + "stxvd2x 45, %9, %3 \n\t" + "stxvd2x 46, %10, %3 \n\t" + "stxvd2x 47, %11, %3 \n\t" + + "addi %3, %3, 128 \n\t" + + "stxvd2x 48, 0, %4 \n\t" + "stxvd2x 49, %5, %4 \n\t" + "stxvd2x 50, %6, %4 \n\t" + "stxvd2x 51, %7, %4 \n\t" + "stxvd2x 0, %8, %4 \n\t" + "stxvd2x 1, %9, %4 \n\t" + "stxvd2x 2, %10, %4 \n\t" + "stxvd2x 3, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + + "stxvd2x 4, 0, %4 \n\t" + "stxvd2x 5, %5, %4 \n\t" + "stxvd2x 6, %6, %4 \n\t" + "stxvd2x 7, %7, %4 \n\t" + "stxvd2x 8, %8, %4 \n\t" + "stxvd2x 9, %9, %4 \n\t" + "stxvd2x 10, %10, %4 \n\t" + "stxvd2x 11, %11, %4 \n\t" + + "addi %4, %4, 128 \n\t" + "addic. %2, %2, -16 \n\t" + "bgt 1b \n" + + "#n=%2 x=%0=%3 y=%1=%4 o16=%5 o32=%6 o48=%7 o64=%8 o80=%9 o96=%10 o112=%11" + : + "+m" (*x), + "+m" (*y), + "+r" (n), // 2 + "+b" (x), // 3 + "+b" (y) // 4 + : + "b" (16), // 5 + "b" (32), // 6 + "b" (48), // 7 + "b" (64), // 8 + "b" (80), // 9 + "b" (96), // 10 + "b" (112) // 11 + : + "cr0", + "vs32","vs33","vs34","vs35","vs36","vs37","vs38","vs39", + "vs40","vs41","vs42","vs43","vs44","vs45","vs46","vs47", + "vs48","vs49","vs50","vs51","vs0","vs1","vs2","vs3", + "vs4","vs5","vs6","vs7","vs8","vs9","vs10","vs11" + ); +} diff --git a/kernel/setparam-ref.c b/kernel/setparam-ref.c index ba44b8f61a..9320cb56cb 100644 --- a/kernel/setparam-ref.c +++ b/kernel/setparam-ref.c @@ -982,6 +982,22 @@ static void init_parameter(void) { #endif #endif +#ifdef ZEN + +#ifdef DEBUG + fprintf(stderr, "Zen\n"); +#endif + + TABLE_NAME.sgemm_p = SGEMM_DEFAULT_P; + TABLE_NAME.dgemm_p = DGEMM_DEFAULT_P; + TABLE_NAME.cgemm_p = CGEMM_DEFAULT_P; + TABLE_NAME.zgemm_p = ZGEMM_DEFAULT_P; +#ifdef EXPRECISION + TABLE_NAME.qgemm_p = QGEMM_DEFAULT_P; + TABLE_NAME.xgemm_p = XGEMM_DEFAULT_P; +#endif +#endif + #ifdef NANO @@ -1022,27 +1038,27 @@ static void init_parameter(void) { - TABLE_NAME.sgemm_p = (TABLE_NAME.sgemm_p + SGEMM_DEFAULT_UNROLL_M - 1) & ~(SGEMM_DEFAULT_UNROLL_M - 1); - TABLE_NAME.dgemm_p = (TABLE_NAME.dgemm_p + DGEMM_DEFAULT_UNROLL_M - 1) & ~(DGEMM_DEFAULT_UNROLL_M - 1); - TABLE_NAME.cgemm_p = (TABLE_NAME.cgemm_p + CGEMM_DEFAULT_UNROLL_M - 1) & ~(CGEMM_DEFAULT_UNROLL_M - 1); - TABLE_NAME.zgemm_p = (TABLE_NAME.zgemm_p + ZGEMM_DEFAULT_UNROLL_M - 1) & ~(ZGEMM_DEFAULT_UNROLL_M - 1); + TABLE_NAME.sgemm_p = ((TABLE_NAME.sgemm_p + SGEMM_DEFAULT_UNROLL_M - 1)/SGEMM_DEFAULT_UNROLL_M) * SGEMM_DEFAULT_UNROLL_M; + TABLE_NAME.dgemm_p = ((TABLE_NAME.dgemm_p + DGEMM_DEFAULT_UNROLL_M - 1)/DGEMM_DEFAULT_UNROLL_M) * DGEMM_DEFAULT_UNROLL_M; + TABLE_NAME.cgemm_p = ((TABLE_NAME.cgemm_p + CGEMM_DEFAULT_UNROLL_M - 1)/CGEMM_DEFAULT_UNROLL_M) * CGEMM_DEFAULT_UNROLL_M; + TABLE_NAME.zgemm_p = ((TABLE_NAME.zgemm_p + ZGEMM_DEFAULT_UNROLL_M - 1)/ZGEMM_DEFAULT_UNROLL_M) * ZGEMM_DEFAULT_UNROLL_M; #ifdef CGEMM3M_DEFAULT_UNROLL_M - TABLE_NAME.cgemm3m_p = (TABLE_NAME.cgemm3m_p + CGEMM3M_DEFAULT_UNROLL_M - 1) & ~(CGEMM3M_DEFAULT_UNROLL_M - 1); + TABLE_NAME.cgemm3m_p = ((TABLE_NAME.cgemm3m_p + CGEMM3M_DEFAULT_UNROLL_M - 1)/CGEMM3M_DEFAULT_UNROLL_M) * CGEMM3M_DEFAULT_UNROLL_M; #else - TABLE_NAME.cgemm3m_p = (TABLE_NAME.cgemm3m_p + SGEMM_DEFAULT_UNROLL_M - 1) & ~(SGEMM_DEFAULT_UNROLL_M - 1); + TABLE_NAME.cgemm3m_p = ((TABLE_NAME.cgemm3m_p + SGEMM_DEFAULT_UNROLL_M - 1)/SGEMM_DEFAULT_UNROLL_M) * SGEMM_DEFAULT_UNROLL_M; #endif #ifdef ZGEMM3M_DEFAULT_UNROLL_M - TABLE_NAME.zgemm3m_p = (TABLE_NAME.zgemm3m_p + ZGEMM3M_DEFAULT_UNROLL_M - 1) & ~(ZGEMM3M_DEFAULT_UNROLL_M - 1); + TABLE_NAME.zgemm3m_p = ((TABLE_NAME.zgemm3m_p + ZGEMM3M_DEFAULT_UNROLL_M - 1)/ZGEMM3M_DEFAULT_UNROLL_M) * ZGEMM3M_DEFAULT_UNROLL_M; #else - TABLE_NAME.zgemm3m_p = (TABLE_NAME.zgemm3m_p + DGEMM_DEFAULT_UNROLL_M - 1) & ~(DGEMM_DEFAULT_UNROLL_M - 1); + TABLE_NAME.zgemm3m_p = ((TABLE_NAME.zgemm3m_p + DGEMM_DEFAULT_UNROLL_M - 1)/DGEMM_DEFAULT_UNROLL_M) * DGEMM_DEFAULT_UNROLL_M; #endif #ifdef QUAD_PRECISION - TABLE_NAME.qgemm_p = (TABLE_NAME.qgemm_p + QGEMM_DEFAULT_UNROLL_M - 1) & ~(QGEMM_DEFAULT_UNROLL_M - 1); - TABLE_NAME.xgemm_p = (TABLE_NAME.xgemm_p + XGEMM_DEFAULT_UNROLL_M - 1) & ~(XGEMM_DEFAULT_UNROLL_M - 1); - TABLE_NAME.xgemm3m_p = (TABLE_NAME.xgemm3m_p + QGEMM_DEFAULT_UNROLL_M - 1) & ~(QGEMM_DEFAULT_UNROLL_M - 1); + TABLE_NAME.qgemm_p = ((TABLE_NAME.qgemm_p + QGEMM_DEFAULT_UNROLL_M - 1)/QGEMM_DEFAULT_UNROLL_M) * QGEMM_DEFAULT_UNROLL_M; + TABLE_NAME.xgemm_p = ((TABLE_NAME.xgemm_p + XGEMM_DEFAULT_UNROLL_M - 1)/XGEMM_DEFAULT_UNROLL_M) * XGEMM_DEFAULT_UNROLL_M; + TABLE_NAME.xgemm3m_p = ((TABLE_NAME.xgemm3m_p + QGEMM_DEFAULT_UNROLL_M - 1)/QGEMM_DEFAULT_UNROLL_M) * QGEMM_DEFAULT_UNROLL_M; #endif #ifdef DEBUG diff --git a/kernel/x86/KERNEL.ZEN b/kernel/x86/KERNEL.ZEN new file mode 100644 index 0000000000..d9abfc78a4 --- /dev/null +++ b/kernel/x86/KERNEL.ZEN @@ -0,0 +1 @@ +include $(KERNELDIR)/KERNEL.BARCELONA diff --git a/kernel/x86_64/KERNEL.ZEN b/kernel/x86_64/KERNEL.ZEN new file mode 100644 index 0000000000..f2e1374d32 --- /dev/null +++ b/kernel/x86_64/KERNEL.ZEN @@ -0,0 +1,98 @@ +DSCALKERNEL = dscal.c +CSCALKERNEL = cscal.c +ZSCALKERNEL = zscal.c + +SGEMVNKERNEL = sgemv_n_4.c +SGEMVTKERNEL = sgemv_t_4.c + +DGEMVNKERNEL = dgemv_n_4.c +DGEMVTKERNEL = dgemv_t_4.c + +ZGEMVNKERNEL = zgemv_n_4.c +ZGEMVTKERNEL = zgemv_t_4.c + +CGEMVNKERNEL = cgemv_n_4.c +CGEMVTKERNEL = cgemv_t_4.c + +SSYMV_L_KERNEL = ssymv_L.c +SSYMV_U_KERNEL = ssymv_U.c +DSYMV_L_KERNEL = dsymv_L.c +DSYMV_U_KERNEL = dsymv_U.c + +SDOTKERNEL = sdot.c +DDOTKERNEL = ddot.c +CDOTKERNEL = cdot.c +ZDOTKERNEL = zdot.c + +SAXPYKERNEL = saxpy.c +DAXPYKERNEL = daxpy.c +CAXPYKERNEL = caxpy.c +ZAXPYKERNEL = zaxpy.c + +STRMMKERNEL = sgemm_kernel_16x4_haswell.S +SGEMMKERNEL = sgemm_kernel_16x4_haswell.S +SGEMMINCOPY = ../generic/gemm_ncopy_16.c +SGEMMITCOPY = ../generic/gemm_tcopy_16.c +SGEMMONCOPY = ../generic/gemm_ncopy_4.c +SGEMMOTCOPY = ../generic/gemm_tcopy_4.c +SGEMMINCOPYOBJ = sgemm_incopy$(TSUFFIX).$(SUFFIX) +SGEMMITCOPYOBJ = sgemm_itcopy$(TSUFFIX).$(SUFFIX) +SGEMMONCOPYOBJ = sgemm_oncopy$(TSUFFIX).$(SUFFIX) +SGEMMOTCOPYOBJ = sgemm_otcopy$(TSUFFIX).$(SUFFIX) + +DTRMMKERNEL = dtrmm_kernel_4x8_haswell.c +DGEMMKERNEL = dgemm_kernel_4x8_haswell.S +DGEMMINCOPY = ../generic/gemm_ncopy_4.c +DGEMMITCOPY = ../generic/gemm_tcopy_4.c +DGEMMONCOPY = ../generic/gemm_ncopy_8.c +DGEMMOTCOPY = ../generic/gemm_tcopy_8.c +DGEMMINCOPYOBJ = dgemm_incopy$(TSUFFIX).$(SUFFIX) +DGEMMITCOPYOBJ = dgemm_itcopy$(TSUFFIX).$(SUFFIX) +DGEMMONCOPYOBJ = dgemm_oncopy$(TSUFFIX).$(SUFFIX) +DGEMMOTCOPYOBJ = dgemm_otcopy$(TSUFFIX).$(SUFFIX) + +CTRMMKERNEL = cgemm_kernel_8x2_haswell.S +CGEMMKERNEL = cgemm_kernel_8x2_haswell.S +CGEMMINCOPY = ../generic/zgemm_ncopy_8.c +CGEMMITCOPY = ../generic/zgemm_tcopy_8.c +CGEMMONCOPY = ../generic/zgemm_ncopy_2.c +CGEMMOTCOPY = ../generic/zgemm_tcopy_2.c +CGEMMINCOPYOBJ = cgemm_incopy$(TSUFFIX).$(SUFFIX) +CGEMMITCOPYOBJ = cgemm_itcopy$(TSUFFIX).$(SUFFIX) +CGEMMONCOPYOBJ = cgemm_oncopy$(TSUFFIX).$(SUFFIX) +CGEMMOTCOPYOBJ = cgemm_otcopy$(TSUFFIX).$(SUFFIX) + +ZTRMMKERNEL = zgemm_kernel_4x2_haswell.S +ZGEMMKERNEL = zgemm_kernel_4x2_haswell.S +ZGEMMINCOPY = ../generic/zgemm_ncopy_4.c +ZGEMMITCOPY = ../generic/zgemm_tcopy_4.c +ZGEMMONCOPY = ../generic/zgemm_ncopy_2.c +ZGEMMOTCOPY = ../generic/zgemm_tcopy_2.c +ZGEMMINCOPYOBJ = zgemm_incopy$(TSUFFIX).$(SUFFIX) +ZGEMMITCOPYOBJ = zgemm_itcopy$(TSUFFIX).$(SUFFIX) +ZGEMMONCOPYOBJ = zgemm_oncopy$(TSUFFIX).$(SUFFIX) +ZGEMMOTCOPYOBJ = zgemm_otcopy$(TSUFFIX).$(SUFFIX) + +STRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +STRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +STRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +STRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +DTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +DTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +DTRSMKERNEL_RN = dtrsm_kernel_RN_haswell.c +DTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +CTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +CTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +CTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +CTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +ZTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +ZTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +ZTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +ZTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +CGEMM3MKERNEL = zgemm3m_kernel_4x8_nehalem.S +ZGEMM3MKERNEL = zgemm3m_kernel_2x8_nehalem.S + diff --git a/kernel/x86_64/caxpy.c b/kernel/x86_64/caxpy.c index 5af9b8fcc9..b1ec19bd3d 100644 --- a/kernel/x86_64/caxpy.c +++ b/kernel/x86_64/caxpy.c @@ -33,7 +33,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "caxpy_microk_steamroller-2.c" #elif defined(BULLDOZER) #include "caxpy_microk_bulldozer-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "caxpy_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "caxpy_microk_sandy-2.c" diff --git a/kernel/x86_64/cdot.c b/kernel/x86_64/cdot.c index 9bba72ba20..ce396a2ceb 100644 --- a/kernel/x86_64/cdot.c +++ b/kernel/x86_64/cdot.c @@ -34,7 +34,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "cdot_microk_bulldozer-2.c" #elif defined(STEAMROLLER) || defined(PILEDRIVER) || defined(EXCAVATOR) #include "cdot_microk_steamroller-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "cdot_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "cdot_microk_sandy-2.c" @@ -100,8 +100,7 @@ FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG in if ( n <= 0 ) { - __real__ result = 0.0 ; - __imag__ result = 0.0 ; + result = OPENBLAS_MAKE_COMPLEX_FLOAT (0.0, 0.0) ; return(result); } @@ -161,11 +160,13 @@ FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG in } #if !defined(CONJ) - __real__ result = dot[0] - dot[1]; - __imag__ result = dot[4] + dot[5]; + result = OPENBLAS_MAKE_COMPLEX_FLOAT (dot[0]-dot[1], dot[4]+dot[5]) ; +// CREAL(result) = dot[0] - dot[1]; +// CIMAG(result) = dot[4] + dot[5]; #else - __real__ result = dot[0] + dot[1]; - __imag__ result = dot[4] - dot[5]; + result = OPENBLAS_MAKE_COMPLEX_FLOAT (dot[0]+dot[1], dot[4]-dot[5]) ; +// CREAL(result) = dot[0] + dot[1]; +// CIMAG(result) = dot[4] - dot[5]; #endif diff --git a/kernel/x86_64/cgemv_n_4.c b/kernel/x86_64/cgemv_n_4.c index 2355105344..d0a2c84e22 100644 --- a/kernel/x86_64/cgemv_n_4.c +++ b/kernel/x86_64/cgemv_n_4.c @@ -29,7 +29,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include #include "common.h" -#if defined(HASWELL) +#if defined(HASWELL) || defined(ZEN) #include "cgemv_n_microk_haswell-4.c" #elif defined(BULLDOZER) || defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "cgemv_n_microk_bulldozer-4.c" diff --git a/kernel/x86_64/cgemv_t_4.c b/kernel/x86_64/cgemv_t_4.c index 1a714f61fe..3dc19dc4e2 100644 --- a/kernel/x86_64/cgemv_t_4.c +++ b/kernel/x86_64/cgemv_t_4.c @@ -28,7 +28,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#if defined(HASWELL) +#if defined(HASWELL) || defined(ZEN) #include "cgemv_t_microk_haswell-4.c" #elif defined(BULLDOZER) || defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "cgemv_t_microk_bulldozer-4.c" diff --git a/kernel/x86_64/cscal.c b/kernel/x86_64/cscal.c index c44d12e3da..9b9179da04 100644 --- a/kernel/x86_64/cscal.c +++ b/kernel/x86_64/cscal.c @@ -28,7 +28,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#if defined(HASWELL) +#if defined(HASWELL) || defined(ZEN) #include "cscal_microk_haswell-2.c" #elif defined(BULLDOZER) || defined(PILEDRIVER) #include "cscal_microk_bulldozer-2.c" diff --git a/kernel/x86_64/cscal_microk_bulldozer-2.c b/kernel/x86_64/cscal_microk_bulldozer-2.c index f470cf8433..3abffc4cfa 100644 --- a/kernel/x86_64/cscal_microk_bulldozer-2.c +++ b/kernel/x86_64/cscal_microk_bulldozer-2.c @@ -120,7 +120,7 @@ static void cscal_kernel_16( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -212,7 +212,7 @@ static void cscal_kernel_16_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -289,7 +289,7 @@ static void cscal_kernel_16_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -334,7 +334,7 @@ static void cscal_kernel_16_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/cscal_microk_haswell-2.c b/kernel/x86_64/cscal_microk_haswell-2.c index 0424de3a5e..48e3395018 100644 --- a/kernel/x86_64/cscal_microk_haswell-2.c +++ b/kernel/x86_64/cscal_microk_haswell-2.c @@ -120,7 +120,7 @@ static void cscal_kernel_16( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", //"0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -212,7 +212,7 @@ static void cscal_kernel_16_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", // "0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -289,7 +289,7 @@ static void cscal_kernel_16_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -334,7 +334,7 @@ static void cscal_kernel_16_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", //"0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/cscal_microk_steamroller-2.c b/kernel/x86_64/cscal_microk_steamroller-2.c index 763e7add41..8346e17483 100644 --- a/kernel/x86_64/cscal_microk_steamroller-2.c +++ b/kernel/x86_64/cscal_microk_steamroller-2.c @@ -121,7 +121,7 @@ static void cscal_kernel_16( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", //"0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -213,7 +213,7 @@ static void cscal_kernel_16_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", //"0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -290,7 +290,7 @@ static void cscal_kernel_16_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -335,7 +335,7 @@ static void cscal_kernel_16_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "0", "1", + : "cc", //"0", "1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/daxpy.c b/kernel/x86_64/daxpy.c index 18569e6e41..4bde62824f 100644 --- a/kernel/x86_64/daxpy.c +++ b/kernel/x86_64/daxpy.c @@ -37,7 +37,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "daxpy_microk_steamroller-2.c" #elif defined(PILEDRIVER) #include "daxpy_microk_piledriver-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "daxpy_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "daxpy_microk_sandy-2.c" diff --git a/kernel/x86_64/ddot.c b/kernel/x86_64/ddot.c index a45dd7f3b0..0a20564cf4 100644 --- a/kernel/x86_64/ddot.c +++ b/kernel/x86_64/ddot.c @@ -37,7 +37,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "ddot_microk_piledriver-2.c" #elif defined(NEHALEM) #include "ddot_microk_nehalem-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "ddot_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "ddot_microk_sandy-2.c" diff --git a/kernel/x86_64/dgemm_kernel_4x8_sandy.S b/kernel/x86_64/dgemm_kernel_4x8_sandy.S index a52bb07883..926395c493 100644 --- a/kernel/x86_64/dgemm_kernel_4x8_sandy.S +++ b/kernel/x86_64/dgemm_kernel_4x8_sandy.S @@ -277,7 +277,7 @@ LEAQ (, %rax, SIZE), %rax; LEAQ (ptrba, %rax, 8), ptrba; LEAQ (ptrbb, %rax, 4), ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### PREFETCH2 0*SIZE(prebb); XOR_DY yvec15, yvec15, yvec15; PREFETCH2 8*SIZE(prebb); @@ -317,7 +317,7 @@ ALIGN_5; .L2_bodyB:; # Computing kernel -#### Unroll times 1 #### +//#### Unroll times 1 #### LD_DY 4*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; SHUF_DY $0x03, yvec2, yvec2, yvec4; @@ -345,7 +345,7 @@ MUL_DY yvec1, yvec5, yvec7; ADD_DY yvec10, yvec6, yvec10; ADD_DY yvec8, yvec7, yvec8; -#### Unroll times 2 #### +//#### Unroll times 2 #### LD_DY 12*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; SHUF_DY $0x03, yvec2, yvec2, yvec4; @@ -373,7 +373,7 @@ MUL_DY yvec1, yvec5, yvec7; ADD_DY yvec10, yvec6, yvec10; ADD_DY yvec8, yvec7, yvec8; -#### Unroll times 3 #### +//#### Unroll times 3 #### LD_DY 20*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; SHUF_DY $0x03, yvec2, yvec2, yvec4; @@ -402,7 +402,7 @@ MUL_DY yvec1, yvec5, yvec7; ADD_DY yvec10, yvec6, yvec10; ADD_DY yvec8, yvec7, yvec8; -#### Unroll times 4 #### +//#### Unroll times 4 #### LD_DY 28*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; SHUF_DY $0x03, yvec2, yvec2, yvec4; @@ -446,7 +446,7 @@ TEST $2, %rax; JLE .L3_loopE; ALIGN_5 .L3_bodyB: -#### Unroll times 1 #### +//#### Unroll times 1 #### PREFETCH0 64*SIZE(ptrba) LD_DY 4*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; @@ -475,7 +475,7 @@ MUL_DY yvec1, yvec5, yvec7; ADD_DY yvec10, yvec6, yvec10; ADD_DY yvec8, yvec7, yvec8; -#### Unroll times 2 #### +//#### Unroll times 2 #### PREFETCH0 72*SIZE(ptrba) LD_DY 12*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; @@ -516,7 +516,7 @@ TEST $1, %rax; JLE .L4_loopE; ALIGN_5 .L4_bodyB:; -#### Unroll times 1 #### +//#### Unroll times 1 #### PREFETCH0 64*SIZE(ptrba) LD_DY 4*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; @@ -544,9 +544,9 @@ ADD_DY yvec10, yvec6, yvec10; ADD_DY yvec8, yvec7, yvec8; .L4_loopE:; -#### Load Alpha #### +//#### Load Alpha #### BROAD_DY MEMALPHA,yvec7; -#### Multiply Alpha #### +//#### Multiply Alpha #### MUL_DY yvec7,yvec15,yvec15; MUL_DY yvec7,yvec14,yvec14; MUL_DY yvec7,yvec13,yvec13; @@ -555,7 +555,7 @@ MUL_DY yvec7,yvec11,yvec11; MUL_DY yvec7,yvec10,yvec10; MUL_DY yvec7,yvec9,yvec9; MUL_DY yvec7,yvec8,yvec8; -#### Reverse the Results #### +//#### Reverse the Results #### MOV_DY yvec15,yvec7; REVS_DY $0x0a,yvec13,yvec15,yvec15; REVS_DY $0x0a,yvec7,yvec13,yvec13; @@ -568,13 +568,13 @@ REVS_DY $0x0a,yvec7,yvec9,yvec9; MOV_DY yvec10,yvec7; REVS_DY $0x0a,yvec8,yvec10,yvec10; REVS_DY $0x0a,yvec7,yvec8,yvec8; -#### Testing alignment #### +//#### Testing alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L4_loopEx; # Unalign part write back ALIGN_5 -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1,yvec15,xvec7; EXTRA_DY $1,yvec14,xvec6; EXTRA_DY $1,yvec13,xvec5; @@ -776,7 +776,7 @@ LEAQ (, %rax, SIZE), %rax; LEAQ (ptrba, %rax, 4), ptrba; LEAQ (ptrbb, %rax, 4), ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; XOR_DY yvec13, yvec13, yvec13; LD_DY 0*SIZE(ptrbb), yvec2; @@ -805,7 +805,7 @@ ALIGN_5; .L6_bodyB:; # Computing kernel -#### Untoll time 1 #### +//#### Untoll time 1 #### LD_DY 4*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -821,7 +821,7 @@ VPERMILP_DY $0x05, yvec2, yvec3; MUL_DY yvec0, yvec5, yvec7; ADD_DY yvec9, yvec7, yvec9; -#### Untoll time 2 #### +//#### Untoll time 2 #### LD_DY 8*SIZE(ptrba), yvec0; MUL_DY yvec1, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -837,7 +837,7 @@ VPERMILP_DY $0x05, yvec2, yvec3; MUL_DY yvec1, yvec5, yvec7; ADD_DY yvec9, yvec7, yvec9; -#### Untoll time 3 #### +//#### Untoll time 3 #### LD_DY 12*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -855,7 +855,7 @@ ADDQ $16*SIZE, ptrbb; MUL_DY yvec0, yvec5, yvec7; ADD_DY yvec9, yvec7, yvec9; -#### Untoll time 4 #### +//#### Untoll time 4 #### LD_DY 0*SIZE(ptrba), yvec0; MUL_DY yvec1, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -883,7 +883,7 @@ TEST $2, %rax; JLE .L7_loopE; ALIGN_5 .L7_bodyB:; -#### Untoll time 1 #### +//#### Untoll time 1 #### LD_DY 4*SIZE(ptrba), yvec1; MUL_DY yvec0, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -901,7 +901,7 @@ ADDQ $8*SIZE, ptrbb; MUL_DY yvec0, yvec5, yvec7; ADD_DY yvec9, yvec7, yvec9; -#### Untoll time 2 #### +//#### Untoll time 2 #### LD_DY 0*SIZE(ptrba), yvec0; MUL_DY yvec1, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; @@ -927,7 +927,7 @@ TEST $1, %rax; JLE .L8_loopE; ALIGN_5 .L8_bodyB:; -#### Untoll time 1 #### +//#### Untoll time 1 #### MUL_DY yvec0, yvec2, yvec6; ADD_DY yvec15, yvec6, yvec15; SHUF_DY $0x03, yvec2, yvec2, yvec4; @@ -943,27 +943,27 @@ MUL_DY yvec0, yvec5, yvec7; ADD_DY yvec9, yvec7, yvec9; .L8_loopE:; -#### Load Alpha #### +//#### Load Alpha #### BROAD_DY MEMALPHA, yvec7; -#### Multiply Alpha #### +//#### Multiply Alpha #### MUL_DY yvec7,yvec15,yvec15; MUL_DY yvec7,yvec13,yvec13; MUL_DY yvec7,yvec11,yvec11; MUL_DY yvec7,yvec9,yvec9; -#### Reverse the Results #### +//#### Reverse the Results #### MOV_DY yvec15, yvec7; REVS_DY $0x0a,yvec13,yvec15,yvec15; REVS_DY $0x0a,yvec7,yvec13,yvec13; MOV_DY yvec11,yvec7; REVS_DY $0x0a,yvec9,yvec11,yvec11; REVS_DY $0x0a,yvec7,yvec9,yvec9; -#### Testing alignment #### +//#### Testing alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L8_loopEx; # Unalign part write back ALIGN_5 -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1,yvec15,xvec7; EXTRA_DY $1,yvec13,xvec5; EXTRA_DY $1,yvec11,xvec3; @@ -1076,7 +1076,7 @@ LEAQ (, %rax, SIZE), %rax; LEAQ (ptrba, %rax, 2), ptrba; LEAQ (ptrbb, %rax, 4), ptrbb #endif -#### Initial Results Register #### +//#### Initial Results Register #### LD_DX 0*SIZE(ptrbb), xvec2; XOR_DY yvec15, yvec15, yvec15; LD_DX 2*SIZE(ptrbb), xvec3; @@ -1106,7 +1106,7 @@ ALIGN_5; .L10_bodyB:; # Computing kernel -##### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 4*SIZE(ptrbb), xvec6; SHUF_DX $0x4e, xvec3, xvec5; MUL_DX xvec0, xvec2, xvec2; @@ -1123,7 +1123,7 @@ SHUF_DX $0x4e, xvec6, xvec4; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec9, xvec9; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 8*SIZE(ptrbb), xvec2; SHUF_DX $0x4e, xvec7, xvec5; MUL_DX xvec1, xvec6, xvec6; @@ -1140,7 +1140,7 @@ SHUF_DX $0x4e, xvec2, xvec4; MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec9, xvec9; -##### Unroll time 3 #### +//#### Unroll time 3 #### LD_DX 12*SIZE(ptrbb), xvec6; SHUF_DX $0x4e, xvec3, xvec5; MUL_DX xvec0, xvec2, xvec2; @@ -1159,7 +1159,7 @@ ADDQ $8*SIZE, ptrba; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec9, xvec9; -#### Unroll time 4 #### +//#### Unroll time 4 #### LD_DX 0*SIZE(ptrbb), xvec2; SHUF_DX $0x4e, xvec7, xvec5; MUL_DX xvec1, xvec6, xvec6; @@ -1188,7 +1188,7 @@ TEST $2, %rax; JLE .L11_loopE; ALIGN_5 .L11_bodyB:; -##### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 4*SIZE(ptrbb), xvec6; SHUF_DX $0x4e, xvec3, xvec5; MUL_DX xvec0, xvec2, xvec2; @@ -1208,7 +1208,7 @@ ADDQ $4*SIZE, ptrba; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec9, xvec9; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 0*SIZE(ptrbb), xvec2; SHUF_DX $0x4e, xvec7, xvec5; MUL_DX xvec1, xvec6, xvec6; @@ -1251,27 +1251,27 @@ MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec9, xvec9; .L12_loopE:; -#### Load Alpha #### +//#### Load Alpha #### BROAD_DX MEMALPHA, xvec7; -#### Multiply Alpha #### +//#### Multiply Alpha #### MUL_DX xvec7, xvec15, xvec15; MUL_DX xvec7, xvec13, xvec13; MUL_DX xvec7, xvec11, xvec11; MUL_DX xvec7, xvec9, xvec9; -#### Reverse the Results #### +//#### Reverse the Results #### MOV_DX xvec15, xvec6; REVS_DX xvec13, xvec15, xvec15; REVS_DX xvec6, xvec13, xvec13; MOV_DX xvec11, xvec6; REVS_DX xvec9, xvec11, xvec11; REVS_DX xvec6, xvec9, xvec9; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L12_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### #ifndef TRMMKERNEL ADD_DX 0*SIZE(C0), xvec13, xvec13; ADD_DX 0*SIZE(C0, ldc, 1), xvec15, xvec15; @@ -1345,7 +1345,7 @@ LEAQ (,%rax, SIZE), %rax; ADDQ %rax, ptrba; LEAQ (ptrbb, %rax, 4), ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; #ifndef TRMMKERNEL MOVQ bk, k; @@ -1429,11 +1429,11 @@ ADDQ $1*SIZE, ptrba; ADDQ $4*SIZE, ptrbb; .L16_loopE: -#### Load Alpha #### +//#### Load Alpha #### BROAD_DY MEMALPHA, yvec7; -#### Multiply Alpha #### +//#### Multiply Alpha #### MUL_DY yvec15, yvec7, yvec15; -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1, yvec15, xvec7; #ifndef TRMMKERNEL LDL_DX 0*SIZE(C0), xvec0, xvec0; @@ -1497,7 +1497,7 @@ LEAQ (, %rax, SIZE), %rax; LEAQ (ptrba, %rax, 8), ptrba; LEAQ (ptrbb, %rax, 2), ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; XOR_DY yvec14, yvec14, yvec14; XOR_DY yvec13, yvec13, yvec13; @@ -1526,7 +1526,7 @@ JLE .L211_loopE; ALIGN_5; .L211_bodyB: # Computing kernel -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1563,7 +1563,7 @@ ADD_DX xvec6, xvec9, xvec9; MUL_DX xvec3, xvec7, xvec7; ADD_DX xvec7, xvec8, xvec8; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 8*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1600,7 +1600,7 @@ ADD_DX xvec6, xvec9, xvec9; MUL_DX xvec3, xvec7, xvec7; ADD_DX xvec7, xvec8, xvec8; -#### Unroll time 3 #### +//#### Unroll time 3 #### LD_DX 16*SIZE(ptrba), xvec0; LD_DX 4*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1637,7 +1637,7 @@ ADD_DX xvec6, xvec9, xvec9; MUL_DX xvec3, xvec7, xvec7; ADD_DX xvec7, xvec8, xvec8; -#### Unroll time 4 #### +//#### Unroll time 4 #### LD_DX 24*SIZE(ptrba), xvec0; LD_DX 6*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1689,7 +1689,7 @@ JLE .L212_loopE; ALIGN_5; .L212_bodyB: # Computing kernel -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1726,7 +1726,7 @@ ADD_DX xvec6, xvec9, xvec9; MUL_DX xvec3, xvec7, xvec7; ADD_DX xvec7, xvec8, xvec8; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 8*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1775,7 +1775,7 @@ TEST $1, %rax; JLE .L213_loopE; ALIGN_5 .L213_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1815,7 +1815,7 @@ MUL_DX xvec3, xvec7, xvec7; ADD_DX xvec7, xvec8, xvec8; .L213_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DX MEMALPHA, xvec7; MUL_DX xvec7, xvec15, xvec15; MUL_DX xvec7, xvec14, xvec14; @@ -1825,7 +1825,7 @@ MUL_DX xvec7, xvec11, xvec11; MUL_DX xvec7, xvec10, xvec10; MUL_DX xvec7, xvec9, xvec9; MUL_DX xvec7, xvec8, xvec8; -#### Reverse ##### +//#### Reverse #### MOV_DX xvec15, xvec6; REVS_DX xvec11, xvec15, xvec15; REVS_DX xvec6, xvec11, xvec11; @@ -1838,13 +1838,13 @@ REVS_DX xvec6, xvec9, xvec9; MOV_DX xvec12, xvec6; REVS_DX xvec8, xvec12, xvec12; REVS_DX xvec6, xvec8, xvec8; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L213_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### #ifndef TRMMKERNEL ADD_DX 0*SIZE(C0), xvec11, xvec11; ADD_DX 2*SIZE(C0), xvec10, xvec10; @@ -1952,7 +1952,7 @@ LEAQ (,%rax, SIZE), %rax; LEAQ (ptrba, %rax, 4), ptrba; LEAQ (ptrbb, %rax, 2), ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; XOR_DY yvec14, yvec14, yvec14; XOR_DY yvec11, yvec11, yvec11; @@ -1977,7 +1977,7 @@ JLE .L221_loopE; ALIGN_5 .L221_bodyB:; # Computing kernel -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -1996,7 +1996,7 @@ ADD_DX xvec4, xvec11, xvec11; MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec10, xvec10; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 4*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2015,7 +2015,7 @@ ADD_DX xvec4, xvec11, xvec11; MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec10, xvec10; -#### Unroll time 3 #### +//#### Unroll time 3 #### LD_DX 8*SIZE(ptrba), xvec0; LD_DX 4*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2034,7 +2034,7 @@ ADD_DX xvec4, xvec11, xvec11; MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec10, xvec10; -#### Unroll time 4 #### +//#### Unroll time 4 #### LD_DX 12*SIZE(ptrba), xvec0; LD_DX 6*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2067,7 +2067,7 @@ TEST $2, %rax; JLE .L222_loopE; ALIGN_5 .L222_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2086,7 +2086,7 @@ ADD_DX xvec4, xvec11, xvec11; MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec10, xvec10; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 4*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2116,7 +2116,7 @@ TEST $1, %rax; JLE .L223_loopE; ALIGN_5 .L223_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; MOV_DX xvec4, xvec5; @@ -2138,26 +2138,26 @@ MUL_DX xvec1, xvec5, xvec5; ADD_DX xvec5, xvec10, xvec10; .L223_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DX MEMALPHA, xvec7; MUL_DX xvec7, xvec15, xvec15; MUL_DX xvec7, xvec14, xvec14; MUL_DX xvec7, xvec11, xvec11; MUL_DX xvec7, xvec10, xvec10; -#### Reverse ##### +//#### Reverse #### MOV_DX xvec15, xvec6; REVS_DX xvec11, xvec15, xvec15; REVS_DX xvec6, xvec11, xvec11; MOV_DX xvec14, xvec6; REVS_DX xvec10, xvec14, xvec14; REVS_DX xvec6, xvec10, xvec10; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L223_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### #ifndef TRMMKERNEL ADD_DX 0*SIZE(C0), xvec11, xvec11; ADD_DX 2*SIZE(C0), xvec10, xvec10; @@ -2220,7 +2220,7 @@ ADDQ $4, kk ADDQ $4*SIZE, C0; ADDQ $4*SIZE, C1; .L22_loopE:; -TEST $2, bm; # Rm = 2 +TEST $2, bm; // Rm = 2 JLE .L23_loopE; ALIGN_5; .L23_bodyB: @@ -2255,7 +2255,7 @@ JLE .L231_loopE; ALIGN_5 .L231_bodyB: # Computing kernel -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2264,7 +2264,7 @@ ADD_DX xvec4, xvec15, xvec15; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec11, xvec11; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 2*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2273,7 +2273,7 @@ ADD_DX xvec4, xvec15, xvec15; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec11, xvec11; -#### Unroll time 3 #### +//#### Unroll time 3 #### LD_DX 4*SIZE(ptrba), xvec0; LD_DX 4*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2282,7 +2282,7 @@ ADD_DX xvec4, xvec15, xvec15; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec11, xvec11; -#### Unroll time 4 #### +//#### Unroll time 4 #### LD_DX 6*SIZE(ptrba), xvec0; LD_DX 6*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2305,7 +2305,7 @@ TEST $2, %rax; JLE .L232_loopE; ALIGN_5 .L232_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2314,7 +2314,7 @@ ADD_DX xvec4, xvec15, xvec15; MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec11, xvec11; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DX 2*SIZE(ptrba), xvec0; LD_DX 2*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2334,7 +2334,7 @@ TEST $1, %rax; JLE .L233_loopE; ALIGN_5 .L233_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DX 0*SIZE(ptrba), xvec0; LD_DX 0*SIZE(ptrbb), xvec4; SHUF_DX $0x4e, xvec4, xvec5; @@ -2345,21 +2345,21 @@ MUL_DX xvec0, xvec5, xvec5; ADD_DX xvec5, xvec11, xvec11; ADDQ $2*SIZE, ptrbb; .L233_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DX MEMALPHA, xvec7; MUL_DX xvec7, xvec15, xvec15; MUL_DX xvec7, xvec11, xvec11; -#### Reverse ##### +//#### Reverse #### MOV_DX xvec15, xvec6; REVS_DX xvec11, xvec15, xvec15; REVS_DX xvec6, xvec11, xvec11; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L233_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### #ifndef TRMMKERNEL ADD_DX 0*SIZE(C0), xvec11, xvec11; ADD_DX 0*SIZE(C1), xvec15, xvec15; @@ -2408,7 +2408,7 @@ ADDQ $2, kk; ADDQ $2*SIZE, C0; ADDQ $2*SIZE, C1; .L23_loopE: -TEST $1, bm; # Rm = 1 +TEST $1, bm; // Rm = 1 JLE .L24_loopE; ALIGN_5; .L24_bodyB: @@ -2534,7 +2534,7 @@ SALQ $4, k; ADDQ k, bb; LEAQ (C, ldc, 2), C; .L20_loopE:; -TEST $1, bn; # Rn = 1 +TEST $1, bn; // Rn = 1 JLE .L30_loopE; ALIGN_5 .L30_bodyB: @@ -2558,7 +2558,7 @@ LEAQ (, %rax, SIZE), %rax; LEAQ (ptrba, %rax, 8), ptrba; ADDQ %rax, ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; XOR_DY yvec14, yvec14, yvec14; #ifndef TRMMKERNEL @@ -2580,7 +2580,7 @@ SARQ $2, k; JLE .L311_loopE; ALIGN_5 .L311_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DY 0*SIZE(ptrba), yvec0; LD_DY 4*SIZE(ptrba), yvec1; BROAD_DY 0*SIZE(ptrbb), yvec2; @@ -2589,7 +2589,7 @@ ADD_DY yvec0, yvec15, yvec15; MUL_DY yvec2, yvec1, yvec1; ADD_DY yvec1, yvec14, yvec14; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DY 8*SIZE(ptrba), yvec3; LD_DY 12*SIZE(ptrba), yvec4; BROAD_DY 1*SIZE(ptrbb), yvec5; @@ -2598,7 +2598,7 @@ ADD_DY yvec3, yvec15, yvec15; MUL_DY yvec5, yvec4, yvec4 ADD_DY yvec4, yvec14, yvec14; -#### Unroll time 3 #### +//#### Unroll time 3 #### LD_DY 16*SIZE(ptrba), yvec0; LD_DY 20*SIZE(ptrba), yvec1; BROAD_DY 2*SIZE(ptrbb), yvec2; @@ -2607,7 +2607,7 @@ ADD_DY yvec0, yvec15, yvec15; MUL_DY yvec2, yvec1, yvec1; ADD_DY yvec1, yvec14, yvec14; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DY 24*SIZE(ptrba), yvec3; LD_DY 28*SIZE(ptrba), yvec4; BROAD_DY 3*SIZE(ptrbb), yvec5; @@ -2630,7 +2630,7 @@ TEST $2, %rax; JLE .L312_loopE; ALIGN_5 .L312_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DY 0*SIZE(ptrba), yvec0; LD_DY 4*SIZE(ptrba), yvec1; BROAD_DY 0*SIZE(ptrbb), yvec2; @@ -2639,7 +2639,7 @@ ADD_DY yvec0, yvec15, yvec15; MUL_DY yvec2, yvec1, yvec1; ADD_DY yvec1, yvec14, yvec14; -#### Unroll time 2 #### +//#### Unroll time 2 #### LD_DY 8*SIZE(ptrba), yvec3; LD_DY 12*SIZE(ptrba), yvec4; BROAD_DY 1*SIZE(ptrbb), yvec5; @@ -2660,7 +2660,7 @@ TEST $1, %rax; JLE .L313_loopE; ALIGN_5 .L313_bodyB: -#### Unroll time 1 #### +//#### Unroll time 1 #### LD_DY 0*SIZE(ptrba), yvec0; LD_DY 4*SIZE(ptrba), yvec1; BROAD_DY 0*SIZE(ptrbb), yvec2; @@ -2672,17 +2672,17 @@ ADD_DY yvec1, yvec14, yvec14; ADDQ $1*SIZE, ptrbb; .L313_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DY MEMALPHA, yvec7; MUL_DY yvec7, yvec15, yvec15; MUL_DY yvec7, yvec14, yvec14; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L313_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1, yvec15, xvec13; EXTRA_DY $1, yvec14, xvec12; #ifndef TRMMKERNEL @@ -2762,7 +2762,7 @@ LEAQ (,%rax, SIZE), %rax; LEAQ (ptrba, %rax, 4), ptrba; ADDQ %rax, ptrbb; #endif -#### Initial Results Register #### +//#### Initial Results Register #### XOR_DY yvec15, yvec15, yvec15; #ifndef TRMMKERNEL MOVQ bk, k; @@ -2847,16 +2847,16 @@ ADDQ $4*SIZE, ptrba; ADDQ $1*SIZE, ptrbb; .L323_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DY MEMALPHA, yvec7; MUL_DY yvec7, yvec15, yvec15; -#### Testing Alignment #### +//#### Testing Alignment #### MOVQ C0, %rax; OR ldc, %rax; TEST $15, %rax; JNE .L323_loopEx; ALIGN_5 -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1, yvec15, xvec14; #ifndef TRMMKERNEL ADD_DX 0*SIZE(C0), xvec15, xvec15; @@ -2878,7 +2878,7 @@ ADDQ $4*SIZE, C0; JMP .L32_loopE; ALIGN_5 .L323_loopEx: -#### Writing Back #### +//#### Writing Back #### EXTRA_DY $1, yvec15, xvec14; #ifndef TRMMKERNEL LDL_DX 0*SIZE(C0), xvec13, xvec13; @@ -2917,7 +2917,7 @@ LEAQ (, %rax, SIZE), %rax LEAQ (ptrba, %rax, 2), ptrba ADDQ %rax, ptrbb; #endif -#### Initial Result #### +//#### Initial Result #### XOR_DY yvec15, yvec15, yvec15; #ifndef TRMMKERNEL MOVQ bk, k; @@ -3000,7 +3000,7 @@ ADD_DX xvec2, xvec15, xvec15; ADDQ $2*SIZE, ptrba; ADDQ $1*SIZE, ptrbb; .L333_loopE: -#### Multiply Alpha #### +//#### Multiply Alpha #### BROAD_DX MEMALPHA, xvec7; MUL_DX xvec7, xvec15, xvec15; #ifndef TRMMKERNEL @@ -3119,7 +3119,7 @@ addq $1*SIZE, ptrba; addq $1*SIZE, ptrbb; .L343_loopE: -#### Writing Back #### +//#### Writing Back #### vmovsd MEMALPHA, xvec7; vmulsd xvec7, xvec15, xvec15; #ifndef TRMMKERNEL diff --git a/kernel/x86_64/dgemv_n_4.c b/kernel/x86_64/dgemv_n_4.c index 4200b8acde..f8234fbc1c 100644 --- a/kernel/x86_64/dgemv_n_4.c +++ b/kernel/x86_64/dgemv_n_4.c @@ -31,7 +31,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NEHALEM) #include "dgemv_n_microk_nehalem-4.c" -#elif defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) +#elif defined(HASWELL) || defined(ZEN) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "dgemv_n_microk_haswell-4.c" #endif diff --git a/kernel/x86_64/dgemv_t_4.c b/kernel/x86_64/dgemv_t_4.c index 42f11f39aa..3891e16ccd 100644 --- a/kernel/x86_64/dgemv_t_4.c +++ b/kernel/x86_64/dgemv_t_4.c @@ -28,7 +28,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#if defined(HASWELL) || defined(STEAMROLLER) || defined(EXCAVATOR) +#if defined(HASWELL) || defined(ZEN) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "dgemv_t_microk_haswell-4.c" #endif diff --git a/kernel/x86_64/dscal.c b/kernel/x86_64/dscal.c index bbc1c9660e..78ad521799 100644 --- a/kernel/x86_64/dscal.c +++ b/kernel/x86_64/dscal.c @@ -31,7 +31,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "dscal_microk_bulldozer-2.c" #elif defined(SANDYBRIDGE) #include "dscal_microk_sandy-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "dscal_microk_haswell-2.c" #endif @@ -141,7 +141,7 @@ static void dscal_kernel_inc_8(BLASLONG n, FLOAT *alpha, FLOAT *x, BLASLONG inc_ "r" (alpha), // 3 "r" (inc_x), // 4 "r" (inc_x3) // 5 - : "cc", "%0", "%1", "%2", + : "cc", //"%0", "%1", "%2", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/dsymv_L.c b/kernel/x86_64/dsymv_L.c index e10784ad73..3e8db3fa3f 100644 --- a/kernel/x86_64/dsymv_L.c +++ b/kernel/x86_64/dsymv_L.c @@ -30,7 +30,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(BULLDOZER) || defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "dsymv_L_microk_bulldozer-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "dsymv_L_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "dsymv_L_microk_sandy-2.c" diff --git a/kernel/x86_64/dsymv_U.c b/kernel/x86_64/dsymv_U.c index bd07ce2c3e..226458bf71 100644 --- a/kernel/x86_64/dsymv_U.c +++ b/kernel/x86_64/dsymv_U.c @@ -31,7 +31,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(BULLDOZER) || defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "dsymv_U_microk_bulldozer-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "dsymv_U_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "dsymv_U_microk_sandy-2.c" diff --git a/kernel/x86_64/saxpy.c b/kernel/x86_64/saxpy.c index b9e5d57841..d89fe408a6 100644 --- a/kernel/x86_64/saxpy.c +++ b/kernel/x86_64/saxpy.c @@ -31,7 +31,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(NEHALEM) #include "saxpy_microk_nehalem-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "saxpy_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "saxpy_microk_sandy-2.c" diff --git a/kernel/x86_64/sdot.c b/kernel/x86_64/sdot.c index d9fc417a07..389252f8b5 100644 --- a/kernel/x86_64/sdot.c +++ b/kernel/x86_64/sdot.c @@ -34,7 +34,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "sdot_microk_steamroller-2.c" #elif defined(NEHALEM) #include "sdot_microk_nehalem-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "sdot_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "sdot_microk_sandy-2.c" diff --git a/kernel/x86_64/sgemv_n_4.c b/kernel/x86_64/sgemv_n_4.c index bdf68dd07d..7c091c765f 100644 --- a/kernel/x86_64/sgemv_n_4.c +++ b/kernel/x86_64/sgemv_n_4.c @@ -35,7 +35,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "sgemv_n_microk_nehalem-4.c" #elif defined(SANDYBRIDGE) #include "sgemv_n_microk_sandy-4.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "sgemv_n_microk_haswell-4.c" #endif diff --git a/kernel/x86_64/sgemv_t_4.c b/kernel/x86_64/sgemv_t_4.c index 62550e65ce..6f9c7caa0f 100644 --- a/kernel/x86_64/sgemv_t_4.c +++ b/kernel/x86_64/sgemv_t_4.c @@ -34,7 +34,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "sgemv_t_microk_bulldozer-4.c" #elif defined(SANDYBRIDGE) #include "sgemv_t_microk_sandy-4.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "sgemv_t_microk_haswell-4.c" #endif diff --git a/kernel/x86_64/ssymv_L.c b/kernel/x86_64/ssymv_L.c index 3813981edf..199d8a5176 100644 --- a/kernel/x86_64/ssymv_L.c +++ b/kernel/x86_64/ssymv_L.c @@ -32,7 +32,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "ssymv_L_microk_bulldozer-2.c" #elif defined(NEHALEM) #include "ssymv_L_microk_nehalem-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "ssymv_L_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "ssymv_L_microk_sandy-2.c" diff --git a/kernel/x86_64/ssymv_U.c b/kernel/x86_64/ssymv_U.c index e4d3c9b30f..104b293550 100644 --- a/kernel/x86_64/ssymv_U.c +++ b/kernel/x86_64/ssymv_U.c @@ -33,7 +33,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "ssymv_U_microk_bulldozer-2.c" #elif defined(NEHALEM) #include "ssymv_U_microk_nehalem-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "ssymv_U_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "ssymv_U_microk_sandy-2.c" diff --git a/kernel/x86_64/symv_L_sse.S b/kernel/x86_64/symv_L_sse.S index cda0b476da..8cae3fc1b8 100644 --- a/kernel/x86_64/symv_L_sse.S +++ b/kernel/x86_64/symv_L_sse.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 12) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 12) diff --git a/kernel/x86_64/symv_L_sse2.S b/kernel/x86_64/symv_L_sse2.S index 0afc1e8c0c..d7091624d5 100644 --- a/kernel/x86_64/symv_L_sse2.S +++ b/kernel/x86_64/symv_L_sse2.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 12) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 12) diff --git a/kernel/x86_64/symv_U_sse.S b/kernel/x86_64/symv_U_sse.S index 691012cb1c..3549b98637 100644 --- a/kernel/x86_64/symv_U_sse.S +++ b/kernel/x86_64/symv_U_sse.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 12) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 12) diff --git a/kernel/x86_64/symv_U_sse2.S b/kernel/x86_64/symv_U_sse2.S index 8ecbb39e64..882b035a90 100644 --- a/kernel/x86_64/symv_U_sse2.S +++ b/kernel/x86_64/symv_U_sse2.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 12) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 24) diff --git a/kernel/x86_64/zaxpy.c b/kernel/x86_64/zaxpy.c index 0cd555a683..8cb1d532f1 100644 --- a/kernel/x86_64/zaxpy.c +++ b/kernel/x86_64/zaxpy.c @@ -33,7 +33,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "zaxpy_microk_bulldozer-2.c" #elif defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "zaxpy_microk_steamroller-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "zaxpy_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "zaxpy_microk_sandy-2.c" diff --git a/kernel/x86_64/zdot.c b/kernel/x86_64/zdot.c index 4533d4e885..2fcacc87a8 100644 --- a/kernel/x86_64/zdot.c +++ b/kernel/x86_64/zdot.c @@ -27,14 +27,13 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#include #if defined(BULLDOZER) #include "zdot_microk_bulldozer-2.c" #elif defined(STEAMROLLER) || defined(PILEDRIVER) || defined(EXCAVATOR) #include "zdot_microk_steamroller-2.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "zdot_microk_haswell-2.c" #elif defined(SANDYBRIDGE) #include "zdot_microk_sandy-2.c" @@ -96,8 +95,9 @@ FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG in if ( n <= 0 ) { - __real__ result = 0.0 ; - __imag__ result = 0.0 ; +// CREAL(result) = 0.0 ; +// CIMAG(result) = 0.0 ; + result=OPENBLAS_MAKE_COMPLEX_FLOAT(0.0,0.0); return(result); } @@ -151,11 +151,13 @@ FLOAT _Complex CNAME(BLASLONG n, FLOAT *x, BLASLONG inc_x, FLOAT *y, BLASLONG in } #if !defined(CONJ) - __real__ result = dot[0] - dot[1]; - __imag__ result = dot[2] + dot[3]; + result=OPENBLAS_MAKE_COMPLEX_FLOAT(dot[0]-dot[1],dot[2]+dot[3]); +// CREAL(result) = dot[0] - dot[1]; +// CIMAG(result) = dot[2] + dot[3]; #else - __real__ result = dot[0] + dot[1]; - __imag__ result = dot[2] - dot[3]; + result=OPENBLAS_MAKE_COMPLEX_FLOAT(dot[0]+dot[1],dot[2]-dot[3]); +// CREAL(result) = dot[0] + dot[1]; +// CIMAG(result) = dot[2] - dot[3]; #endif diff --git a/kernel/x86_64/zgemv_n_4.c b/kernel/x86_64/zgemv_n_4.c index 4171fc99fb..1d0f1e8f7c 100644 --- a/kernel/x86_64/zgemv_n_4.c +++ b/kernel/x86_64/zgemv_n_4.c @@ -30,7 +30,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#if defined(HASWELL) +#if defined(HASWELL) || defined(ZEN) #include "zgemv_n_microk_haswell-4.c" #elif defined(SANDYBRIDGE) #include "zgemv_n_microk_sandy-4.c" diff --git a/kernel/x86_64/zgemv_t_4.c b/kernel/x86_64/zgemv_t_4.c index 0524c71f7c..20ccf06f7e 100644 --- a/kernel/x86_64/zgemv_t_4.c +++ b/kernel/x86_64/zgemv_t_4.c @@ -31,7 +31,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #if defined(BULLDOZER) || defined(PILEDRIVER) || defined(STEAMROLLER) || defined(EXCAVATOR) #include "zgemv_t_microk_bulldozer-4.c" -#elif defined(HASWELL) +#elif defined(HASWELL) || defined(ZEN) #include "zgemv_t_microk_haswell-4.c" #endif diff --git a/kernel/x86_64/zscal.c b/kernel/x86_64/zscal.c index 7ca8774b79..aa5d8fac00 100644 --- a/kernel/x86_64/zscal.c +++ b/kernel/x86_64/zscal.c @@ -28,7 +28,7 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include "common.h" -#if defined(HASWELL) +#if defined(HASWELL) || defined(ZEN) #include "zscal_microk_haswell-2.c" #elif defined(BULLDOZER) || defined(PILEDRIVER) #include "zscal_microk_bulldozer-2.c" diff --git a/kernel/x86_64/zscal_microk_bulldozer-2.c b/kernel/x86_64/zscal_microk_bulldozer-2.c index 28fe734803..03882d6b66 100644 --- a/kernel/x86_64/zscal_microk_bulldozer-2.c +++ b/kernel/x86_64/zscal_microk_bulldozer-2.c @@ -120,7 +120,7 @@ static void zscal_kernel_8( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -212,7 +212,7 @@ static void zscal_kernel_8_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -289,7 +289,7 @@ static void zscal_kernel_8_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -334,7 +334,7 @@ static void zscal_kernel_8_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/zscal_microk_haswell-2.c b/kernel/x86_64/zscal_microk_haswell-2.c index a93308ec41..b1a34c1dd6 100644 --- a/kernel/x86_64/zscal_microk_haswell-2.c +++ b/kernel/x86_64/zscal_microk_haswell-2.c @@ -120,7 +120,7 @@ static void zscal_kernel_8( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -212,7 +212,7 @@ static void zscal_kernel_8_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -289,7 +289,7 @@ static void zscal_kernel_8_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -334,7 +334,7 @@ static void zscal_kernel_8_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/zscal_microk_steamroller-2.c b/kernel/x86_64/zscal_microk_steamroller-2.c index d611bf570f..97b07add65 100644 --- a/kernel/x86_64/zscal_microk_steamroller-2.c +++ b/kernel/x86_64/zscal_microk_steamroller-2.c @@ -121,7 +121,7 @@ static void zscal_kernel_8( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -213,7 +213,7 @@ static void zscal_kernel_8_zero_r( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -290,7 +290,7 @@ static void zscal_kernel_8_zero_i( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", @@ -335,7 +335,7 @@ static void zscal_kernel_8_zero( BLASLONG n, FLOAT *alpha, FLOAT *x) "r" (n), // 0 "r" (x), // 1 "r" (alpha) // 2 - : "cc", "%0", "%1", + : "cc", //"%0", "%1", "%xmm0", "%xmm1", "%xmm2", "%xmm3", "%xmm4", "%xmm5", "%xmm6", "%xmm7", "%xmm8", "%xmm9", "%xmm10", "%xmm11", diff --git a/kernel/x86_64/zsymv_L_sse.S b/kernel/x86_64/zsymv_L_sse.S index 3a5243bab1..dd95eea174 100644 --- a/kernel/x86_64/zsymv_L_sse.S +++ b/kernel/x86_64/zsymv_L_sse.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 24) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 24) diff --git a/kernel/x86_64/zsymv_L_sse2.S b/kernel/x86_64/zsymv_L_sse2.S index 295ab1a838..75124cf3ed 100644 --- a/kernel/x86_64/zsymv_L_sse2.S +++ b/kernel/x86_64/zsymv_L_sse2.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 24) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 24) diff --git a/kernel/x86_64/zsymv_U_sse.S b/kernel/x86_64/zsymv_U_sse.S index cf302e4ed7..db1a4ff5f8 100644 --- a/kernel/x86_64/zsymv_U_sse.S +++ b/kernel/x86_64/zsymv_U_sse.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 24) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 24) diff --git a/kernel/x86_64/zsymv_U_sse2.S b/kernel/x86_64/zsymv_U_sse2.S index 7c290137dd..599765a6de 100644 --- a/kernel/x86_64/zsymv_U_sse2.S +++ b/kernel/x86_64/zsymv_U_sse2.S @@ -57,7 +57,7 @@ #define PREFETCHSIZE (16 * 24) #endif -#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) +#if defined(NEHALEM) || defined(SANDYBRIDGE) || defined(HASWELL) || defined(ZEN) #define PREFETCH prefetcht0 #define PREFETCHW prefetcht0 #define PREFETCHSIZE (16 * 24) diff --git a/kernel/zarch/KERNEL b/kernel/zarch/KERNEL new file mode 100644 index 0000000000..68d68b5f86 --- /dev/null +++ b/kernel/zarch/KERNEL @@ -0,0 +1,30 @@ +ifndef SCABS_KERNEL +SCABS_KERNEL = ../generic/cabs.c +endif + +ifndef DCABS_KERNEL +DCABS_KERNEL = ../generic/cabs.c +endif + +ifndef QCABS_KERNEL +QCABS_KERNEL = ../generic/cabs.c +endif + +ifndef LSAME_KERNEL +LSAME_KERNEL = ../generic/lsame.c +endif + +ifndef SGEMM_BETA +SGEMM_BETA = ../generic/gemm_beta.c +endif +ifndef DGEMM_BETA +DGEMM_BETA = ../generic/gemm_beta.c +endif +ifndef CGEMM_BETA +CGEMM_BETA = ../generic/zgemm_beta.c +endif +ifndef ZGEMM_BETA +ZGEMM_BETA = ../generic/zgemm_beta.c +endif + + diff --git a/kernel/zarch/KERNEL.Z13 b/kernel/zarch/KERNEL.Z13 new file mode 100644 index 0000000000..9e3650bff9 --- /dev/null +++ b/kernel/zarch/KERNEL.Z13 @@ -0,0 +1,145 @@ +SAMAXKERNEL = ../arm/amax.c +DAMAXKERNEL = ../arm/amax.c +CAMAXKERNEL = ../arm/zamax.c +ZAMAXKERNEL = ../arm/zamax.c + +SAMINKERNEL = ../arm/amin.c +DAMINKERNEL = ../arm/amin.c +CAMINKERNEL = ../arm/zamin.c +ZAMINKERNEL = ../arm/zamin.c + +SMAXKERNEL = ../arm/max.c +DMAXKERNEL = ../arm/max.c + +SMINKERNEL = ../arm/min.c +DMINKERNEL = ../arm/min.c + +ISAMAXKERNEL = ../arm/iamax.c +IDAMAXKERNEL = ../arm/iamax.c +ICAMAXKERNEL = ../arm/izamax.c +IZAMAXKERNEL = ../arm/izamax.c + +ISAMINKERNEL = ../arm/iamin.c +IDAMINKERNEL = ../arm/iamin.c +ICAMINKERNEL = ../arm/izamin.c +IZAMINKERNEL = ../arm/izamin.c + +ISMAXKERNEL = ../arm/imax.c +IDMAXKERNEL = ../arm/imax.c + +ISMINKERNEL = ../arm/imin.c +IDMINKERNEL = ../arm/imin.c + +SASUMKERNEL = ../arm/asum.c +DASUMKERNEL = ../arm/asum.c +CASUMKERNEL = ../arm/zasum.c +ZASUMKERNEL = ../arm/zasum.c + +SAXPYKERNEL = ../arm/axpy.c +DAXPYKERNEL = ../arm/axpy.c +CAXPYKERNEL = ../arm/zaxpy.c +ZAXPYKERNEL = ../arm/zaxpy.c + +SCOPYKERNEL = ../arm/copy.c +DCOPYKERNEL = ../arm/copy.c +CCOPYKERNEL = ../arm/zcopy.c +ZCOPYKERNEL = ../arm/zcopy.c + +SDOTKERNEL = ../arm/dot.c +DDOTKERNEL = ../arm/dot.c +CDOTKERNEL = ../arm/zdot.c +ZDOTKERNEL = ../arm/zdot.c + +SNRM2KERNEL = ../arm/nrm2.c +DNRM2KERNEL = ../arm/nrm2.c +CNRM2KERNEL = ../arm/znrm2.c +ZNRM2KERNEL = ../arm/znrm2.c + +SROTKERNEL = ../arm/rot.c +DROTKERNEL = ../arm/rot.c +CROTKERNEL = ../arm/zrot.c +ZROTKERNEL = ../arm/zrot.c + +SSCALKERNEL = ../arm/scal.c +DSCALKERNEL = ../arm/scal.c +CSCALKERNEL = ../arm/zscal.c +ZSCALKERNEL = ../arm/zscal.c + +SSWAPKERNEL = ../arm/swap.c +DSWAPKERNEL = ../arm/swap.c +CSWAPKERNEL = ../arm/zswap.c +ZSWAPKERNEL = ../arm/zswap.c + +SGEMVNKERNEL = ../arm/gemv_n.c +DGEMVNKERNEL = ../arm/gemv_n.c +CGEMVNKERNEL = ../arm/zgemv_n.c +ZGEMVNKERNEL = ../arm/zgemv_n.c + +SGEMVTKERNEL = ../arm/gemv_t.c +DGEMVTKERNEL = ../arm/gemv_t.c +CGEMVTKERNEL = ../arm/zgemv_t.c +ZGEMVTKERNEL = ../arm/zgemv_t.c + +STRMMKERNEL = strmm8x4V.S +DTRMMKERNEL = trmm8x4V.S +CTRMMKERNEL = ctrmm4x4V.S +ZTRMMKERNEL = ztrmm4x4V.S + +SGEMMKERNEL = strmm8x4V.S +SGEMMINCOPY = ../generic/gemm_ncopy_8.c +SGEMMITCOPY = ../generic/gemm_tcopy_8.c +SGEMMONCOPY = ../generic/gemm_ncopy_4.c +SGEMMOTCOPY = ../generic/gemm_tcopy_4.c +SGEMMINCOPYOBJ = sgemm_incopy.o +SGEMMITCOPYOBJ = sgemm_itcopy.o +SGEMMONCOPYOBJ = sgemm_oncopy.o +SGEMMOTCOPYOBJ = sgemm_otcopy.o + + + +DGEMMKERNEL = gemm8x4V.S +DGEMMINCOPY = ../generic/gemm_ncopy_8.c +DGEMMITCOPY = ../generic/gemm_tcopy_8.c +DGEMMONCOPY = ../generic/gemm_ncopy_4.c +DGEMMOTCOPY = ../generic/gemm_tcopy_4.c +DGEMMINCOPYOBJ = dgemm_incopy.o +DGEMMITCOPYOBJ = dgemm_itcopy.o +DGEMMONCOPYOBJ = dgemm_oncopy.o +DGEMMOTCOPYOBJ = dgemm_otcopy.o + +CGEMMKERNEL = ctrmm4x4V.S +CGEMMONCOPY = ../generic/zgemm_ncopy_4.c +CGEMMOTCOPY = ../generic/zgemm_tcopy_4.c +CGEMMONCOPYOBJ = cgemm_oncopy.o +CGEMMOTCOPYOBJ = cgemm_otcopy.o + +ZGEMMKERNEL = ztrmm4x4V.S +ZGEMMONCOPY = ../generic/zgemm_ncopy_4.c +ZGEMMOTCOPY = ../generic/zgemm_tcopy_4.c +ZGEMMONCOPYOBJ = zgemm_oncopy$(TSUFFIX).$(SUFFIX) +ZGEMMOTCOPYOBJ = zgemm_otcopy$(TSUFFIX).$(SUFFIX) + +STRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +STRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +STRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +STRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +DTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +DTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +DTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +DTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +CTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +CTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +CTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +CTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +ZTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +ZTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +ZTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +ZTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + + + + + diff --git a/kernel/zarch/KERNEL.ZARCH_GENERIC b/kernel/zarch/KERNEL.ZARCH_GENERIC new file mode 100644 index 0000000000..d80f84e711 --- /dev/null +++ b/kernel/zarch/KERNEL.ZARCH_GENERIC @@ -0,0 +1,133 @@ +SAMAXKERNEL = ../arm/amax.c +DAMAXKERNEL = ../arm/amax.c +CAMAXKERNEL = ../arm/zamax.c +ZAMAXKERNEL = ../arm/zamax.c + +SAMINKERNEL = ../arm/amin.c +DAMINKERNEL = ../arm/amin.c +CAMINKERNEL = ../arm/zamin.c +ZAMINKERNEL = ../arm/zamin.c + +SMAXKERNEL = ../arm/max.c +DMAXKERNEL = ../arm/max.c + +SMINKERNEL = ../arm/min.c +DMINKERNEL = ../arm/min.c + +ISAMAXKERNEL = ../arm/iamax.c +IDAMAXKERNEL = ../arm/iamax.c +ICAMAXKERNEL = ../arm/izamax.c +IZAMAXKERNEL = ../arm/izamax.c + +ISAMINKERNEL = ../arm/iamin.c +IDAMINKERNEL = ../arm/iamin.c +ICAMINKERNEL = ../arm/izamin.c +IZAMINKERNEL = ../arm/izamin.c + +ISMAXKERNEL = ../arm/imax.c +IDMAXKERNEL = ../arm/imax.c + +ISMINKERNEL = ../arm/imin.c +IDMINKERNEL = ../arm/imin.c + +SASUMKERNEL = ../arm/asum.c +DASUMKERNEL = ../arm/asum.c +CASUMKERNEL = ../arm/zasum.c +ZASUMKERNEL = ../arm/zasum.c + +SAXPYKERNEL = ../arm/axpy.c +DAXPYKERNEL = ../arm/axpy.c +CAXPYKERNEL = ../arm/zaxpy.c +ZAXPYKERNEL = ../arm/zaxpy.c + +SCOPYKERNEL = ../arm/copy.c +DCOPYKERNEL = ../arm/copy.c +CCOPYKERNEL = ../arm/zcopy.c +ZCOPYKERNEL = ../arm/zcopy.c + +SDOTKERNEL = ../arm/dot.c +DDOTKERNEL = ../arm/dot.c +CDOTKERNEL = ../arm/zdot.c +ZDOTKERNEL = ../arm/zdot.c + +SNRM2KERNEL = ../arm/nrm2.c +DNRM2KERNEL = ../arm/nrm2.c +CNRM2KERNEL = ../arm/znrm2.c +ZNRM2KERNEL = ../arm/znrm2.c + +SROTKERNEL = ../arm/rot.c +DROTKERNEL = ../arm/rot.c +CROTKERNEL = ../arm/zrot.c +ZROTKERNEL = ../arm/zrot.c + +SSCALKERNEL = ../arm/scal.c +DSCALKERNEL = ../arm/scal.c +CSCALKERNEL = ../arm/zscal.c +ZSCALKERNEL = ../arm/zscal.c + +SSWAPKERNEL = ../arm/swap.c +DSWAPKERNEL = ../arm/swap.c +CSWAPKERNEL = ../arm/zswap.c +ZSWAPKERNEL = ../arm/zswap.c + +SGEMVNKERNEL = ../arm/gemv_n.c +DGEMVNKERNEL = ../arm/gemv_n.c +CGEMVNKERNEL = ../arm/zgemv_n.c +ZGEMVNKERNEL = ../arm/zgemv_n.c + +SGEMVTKERNEL = ../arm/gemv_t.c +DGEMVTKERNEL = ../arm/gemv_t.c +CGEMVTKERNEL = ../arm/zgemv_t.c +ZGEMVTKERNEL = ../arm/zgemv_t.c + +STRMMKERNEL = ../generic/trmmkernel_2x2.c +DTRMMKERNEL = ../generic/trmmkernel_2x2.c +CTRMMKERNEL = ../generic/ztrmmkernel_2x2.c +ZTRMMKERNEL = ../generic/ztrmmkernel_2x2.c + +SGEMMKERNEL = ../generic/gemmkernel_2x2.c +SGEMMONCOPY = ../generic/gemm_ncopy_2.c +SGEMMOTCOPY = ../generic/gemm_tcopy_2.c +SGEMMONCOPYOBJ = sgemm_oncopy.o +SGEMMOTCOPYOBJ = sgemm_otcopy.o + +DGEMMKERNEL = ../generic/gemmkernel_2x2.c +DGEMMONCOPY = ../generic/gemm_ncopy_2.c +DGEMMOTCOPY = ../generic/gemm_tcopy_2.c +DGEMMONCOPYOBJ = dgemm_oncopy.o +DGEMMOTCOPYOBJ = dgemm_otcopy.o + +CGEMMKERNEL = ../generic/zgemmkernel_2x2.c +CGEMMONCOPY = ../generic/zgemm_ncopy_2.c +CGEMMOTCOPY = ../generic/zgemm_tcopy_2.c +CGEMMONCOPYOBJ = cgemm_oncopy.o +CGEMMOTCOPYOBJ = cgemm_otcopy.o + +ZGEMMKERNEL = ../generic/zgemmkernel_2x2.c +ZGEMMONCOPY = ../generic/zgemm_ncopy_2.c +ZGEMMOTCOPY = ../generic/zgemm_tcopy_2.c +ZGEMMONCOPYOBJ = zgemm_oncopy.o +ZGEMMOTCOPYOBJ = zgemm_otcopy.o + +STRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +STRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +STRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +STRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +DTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +DTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +DTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +DTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +CTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +CTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +CTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +CTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + +ZTRSMKERNEL_LN = ../generic/trsm_kernel_LN.c +ZTRSMKERNEL_LT = ../generic/trsm_kernel_LT.c +ZTRSMKERNEL_RN = ../generic/trsm_kernel_RN.c +ZTRSMKERNEL_RT = ../generic/trsm_kernel_RT.c + + + diff --git a/kernel/zarch/Makefile b/kernel/zarch/Makefile new file mode 100644 index 0000000000..efae70d7b7 --- /dev/null +++ b/kernel/zarch/Makefile @@ -0,0 +1,2 @@ +clean :: + diff --git a/kernel/zarch/ckernelMacrosV.S b/kernel/zarch/ckernelMacrosV.S new file mode 100644 index 0000000000..87d541002e --- /dev/null +++ b/kernel/zarch/ckernelMacrosV.S @@ -0,0 +1,1484 @@ +/****************************************Implementation**Details**********************************************/ +/* */ +/* Lets denote (a,a1i) complex which is mathematically a+a1*i */ +/* Complex number multiplication: (a,a1i)*(b,b1i) */ +/* As i*i=-1 .The multiplication result will be: */ +/* (a+a1*i)(b+b1*i)=a*b+a1*i*b1*i+ a1*i*b+a*b1*i=a*b-a1*b1 + (a1*b+a*b1)*i which is (ab-a1b1,a1b+ab1) */ +/* so let c= ab-a1b1 , ci=a1b+ab1 then */ +/* c=c+a*b-a1*b1 => c=a*b-( a1*b1-c) => c= a1*b1-c then c=a*b-c two mseb */ +/* ci=ci+a1*b+a*b1 => ci= a1*b+ci then ci= a*b1+ci */ +/* For simd real and imaginary parts will be grouped together */ +/* such (realA,realK) and (imageA ,imageK) */ +/* Simd(0,1)=(a*b,k*b)-((ai*bi,ki*bi)-Simd(0,1)) */ +/* SimdI(0,1)=SimdI(0,1)+(a*bi,k*bi)+(ai*b,ki*b) */ +/* */ +/* */ +/* for defined(NR) || defined(NC) || defined(TR) || defined(TC) */ +/* (a+a1*I)(b-b1*I)=ab+a1*b1+I(a1b-ab1) */ +/* */ +/* c=c+ab+a1b1 => c=a1b1+c;c=ab+c */ +/* ci=ci+a1b-ab1 => ci=a1*b-(ab1-ci) => ci=ab1-ci; ci=a1*b-ci */ +/* */ +/* */ +/* for defined(RN) || defined(RT) || defined(CN) || defined(CT) */ +/* (a-a1*I)(b+b1*I)=ab+a1*b1+I(-a1b+ab1) */ +/* */ +/* c=c+ab+a1b1 => c=a1b1+c;c=ab+c */ +/* ci=ci+a1b-ab1 => ci=a*b1-(a1b-ci) => ci=a1b-ci; ci=a*b1-ci */ +/* */ +/* */ +/* for defined(RR) || defined(RC) || defined(CR) || defined(CC) */ +/* (a-a1*I)(b-b1*I)=ab-a1*b1+I(-a1b-ab1) */ +/* */ +/* c= a1*b1-c then c=a*b-c */ +/* ci = ci-a1*b -a*b1; */ +/* as ibm z13 only has x*z-m x*z+m instructions implementation will be changed a bit */ +/* Assuming ci=0; and cix=cix+a1b+ab1 ; ci=ci-cix will work */ +/* cix= a*b1+cix ; cix= a1*b+cix (two madb) ci=ci-cix (sign change if ci=0) */ +/* As c=0 then */ +/* c=a*b-c then c=a1*b1-c => c=(a1*b1-(a*b-c)) which is -1*( a*b -(a1*b1-c)) */ +/* */ +/* Values will be equal to (-c) and (-ci) */ +/* To change sign it'll be multiplied by -1*(alpha+alpha_i) */ +/* This is done once: */ +/* lcdbr ALPHA_I,ALPHA_I */ +/* lcdbr ALPHA ,ALPHA */ +/*************************************************************************************************************/ + +/*************************Zero vectors***************************************/ +/*zero vectors for 4x4 */ +.macro ZERO_ZCVEC_4x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + vzero %v24 + vzero %v25 + vzero %v26 + vzero %v27 + vzero %v28 + vzero %v29 + vzero %v30 + vzero %v31 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_1x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_4x2 + ZERO_ZCVEC_2x4 +.endm + +.macro ZERO_ZCVEC_4x1 + ZERO_ZCVEC_1x4 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x2 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_1x2 + vzero %v16 + vzero %v17 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x1 + vzero %v16 + vzero %v17 +.endm + +/*zero vectors for 1x1*/ +.macro ZERO_ZCVEC_1x1 + lzer %f6 + lzer %f7 +.endm + + +/* + Calculate for 4x2 inner +*/ +.macro CalcComplex_4x2 vResR1, vResI1, vResR2, vResI2, vResR3, vResI3, vResR4, vResI4, vr1, vi1, vr2, vi2, vrB, viB,vrB2, viB2 + + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + + #endif + +.endm + +/* + Calculate for 2x4 inner +*/ +.macro CalcComplex_2x4 vResR1, vResI1, vResR2, vResI2, vResR3, vResI3, vResR4, vResI4, vr1, vi1, vr2, vi2, vrB, viB,vrB2, viB2 + + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + + #endif + +.endm + +/* + Calculate for 2x2 inner +*/ +.macro CalcComplex_2x2 vResR1, vResI1,vResR2, vResI2, vR1, vI1, vRB, vIB, vRB2, vIB2 + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vI1, \vIB, \vResR1 + vfmadb \vResI1, \vR1, \vIB, \vResI1 + + vfmsdb \vResR2, \vI1, \vIB2, \vResR2 + vfmadb \vResI2, \vR1, \vIB2, \vResI2 + + vfmsdb \vResR1, \vR1, \vRB, \vResR1 + vfmadb \vResI1, \vI1, \vRB, \vResI1 + + vfmsdb \vResR2, \vR1, \vRB2, \vResR2 + vfmadb \vResI2, \vI1, \vRB2, \vResI2 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vI1, \vIB, \vResR1 + vfmsdb \vResI1, \vR1, \vIB, \vResI1 + + vfmadb \vResR2, \vI1, \vIB2, \vResR2 + vfmsdb \vResI2, \vR1, \vIB2, \vResI2 + + vfmadb \vResR1, \vR1, \vRB, \vResR1 + vfmsdb \vResI1, \vI1, \vRB, \vResI1 + + vfmadb \vResR2, \vR1, \vRB2, \vResR2 + vfmsdb \vResI2, \vI1, \vRB2, \vResI2 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vI1, \vIB, \vResR1 + vfmsdb \vResI1, \vI1, \vRB, \vResI1 + + vfmadb \vResR2, \vI1, \vIB2, \vResR2 + vfmsdb \vResI2, \vI1, \vRB2, \vResI2 + + vfmadb \vResR1, \vR1, \vRB, \vResR1 + vfmsdb \vResI1, \vR1, \vIB, \vResI1 + + vfmadb \vResR2, \vR1, \vRB2, \vResR2 + vfmsdb \vResI2, \vR1, \vIB2, \vResI2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vResR1, \vR1, \vRB, \vResR1 + vfmadb \vResI1, \vI1, \vRB, \vResI1 + + vfmsdb \vResR2, \vR1, \vRB2, \vResR2 + vfmadb \vResI2, \vI1, \vRB2, \vResI2 + + vfmsdb \vResR1, \vI1, \vIB, \vResR1 + vfmadb \vResI1, \vR1, \vIB, \vResI1 + + vfmsdb \vResR2, \vI1, \vIB2, \vResR2 + vfmadb \vResI2, \vR1, \vIB2, \vResI2 + #endif +.endm + +/* + Calculate for 2x1 inner +*/ +.macro CalcComplex_2x1 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif +.endm + +/* + Calculate for 1x2 inner +*/ +.macro CalcComplex_1x2 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(RN) || defined(CN) || defined(RT) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(NR) || defined(TR) || defined(NC) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif +.endm + + +/* + Calculate for 4x1 inner +*/ +.macro CalcComplex_4x1 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + +.endm + +/* + Calculate for 1x4 inner +*/ +.macro CalcComplex_1x4 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(RN) || defined(CN) || defined(RT) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(NR) || defined(TR) || defined(NC) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + +.endm + +.macro CalcComplex_1x1 RealResult1, ImageResult1, Real1, Image1, RealB, ImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + msebr \RealResult1, \Image1, \ImageB + maebr \ImageResult1, \Real1, \ImageB + msebr \RealResult1, \Real1, \RealB + maebr \ImageResult1, \Image1, \RealB + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + maebr \RealResult1, \Image1, \ImageB + msebr \ImageResult1, \Real1, \ImageB + maebr \RealResult1, \Real1, \RealB + msebr \ImageResult1, \Image1, \RealB + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + maebr \RealResult1, \Image1, \ImageB + msebr \ImageResult1, \Image1, \RealB + maebr \RealResult1, \Real1, \RealB + msebr \ImageResult1, \Real1, \ImageB + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + msebr \RealResult1, \Real1, \RealB + maebr \ImageResult1, \Image1, \RealB + msebr \RealResult1, \Image1, \ImageB + maebr \ImageResult1, \Real1, \ImageB + #endif +.endm + +#define DISP(ind,stride,disp) (ind*stride+disp) +#define DISP64(ind,disp) (ind*32+disp) +#define DISP32(ind,disp) (ind*16+disp) +#define DISP16(ind,disp) (ind*8+disp) + +#define unit_size 8 +#define DISP(ind,stride,disp) (ind*stride+disp) +#define DISP8(ind,disp) (ind*unit_size*8+disp) +#define DISP4(ind,disp) (ind*unit_size*4+disp) +#define DISP2(ind,disp) (ind*unit_size*2+disp) +#define DISP1(ind,disp) (ind*unit_size+disp) +#define N8 (8*unit_size) +#define N4 (4*unit_size) +#define N2 (2*unit_size) +#define N1 (1*unit_size) + + + +.macro ZCALC_4x4_I PTR_A_REG,PTR_B_REG,Index,IsLast + + vlef %v1, DISP4(\Index ,0) (\PTR_A_REG),0 + vlef %v5, DISP4(\Index ,4) (\PTR_A_REG),0 + vlef %v1, DISP4(\Index ,8) (\PTR_A_REG),2 + vlef %v5, DISP4(\Index ,12) (\PTR_A_REG),2 + vlef %v3, DISP4(\Index ,16) (\PTR_A_REG),0 + vlef %v7, DISP4(\Index ,20) (\PTR_A_REG),0 + vlef %v3, DISP4(\Index ,24) (\PTR_A_REG),2 + vlef %v7, DISP4(\Index ,28) (\PTR_A_REG),2 + vlrepf %v9, DISP4(\Index ,0)(\PTR_B_REG) + vlrepf %v10 , DISP4(\Index ,4)(\PTR_B_REG) + vlrepf %v11, DISP4(\Index ,8)(\PTR_B_REG) + vlrepf %v12 , DISP4(\Index ,12)(\PTR_B_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v3,%v3 + vldeb %v7,%v7 + vldeb %v9,%v9 + vldeb %v10,%v10 + vldeb %v11,%v11 + vldeb %v12,%v12 + + CalcComplex_4x2 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + vlrepf %v9, DISP4(\Index ,16)(\PTR_B_REG) + vlrepf %v10 , DISP4(\Index ,20)(\PTR_B_REG) + vlrepf %v11, DISP4(\Index ,24)(\PTR_B_REG) + vlrepf %v12 , DISP4(\Index ,28)(\PTR_B_REG) + vldeb %v9,%v9 + vldeb %v10,%v10 + vldeb %v11,%v11 + vldeb %v12,%v12 + + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,32)(\PTR_A_REG) + .endif + CalcComplex_4x2 %v24,%v25,%v26,%v27,%v28,%v29,%v30,%v31,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_B_REG, DISP4(\Index ,32)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_4x2_I PTR_A_REG,PTR_B_REG,Index,IsLast + + vlef %v1, DISP4(\Index ,0) (\PTR_A_REG),0 + vlef %v5, DISP4(\Index ,4) (\PTR_A_REG),0 + vlef %v1, DISP4(\Index ,8) (\PTR_A_REG),2 + vlef %v5, DISP4(\Index ,12) (\PTR_A_REG),2 + vlef %v3, DISP4(\Index ,16) (\PTR_A_REG),0 + vlef %v7, DISP4(\Index ,20) (\PTR_A_REG),0 + vlef %v3, DISP4(\Index ,24) (\PTR_A_REG),2 + vlef %v7, DISP4(\Index ,28) (\PTR_A_REG),2 + vlrepf %v9, DISP2(\Index ,0)(\PTR_B_REG) + vlrepf %v10 , DISP2(\Index ,4)(\PTR_B_REG) + vlrepf %v11, DISP2(\Index ,8)(\PTR_B_REG) + vlrepf %v12 , DISP2(\Index ,12)(\PTR_B_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v3,%v3 + vldeb %v7,%v7 + vldeb %v9,%v9 + vldeb %v10,%v10 + vldeb %v11,%v11 + vldeb %v12,%v12 + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,32)(\PTR_A_REG) + .endif + CalcComplex_4x2 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,16)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_2x4_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlef %v1, DISP4(\Index ,0) (\PTR_B_REG),0 + vlef %v5, DISP4(\Index ,4) (\PTR_B_REG),0 + vlef %v1, DISP4(\Index ,8) (\PTR_B_REG),2 + vlef %v5, DISP4(\Index ,12) (\PTR_B_REG),2 + vlef %v3, DISP4(\Index ,16) (\PTR_B_REG),0 + vlef %v7, DISP4(\Index ,20) (\PTR_B_REG),0 + vlef %v3, DISP4(\Index ,24) (\PTR_B_REG),2 + vlef %v7, DISP4(\Index ,28) (\PTR_B_REG),2 + vlrepf %v9, DISP2(\Index ,0)(\PTR_A_REG) + vlrepf %v10 , DISP2(\Index ,4)(\PTR_A_REG) + vlrepf %v11, DISP2(\Index ,8)(\PTR_A_REG) + vlrepf %v12 , DISP2(\Index ,12)(\PTR_A_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v3,%v3 + vldeb %v7,%v7 + vldeb %v9,%v9 + vldeb %v10,%v10 + vldeb %v11,%v11 + vldeb %v12,%v12 + .if \IsLast==1 + la \PTR_B_REG, DISP4(\Index ,32)(\PTR_B_REG) + .endif + CalcComplex_2x4 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_A_REG, DISP2(\Index ,16)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_4x1_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlef %v1, DISP4(\Index ,0) (\PTR_A_REG),0 + vlef %v5, DISP4(\Index ,4) (\PTR_A_REG),0 + vlef %v1, DISP4(\Index ,8) (\PTR_A_REG),2 + vlef %v5, DISP4(\Index ,12) (\PTR_A_REG),2 + vlef %v3, DISP4(\Index ,16) (\PTR_A_REG),0 + vlef %v7, DISP4(\Index ,20) (\PTR_A_REG),0 + vlef %v3, DISP4(\Index ,24) (\PTR_A_REG),2 + vlef %v7, DISP4(\Index ,28) (\PTR_A_REG),2 + vlrepf %v9, DISP1(\Index ,0)(\PTR_B_REG) + vlrepf %v10 , DISP1(\Index ,4)(\PTR_B_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v3,%v3 + vldeb %v7,%v7 + vldeb %v9,%v9 + vldeb %v10,%v10 + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,32)(\PTR_A_REG) + .endif + CalcComplex_4x1 %v16,%v17,%v18,%v19,%v1,%v5,%v3,%v7,%v9,%v10 + + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,8)(\PTR_B_REG) + .endif + +.endm + +.macro ZCALC_1x4_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlef %v1, DISP4(\Index ,0) (\PTR_B_REG),0 + vlef %v5, DISP4(\Index ,4) (\PTR_B_REG),0 + vlef %v1, DISP4(\Index ,8) (\PTR_B_REG),2 + vlef %v5, DISP4(\Index ,12) (\PTR_B_REG),2 + vlef %v3, DISP4(\Index ,16) (\PTR_B_REG),0 + vlef %v7, DISP4(\Index ,20) (\PTR_B_REG),0 + vlef %v3, DISP4(\Index ,24) (\PTR_B_REG),2 + vlef %v7, DISP4(\Index ,28) (\PTR_B_REG),2 + vlrepf %v9, DISP1(\Index ,0)(\PTR_A_REG) + vlrepf %v10 , DISP1(\Index ,4)(\PTR_A_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v3,%v3 + vldeb %v7,%v7 + vldeb %v9,%v9 + vldeb %v10,%v10 + .if \IsLast==1 + la \PTR_B_REG, DISP4(\Index ,32)(\PTR_B_REG) + .endif + CalcComplex_1x4 %v16,%v17,%v18,%v19,%v1,%v5,%v3,%v7,%v9,%v10 + + .if \IsLast==1 + la \PTR_A_REG, DISP1(\Index ,8)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_2x2_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vlef %v1, DISP2(\Index ,0) (\PTR_A_REG),0 + vlef %v5, DISP2(\Index ,4) (\PTR_A_REG),0 + vlef %v1, DISP2(\Index ,8) (\PTR_A_REG),2 + vlef %v5, DISP2(\Index ,12) (\PTR_A_REG),2 + vlrepf %v9, DISP2(\Index ,0)(\PTR_B_REG) + vlrepf %v10 , DISP2(\Index ,4)(\PTR_B_REG) + vlrepf %v11, DISP2(\Index ,8)(\PTR_B_REG) + vlrepf %v12 , DISP2(\Index ,12)(\PTR_B_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v9,%v9 + vldeb %v10,%v10 + vldeb %v11,%v11 + vldeb %v12,%v12 + .if \IsLast==1 + la \PTR_A_REG, DISP2(\Index ,16)(\PTR_A_REG) + .endif + CalcComplex_2x2 %v16,%v17,%v20,%v21,%v1,%v5, %v9,%v10,%v11,%v12 + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,16)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_2x1_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vlef %v1, DISP2(\Index ,0) (\PTR_A_REG),0 + vlef %v5, DISP2(\Index ,4) (\PTR_A_REG),0 + vlef %v1, DISP2(\Index ,8) (\PTR_A_REG),2 + vlef %v5, DISP2(\Index ,12) (\PTR_A_REG),2 + vlrepf %v9, DISP1(\Index ,0)(\PTR_B_REG) + vlrepf %v10 , DISP1(\Index ,4)(\PTR_B_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v9,%v9 + vldeb %v10,%v10 + .if \IsLast==1 + la \PTR_A_REG, DISP2(\Index ,16)(\PTR_A_REG) + .endif + CalcComplex_2x1 %v16,%v17, %v1,%v5, %v9,%v10 + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,8)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_1x2_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vlef %v1, DISP2(\Index ,0) (\PTR_B_REG),0 + vlef %v5, DISP2(\Index ,4) (\PTR_B_REG),0 + vlef %v1, DISP2(\Index ,8) (\PTR_B_REG),2 + vlef %v5, DISP2(\Index ,12) (\PTR_B_REG),2 + vlrepf %v9, DISP1(\Index ,0)(\PTR_A_REG) + vlrepf %v10 , DISP1(\Index ,4)(\PTR_A_REG) + vldeb %v1,%v1 + vldeb %v5,%v5 + vldeb %v9,%v9 + vldeb %v10,%v10 + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,16)(\PTR_B_REG) + .endif + CalcComplex_1x2 %v16,%v17, %v1,%v5, %v9,%v10 + .if \IsLast==1 + la \PTR_A_REG, DISP1(\Index ,8)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_1x1_I PTR_A_REG,PTR_B_REG ,Index,IsLast + le %f1 , DISP1(\Index ,0)(\PTR_A_REG) + le %f3 , DISP1(\Index ,4)(\PTR_A_REG) + le %f4 , DISP1(\Index ,0)(\PTR_B_REG) + le %f5 , DISP1(\Index ,4)(\PTR_B_REG) + .if \IsLast==1 + la \PTR_A_REG, DISP1(\Index ,8)(\PTR_A_REG) + .endif + CalcComplex_1x1 %f6,%f7,%f1,%f3,%f4,%f5 + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,8)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_4x4 PTR_A_REG,PTR_B_REG + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_4x2 PTR_A_REG,PTR_B_REG + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_4x1 PTR_A_REG,PTR_B_REG + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_4x4_4 PTR_A_REG,PTR_B_REG + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm +.macro ZCALC_4x2_4 PTR_A_REG,PTR_B_REG + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm +.macro ZCALC_4x1_4 PTR_A_REG,PTR_B_REG + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x4_4 PTR_A_REG,PTR_B_REG + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x4 PTR_A_REG,PTR_B_REG + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_1x4_4 PTR_A_REG,PTR_B_REG + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x4 PTR_A_REG,PTR_B_REG + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_2x2 PTR_A_REG,PTR_B_REG + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_2x2_4 PTR_A_REG,PTR_B_REG + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x1 PTR_A_REG,PTR_B_REG + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_2x1_4 PTR_A_REG,PTR_B_REG + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + + +.macro ZCALC_1x2_4 PTR_A_REG,PTR_B_REG + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x2 PTR_A_REG,PTR_B_REG + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_1x1_4 PTR_A_REG,PTR_B_REG + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x1 PTR_A_REG,PTR_B_REG + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + + + +/*****************************STORE RESULTS************************************/ +.macro CalcMultAlpha_4x1 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined (TRMMKERNEL) + vfmdb \vRealResult1, \vImage1, \vecImageB + vfmdb \vImageResult1, \vReal1, \vecImageB + vfmdb \vRealResult2, \vImage2, \vecImageB + vfmdb \vImageResult2, \vReal2, \vecImageB + #else + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 +#endif + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + +.endm + +.macro CalcMultAlpha_2x1 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined (TRMMKERNEL) + vfmdb \vRealResult1, \vImage1, \vecImageB + vfmdb \vImageResult1, \vReal1, \vecImageB +#else + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 +#endif + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 +.endm + +.macro CalcMultAlpha_1x1 RealResult1, ImageResult1, Real1, Image1, RealB, ImageB + + msebr \RealResult1, \Image1, \ImageB + maebr \ImageResult1, \Real1, \ImageB + msebr \RealResult1, \Real1, \RealB + maebr \ImageResult1, \Image1, \RealB +.endm + +.macro ZSTORE_4x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL ,LC1,LC2 + #if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 8(\CIJ_REG),2 + vlef %v4, 12(\CIJ_REG),2 + vlef %v5, 16(\CIJ_REG),0 + vlef %v6, 20(\CIJ_REG),0 + vlef %v5, 24(\CIJ_REG),2 + vlef %v6, 28(\CIJ_REG),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#endif + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 8(\CIJ_REG),2 + vstef %v4, 12(\CIJ_REG),2 + vstef %v5, 16(\CIJ_REG),0 + vstef %v6, 20(\CIJ_REG),0 + vstef %v5, 24(\CIJ_REG),2 + vstef %v6, 28(\CIJ_REG),2 + + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + + #if !defined(TRMMKERNEL) + vlef %v16, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v17, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v16, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v17, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v18, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v19, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v18, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v19, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vldeb %v16,%v16 + vldeb %v17,%v17 + vldeb %v18,%v18 + vldeb %v19,%v19 +#endif + CalcMultAlpha_4x1 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI + vledb %v16, %v16,0,0 + vledb %v17, %v17,0,0 + vledb %v18, %v18,0,0 + vledb %v19, %v19,0,0 + vstef %v16, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v17, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v16, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v17, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v18, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v19, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v18, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v19, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + +#if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG, \LC1),0 + vlef %v4, 4(\CIJ_REG, \LC1),0 + vlef %v3, 8(\CIJ_REG, \LC1),2 + vlef %v4, 12(\CIJ_REG, \LC1),2 + vlef %v5, 16(\CIJ_REG, \LC1),0 + vlef %v6, 20(\CIJ_REG, \LC1),0 + vlef %v5, 24(\CIJ_REG, \LC1),2 + vlef %v6, 28(\CIJ_REG, \LC1),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v24,%v25,%v26,%v27,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG,\LC1),0 + vstef %v4, 4(\CIJ_REG,\LC1),0 + vstef %v3, 8(\CIJ_REG,\LC1),2 + vstef %v4, 12(\CIJ_REG,\LC1),2 + vstef %v5, 16(\CIJ_REG,\LC1),0 + vstef %v6, 20(\CIJ_REG,\LC1),0 + vstef %v5, 24(\CIJ_REG,\LC1),2 + vstef %v6, 28(\CIJ_REG,\LC1),2 + + #if !defined(TRMMKERNEL) + vlef %v16, 0(\CIJ_REG,\LC2),0 + vlef %v17, 4(\CIJ_REG,\LC2),0 + vlef %v16, 8(\CIJ_REG,\LC2),2 + vlef %v17, 12(\CIJ_REG,\LC2),2 + vlef %v18, 16(\CIJ_REG,\LC2),0 + vlef %v19, 20(\CIJ_REG,\LC2),0 + vlef %v18, 24(\CIJ_REG,\LC2),2 + vlef %v19, 28(\CIJ_REG,\LC2),2 + vldeb %v16,%v16 + vldeb %v17,%v17 + vldeb %v18,%v18 + vldeb %v19,%v19 +#endif + CalcMultAlpha_4x1 %v16,%v17,%v18,%v19,%v28,%v29,%v30,%v31,\ALPHA_VECREG,\ALPHA_VECI + vledb %v16, %v16,0,0 + vledb %v17, %v17,0,0 + vledb %v18, %v18,0,0 + vledb %v19, %v19,0,0 + vstef %v16, 0(\CIJ_REG,\LC2),0 + vstef %v17, 4(\CIJ_REG,\LC2),0 + vstef %v16, 8(\CIJ_REG,\LC2),2 + vstef %v17, 12(\CIJ_REG,\LC2),2 + vstef %v18, 16(\CIJ_REG,\LC2),0 + vstef %v19, 20(\CIJ_REG,\LC2),0 + vstef %v18, 24(\CIJ_REG,\LC2),2 + vstef %v19, 28(\CIJ_REG,\LC2),2 + + la \CIJ_REG,32(\CIJ_REG) +.endm + +.macro ZSTORE_4x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 8(\CIJ_REG),2 + vlef %v4, 12(\CIJ_REG),2 + vlef %v5, 16(\CIJ_REG),0 + vlef %v6, 20(\CIJ_REG),0 + vlef %v5, 24(\CIJ_REG),2 + vlef %v6, 28(\CIJ_REG),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 8(\CIJ_REG),2 + vstef %v4, 12(\CIJ_REG),2 + vstef %v5, 16(\CIJ_REG),0 + vstef %v6, 20(\CIJ_REG),0 + vstef %v5, 24(\CIJ_REG),2 + vstef %v6, 28(\CIJ_REG),2 + + #if !defined(TRMMKERNEL) + vlef %v16, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v17, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v16, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v17, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v18, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v19, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v18, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v19, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vldeb %v16,%v16 + vldeb %v17,%v17 + vldeb %v18,%v18 + vldeb %v19,%v19 +#endif + CalcMultAlpha_4x1 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI + vledb %v16, %v16,0,0 + vledb %v17, %v17,0,0 + vledb %v18, %v18,0,0 + vledb %v19, %v19,0,0 + vstef %v16, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v17, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v16, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v17, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v18, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v19, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v18, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v19, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + + la \CIJ_REG,32(\CIJ_REG) +.endm +.macro ZSTORE_4x1 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 8(\CIJ_REG),2 + vlef %v4, 12(\CIJ_REG),2 + vlef %v5, 16(\CIJ_REG),0 + vlef %v6, 20(\CIJ_REG),0 + vlef %v5, 24(\CIJ_REG),2 + vlef %v6, 28(\CIJ_REG),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 8(\CIJ_REG),2 + vstef %v4, 12(\CIJ_REG),2 + vstef %v5, 16(\CIJ_REG),0 + vstef %v6, 20(\CIJ_REG),0 + vstef %v5, 24(\CIJ_REG),2 + vstef %v6, 28(\CIJ_REG),2 + la \CIJ_REG,32(\CIJ_REG) +.endm + +.macro ZSTORE_1x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL,LC1,LC2 + #if !defined(TRMMKERNEL) + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + vlef %v5, 0(\CIJ_REG,\LC1),0 + vlef %v6, 4(\CIJ_REG,\LC1),0 + vlef %v5, 0(\CIJ_REG,\LC2),2 + vlef %v6, 4(\CIJ_REG,\LC2),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#else + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#endif + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI +#if defined(TRMMKERNEL) + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) +#endif + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v5, 0(\CIJ_REG,\LC1),0 + vstef %v6, 4(\CIJ_REG,\LC1),0 + vstef %v5, 0(\CIJ_REG,\LC2),2 + vstef %v6, 4(\CIJ_REG,\LC2),2 + la \CIJ_REG,8(\CIJ_REG) +.endm +.macro ZSTORE_2x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL,LC1,LC2 + #if !defined(TRMMKERNEL) + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v24, 8(\CIJ_REG),0 + vlef %v25, 12(\CIJ_REG),0 + vlef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v24, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v25, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + vlef %v5, 0(\CIJ_REG,\LC1),0 + vlef %v6, 4(\CIJ_REG,\LC1),0 + vlef %v26, 8(\CIJ_REG,\LC1),0 + vlef %v27, 12(\CIJ_REG,\LC1),0 + vlef %v5, 0(\CIJ_REG,\LC2),2 + vlef %v6, 4(\CIJ_REG,\LC2),2 + vlef %v26, 8(\CIJ_REG,\LC2),2 + vlef %v27, 12(\CIJ_REG,\LC2),2 + + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 + vldeb %v24,%v24 + vldeb %v25,%v25 + vldeb %v26,%v26 + vldeb %v27,%v27 +#else + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#endif + CalcMultAlpha_4x1 %v3,%v4,%v5,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + CalcMultAlpha_4x1 %v24,%v25,%v26,%v27,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI +#if defined(TRMMKERNEL) + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) +#endif + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vledb %v24, %v24,0,0 + vledb %v25, %v25,0,0 + vledb %v26, %v26,0,0 + vledb %v27, %v27,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v24, 8(\CIJ_REG),0 + vstef %v25, 12(\CIJ_REG),0 + vstef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v24, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v25, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v5, 0(\CIJ_REG,\LC1),0 + vstef %v6, 4(\CIJ_REG,\LC1),0 + vstef %v26, 8(\CIJ_REG,\LC1),0 + vstef %v27, 12(\CIJ_REG,\LC1),0 + vstef %v5, 0(\CIJ_REG,\LC2),2 + vstef %v6, 4(\CIJ_REG,\LC2),2 + vstef %v26, 8(\CIJ_REG,\LC2),2 + vstef %v27, 12(\CIJ_REG,\LC2),2 + + la \CIJ_REG,16(\CIJ_REG) + +.endm + +.macro ZSTORE_2x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL +#if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 8(\CIJ_REG),2 + vlef %v4, 12(\CIJ_REG),2 + vlef %v5, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v6, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vlef %v5, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v6, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + vldeb %v5,%v5 + vldeb %v6,%v6 +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + CalcMultAlpha_2x1 %v5,%v6, %v20,%v21 ,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vledb %v6, %v6,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 8(\CIJ_REG),2 + vstef %v4, 12(\CIJ_REG),2 + vstef %v5, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v6, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v5, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v6, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + la \CIJ_REG,16(\CIJ_REG) +.endm + +.macro ZSTORE_2x1 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL +#if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 8(\CIJ_REG),2 + vlef %v4, 12(\CIJ_REG),2 + vldeb %v3,%v3 + vldeb %v4,%v4 +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 8(\CIJ_REG),2 + vstef %v4, 12(\CIJ_REG),2 + la \CIJ_REG,16(\CIJ_REG) +.endm + +.macro ZSTORE_1x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vlef %v3, 0(\CIJ_REG),0 + vlef %v4, 4(\CIJ_REG),0 + vlef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vlef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vldeb %v3,%v3 + vldeb %v4,%v4 + +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vstef %v3, 0(\CIJ_REG),0 + vstef %v4, 4(\CIJ_REG),0 + vstef %v3, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v4, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + la \CIJ_REG,8(\CIJ_REG) +.endm + +.macro ZSTORE_1x1 ALPHA_RR,ALPHA_RI ,CIJ_REG +#if defined (TRMMKERNEL) + lzer %f1 + lzer %f3 +#else + le %f1 , 0(\CIJ_REG) + le %f3 , 4(\CIJ_REG ) +#endif + ledbr %f4,\ALPHA_RR + ledbr %f5,\ALPHA_RI + CalcMultAlpha_1x1 %f1,%f3, %f6,%f7,%f4,%f5 + ste %f1,0(\CIJ_REG) + ste %f3,4(\CIJ_REG) + la \CIJ_REG,8(\CIJ_REG) +.endm + +/****************************TRMM POINTER REFRESH MACROSES*************************/ + +.macro RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B + #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /* ptrbb = bb;*/ + lgr \PTR_B,\B_VAL /*refresh BPOINT*/ + + #else + /* ptrba =ptrba+ off*C_A; + ptrbb = bb + off*C_B;*/ +.if \C_B==4 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_B, \PTR_B + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,5 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==2 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_B,\PTR_B /* off+off**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==1 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,3 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif +.endif + + #endif +.endm + +/**/ +.macro RefreshTempBk TEMP_VAL,BK_VAL,OFF_VAL,INCR_A,INCR_B + #if (defined(LEFT) && !defined(TRANSA)) || (!defined(LEFT) && defined(TRANSA)) + /* temp = bk-off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + + #elif defined(LEFT) + /* temp = off+INCR_A; // number of values in A */ + la \TEMP_VAL,\INCR_A(\OFF_VAL) + #else + /* temp = off+INCR_B // number of values in B*/ + la \TEMP_VAL,\INCR_B(\OFF_VAL) + #endif + +.endm + +.macro RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,PTR_A,C_A,C_B + + #if ( defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /*temp = bk - off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + #ifdef LEFT + /*temp -= 8; // number of values in A*/ + lay \TEMP_VAL,-\C_A(\TEMP_VAL) + #else + /*temp -= 4; // number of values in B*/ + lay \TEMP_VAL,-\C_B(\TEMP_VAL) + #endif + /*ptrba += temp*C_A; + ptrbb += temp*C_B;*/ + + .if \C_A==4 + sllg \TEMP_VAL, \TEMP_VAL,5 /*temp*4*/ + .elseif \C_A==2 + sllg \TEMP_VAL, \TEMP_VAL,4 /*temp*2*/ + .elseif \C_A==1 + sllg \TEMP_VAL, \TEMP_VAL,3 /*temp*1*/ + .endif + la \PTR_A,0(\PTR_A,\TEMP_VAL) /*ptrba+temp*C_A*/ + #endif + + #ifdef LEFT + /*off += \c_A; // number of values in A*/ + aghi \OFF_VAL,\C_A + #endif +.endm + diff --git a/kernel/zarch/ctrmm4x4V.S b/kernel/zarch/ctrmm4x4V.S new file mode 100644 index 0000000000..c0e4df17d1 --- /dev/null +++ b/kernel/zarch/ctrmm4x4V.S @@ -0,0 +1,733 @@ +/*************************************************************************** +Copyright (c) 2013-2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +/************************************************************************************** +* 2017/03/12 AbdelRauf (quickwritereader@gmail.com) +* BLASTEST : passed +* CTEST : passed +* TEST : passed +**************************************************************************************/ + +/*********************************************************************/ +/* Copyright 2009, 2010 The University of Texas at Austin. */ +/* All rights reserved. */ +/* */ +/* Redistribution and use in source and binary forms, with or */ +/* without modification, are permitted provided that the following */ +/* conditions are met: */ +/* */ +/* 1. Redistributions of source code must retain the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer. */ +/* */ +/* 2. Redistributions in binary form must reproduce the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer in the documentation and/or other materials */ +/* provided with the distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, */ +/* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF */ +/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE */ +/* DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ +/* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES */ +/* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE */ +/* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR */ +/* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF */ +/* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT */ +/* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ +/* POSSIBILITY OF SUCH DAMAGE. */ +/* */ +/* The views and conclusions contained in the software and */ +/* documentation are those of the authors and should not be */ +/* interpreted as representing official policies, either expressed */ +/* or implied, of The University of Texas at Austin. */ +/*********************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* + + +BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alphar,FLOAT alphai,FLOAT* ba,FLOAT* bb, + FLOAT* C,BLASLONG ldc, BLASLONG offset) + ##bm=r2,bn=r3, bk=r4, alpha=f0,aplhai=f2, ba=r5,bb=r6,stack[160] ,ldc=stack[168] +offset=stack[176] + +**********************************************************************************************/ +/*Note: r0 can not be used as address disp register */ + +#define BM %r2 +#define BM_CUR %r0 +#define BN %r3 +#define BN_CUR %r10 +#define BK %r4 +#define LDC_BYTE %r8 +#define ALPHA %f0 +#define ALPHA_I %f2 +#define ALPHA_VECT %v0 +#define ALPHA_VECT_I %v2 +#define LOCAL_VAR1 %r9 +#define LOCAL_VAR2 %r1 +#define LOCAL_VAR3 %r11 +#define A %r5 +#define B %r6 +#define CIJ %r7 +#define CIJ_LOCAL %r12 +#define OFF %r13 +#define OFFSET %f8 +#define ALIGN_4 .align 32 +#define ALIGN_2 .align 16 +#define PREFETCH_INS 1 + +/**************************Include kernel helper macrosses**********************************/ +#include "ckernelMacrosV.S" + + + +/***********************************CGEMM**4x4*******************************************************/ + +PROLOGUE +#if defined(TRMMKERNEL) + std OFFSET ,40(%r15) + stmg %r6,%r13,48(%r15) +#else + stmg %r6,%r12,48(%r15) +#endif +std %f9, 128(%r15) +std %f10,136(%r15) +std %f11,144(%r15) +std %f12,152(%r15) + +lg CIJ, 160(%r15) +lg LOCAL_VAR1, 168(%r15) +#if defined(TRMMKERNEL) + lg OFF,176(%r15) + ldgr OFFSET ,OFF +#endif +srlg BN_CUR,BN,2 +#if defined(RR) || defined(RC) || defined(CR) || defined(CC) + lcdbr ALPHA_I,ALPHA_I + lcdbr ALPHA ,ALPHA +#endif + +vrepg ALPHA_VECT,ALPHA_VECT,0 /*replicate alpha which in f0*/ + +sllg LDC_BYTE, LOCAL_VAR1,3 /*calculate lcd stride with complex=8 x<<4 */ +vrepg ALPHA_VECT_I,ALPHA_VECT_I,0 /*replicate alpha which in f0*/ + +vldeb ALPHA_VECT,ALPHA_VECT +vldeb ALPHA_VECT_I,ALPHA_VECT_I +#if defined(TRMMKERNEL) && !defined(LEFT) + /*off = -offset;*/ + lgdr LOCAL_VAR1,OFFSET + lcgr OFF,LOCAL_VAR1 +#endif +cijle BN_CUR,0,.LX2 + +ALIGN_4 +.LX4_BN: +#if defined(PREFETCH_INS) + pfd 1, 0(A) + pfd 1, 0(B) +#endif +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x4 + +ALIGN_4 +.L4x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x4 +cijle LOCAL_VAR1,0,.L4x4_mod + +ALIGN_4 +.L4x4_4_BK: /*BK_CUR LOOP */ + ZCALC_4x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 128(LOCAL_VAR3) /*256-128*/ + pfd 1, 128(LOCAL_VAR2 ) +#endif +brctg LOCAL_VAR1,.L4x4_4_BK + +ALIGN_4 +.L4x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + nill LOCAL_VAR1,3 +#else + la LOCAL_VAR1,3(0,0) + NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x4_BK_Store + +ALIGN_4 +.L4x4_BK: /*BK_CUR LOOP */ + ZCALC_4x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_BK + +ALIGN_4 +.L4x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,4 +#endif + +brctg BM_CUR,.L4x4_BM + +ALIGN_2 +.L2x4: + +tmll BM,2 +jz .L1x4 + +ALIGN_4 +.L2x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x4 +cijle LOCAL_VAR1,0,.L2x4_mod + +ALIGN_4 +.L2x4_4_BK: /*BK_CUR LOOP */ + ZCALC_2x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 128(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L2x4_4_BK + +ALIGN_4 +.L2x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x4_BK_Store + +ALIGN_4 +.L2x4_BK: /*BK_CUR LOOP */ + ZCALC_2x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_BK + +ALIGN_4 +.L2x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE ,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,4 +#endif + +ALIGN_4 +.L1x4: + +tmll BM,1 +jz .Lx4_INNER_END + +ALIGN_4 +.L1x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x4 +cijle LOCAL_VAR1,0,.L1x4_mod + +ALIGN_4 +.L1x4_4_BK: /*BK_CUR LOOP */ + ZCALC_1x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_4_BK + +ALIGN_4 +.L1x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x4_BK_Store + +ALIGN_4 +.L1x4_BK: /*BK_CUR LOOP */ + ZCALC_1x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_BK + +ALIGN_4 +.L1x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_1x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,4 +#endif +ALIGN_2 +.Lx4_INNER_END: + + +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR1,LDC_BYTE,2 /*multiply*4 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,4 +#endif +sllg LOCAL_VAR2,BK,5 /*multiply*4*sizeof(complex) =multiply*4*8* 2**5 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(complex) */ + +brctg BN_CUR,.LX4_BN + +/*********************************X2 SECTION************************************************/ +ALIGN_4 +.LX2: +tmll BN,2 +jz .Lx1 + +ALIGN_4 +.Lx2_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif + +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x2 + +ALIGN_4 +.L4x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x2 +cijle LOCAL_VAR1,0,.L4x2_mod + +ALIGN_4 +.L4x2_4_BK: /*BK_CUR LOOP */ + ZCALC_4x2_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 128(LOCAL_VAR3) +#endif +brctg LOCAL_VAR1,.L4x2_4_BK + +ALIGN_4 +.L4x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x2_BK_Store + +ALIGN_4 +.L4x2_BK: /*BK_CUR LOOP */ + ZCALC_4x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_BK + +ALIGN_4 +.L4x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,2 +#endif +ALIGN_4 +brctg BM_CUR,.L4x2_BM + +ALIGN_2 +.L2x2: + +tmll BM,2 +jz .L1x2 + +ALIGN_4 +.L2x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x2 +cijle LOCAL_VAR1,0,.L2x2_mod + +ALIGN_4 +.L2x2_4_BK: /*BK_CUR LOOP */ + ZCALC_2x2_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) + pfd 1, 256(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L2x2_4_BK + +ALIGN_4 +.L2x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x2_BK_Store + +ALIGN_4 +.L2x2_BK: /*BK_CUR LOOP */ + ZCALC_2x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_BK + +ALIGN_4 +.L2x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,2 +#endif + +ALIGN_2 +.L1x2: + +tmll BM,1 +jz .Lx2_INNER_END + +ALIGN_4 +.L1x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x2 +cijle LOCAL_VAR1,0,.L1x2_mod + +ALIGN_4 +.L1x2_4_BK: /*BK_CUR LOOP */ + ZCALC_1x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_4_BK + +ALIGN_4 +.L1x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x2_BK_Store + +ALIGN_4 +.L1x2_BK: /*BK_CUR LOOP */ + ZCALC_1x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_BK + +ALIGN_4 +.L1x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_1x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,2 +#endif +ALIGN_2 +.Lx2_INNER_END: +/*add LDC_BYTE_COPY to new*/ +la LOCAL_VAR1,0(LDC_BYTE,LDC_BYTE) /*multiply*2 */ +sllg LOCAL_VAR2,BK,4 /*multiply*2*sizeof(complex) =multiply*2*8 2^4 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*2*/ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,2 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*2*sizeof(complex) */ + + + + +/*********************************X1 SECTION************************************************/ +ALIGN_2 +.Lx1: +tmll BN,1 +jz .L_FUNC_END + +ALIGN_4 +.Lx1_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x1 + +ALIGN_4 +.L4x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x1 +cijle LOCAL_VAR1,0,.L4x1_mod + +ALIGN_4 +.L4x1_4_BK: /*BK_CUR LOOP */ + ZCALC_4x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_4_BK + +ALIGN_4 +.L4x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x1_BK_Store + +ALIGN_4 +.L4x1_BK: /*BK_CUR LOOP */ + ZCALC_4x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_BK + +ALIGN_4 +.L4x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x1 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,1 +#endif +ALIGN_4 +brctg BM_CUR , .L4x1_BM + +ALIGN_2 +.L2x1: + +tmll BM,2 +jz .L1x1 + +ALIGN_4 +.L2x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x1 +cijle LOCAL_VAR1,0,.L2x1_mod + +ALIGN_4 +.L2x1_4_BK: /*BK_CUR LOOP */ + ZCALC_2x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_4_BK + +ALIGN_4 +.L2x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x1_BK_Store + +ALIGN_4 +.L2x1_BK: /*BK_CUR LOOP */ + ZCALC_2x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_BK + +ALIGN_4 +.L2x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x1 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,1 +#endif + +ALIGN_2 +.L1x1: + +tmll BM, 1 +jz .Lx1_INNER_END + +ALIGN_4 +.L1x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x1 +cijle LOCAL_VAR1,0,.L1x1_mod + +ALIGN_4 +.L1x1_4_BK: /*BK_CUR LOOP */ + ZCALC_1x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_4_BK + +ALIGN_4 +.L1x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x1_BK_Store + +ALIGN_4 +.L1x1_BK: /*BK_CUR LOOP */ + ZCALC_1x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_BK + +ALIGN_4 +.L1x1_BK_Store: +/*store C and use CIJ_COPY for mem storing*/ +ZSTORE_1x1 ALPHA,ALPHA_I ,CIJ_LOCAL +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,1 +#endif +ALIGN_2 +.Lx1_INNER_END: +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR2,BK,3 /*multiply*1*sizeof(complex) =multiply*1*8* 2^3 */ +la CIJ,0(CIJ,LDC_BYTE) /*refresh CIJ=CIJ+LDC_BYTE */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,1 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*1*sizeof(complex) */ + + +ALIGN_2 +.L_FUNC_END: +/*end*/ + + +#if defined(TRMMKERNEL) +ld OFFSET,40(%r15) +lmg %r6,%r13,48(%r15) +#else +lmg %r6,%r12,48(%r15) +#endif +ld %f9, 128(%r15) +ld %f10,136(%r15) +ld %f11,144(%r15) +ld %f12,152(%r15) +br %r14 +.end + + + + + + + + + + + + + + + + diff --git a/kernel/zarch/gemm8x4V.S b/kernel/zarch/gemm8x4V.S new file mode 100644 index 0000000000..27fd5f57b5 --- /dev/null +++ b/kernel/zarch/gemm8x4V.S @@ -0,0 +1,611 @@ +/*************************************************************************** +Copyright (c) 2013-2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +/************************************************************************************** +* 2017/01/01 AbdelRauf (quickwritereader@gmail.com) +* BLASTEST : OK +* CTEST : OK +* TEST : OK +**************************************************************************************/ + +/*********************************************************************/ +/* Copyright 2009, 2010 The University of Texas at Austin. */ +/* All rights reserved. */ +/* */ +/* Redistribution and use in source and binary forms, with or */ +/* without modification, are permitted provided that the following */ +/* conditions are met: */ +/* */ +/* 1. Redistributions of source code must retain the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer. */ +/* */ +/* 2. Redistributions in binary form must reproduce the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer in the documentation and/or other materials */ +/* provided with the distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, */ +/* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF */ +/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE */ +/* DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ +/* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES */ +/* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE */ +/* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR */ +/* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF */ +/* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT */ +/* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ +/* POSSIBILITY OF SUCH DAMAGE. */ +/* */ +/* The views and conclusions contained in the software and */ +/* documentation are those of the authors and should not be */ +/* interpreted as representing official policies, either expressed */ +/* or implied, of The University of Texas at Austin. */ +/*********************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* + +#BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc + ##bm=r2,bn=r3, bk=r4, alpha=f0,ba=r5,bb=r6,stack[160] ,ldc=stack[168] +**********************************************************************************************/ +/*Note: r0 can not be used as address disp register */ + +#define BM %r2 +#define BM_CUR %r0 +#define BN %r3 +#define BN_CUR %r10 +#define BK %r4 +#define LDC_BYTE %r8 +#define ALPHA %f0 +#define ALPHA_VECT %v0 +#define LOCAL_VAR1 %r9 +#define LOCAL_VAR2 %r1 +#define LOCAL_VAR3 %r11 +#define A %r5 +#define B %r6 +#define CIJ %r7 +#define CIJ_LOCAL %r12 +#define ALIGN_4 .align 16 +#define ALIGN_2 .align 8 +#define PREFETCH_INS 1 + +#include "kernelMacros.S" + +/***********************************DGEMM***********************************************************/ + +PROLOGUE + +stmg %r6,%r12,48(%r15) +lg CIJ, 160(%r15) +lg LOCAL_VAR1, 168(%r15) +srlg BN_CUR,BN,2 +vrepg ALPHA_VECT,ALPHA_VECT,0 /*replicate alpha which in f0*/ +sllg LDC_BYTE, LOCAL_VAR1,3 /*calculate lcd stride with bytes double=8 x<<3 */ +cijle BN_CUR,0,.LX2 + +ALIGN_4 +.LX4_BN: +#if defined(PREFETCH_INS) + pfd 1, 0(A) + pfd 1, 256(A) + pfd 1, 0(B) + pfd 1, 256(B) +#endif +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x4 + +ALIGN_4 +.L8x4_BM: /*BM_CUR LOOP */ + +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_8x4 +cijle LOCAL_VAR1,0,.L8x4_mod + +ALIGN_4 +.L8x4_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 512(LOCAL_VAR3) +#endif + CALC_8x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 512(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L8x4_4_BK + +ALIGN_4 +.L8x4_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L8x4_BK_Store + +ALIGN_4 +.L8x4_BK: /*BK_CUR LOOP */ + CALC_8x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x4_BK + +ALIGN_4 +.L8x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x4 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE + +brctg BM_CUR,.L8x4_BM + +ALIGN_4 +.L4x4: + +tmll BM,4 +jz .L2x4 + +ALIGN_4 +.L4x4_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_4x4 +cijle LOCAL_VAR1,0,.L4x4_mod + +ALIGN_4 +.L4x4_4_BK: /*BK_CUR LOOP */ + CALC_4x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_4_BK + +ALIGN_4 +.L4x4_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L4x4_BK_Store + +ALIGN_4 +.L4x4_BK: /*BK_CUR LOOP */ + CALC_4x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_BK + +ALIGN_4 +.L4x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.L2x4: + +tmll BM,2 +jz .L1x4 + +ALIGN_4 +.L2x4_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_2x4 +cijle LOCAL_VAR1,0,.L2x4_mod + +ALIGN_4 +.L2x4_4_BK: /*BK_CUR LOOP */ + CALC_2x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_4_BK + +ALIGN_4 +.L2x4_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L2x4_BK_Store + +ALIGN_4 +.L2x4_BK: /*BK_CUR LOOP */ + CALC_2x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_BK + +ALIGN_4 +.L2x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + + +ALIGN_4 +.L1x4: + +tmll BM,1 +jz .Lx4_INNER_END + +ALIGN_4 +.L1x4_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_1x4 +cijle LOCAL_VAR1,0,.L1x4_mod + +ALIGN_4 +.L1x4_4_BK: /*BK_CUR LOOP */ + CALC_1x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_4_BK + +ALIGN_4 +.L1x4_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L1x4_BK_Store + +ALIGN_4 +.L1x4_BK: /*BK_CUR LOOP */ + CALC_1x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_BK + +ALIGN_4 +.L1x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.Lx4_INNER_END: + +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR1,LDC_BYTE,2 /*multiply*4 */ +sllg LOCAL_VAR2,BK,5 /*muyliply*4*sizeof(double) =multiply*32* 2**5 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(double) */ + +brctg BN_CUR,.LX4_BN + +/*********************************X2 SECTION************************************************/ +ALIGN_4 +.LX2: +tmll BN,2 +jz .Lx1 + +ALIGN_4 +.Lx2_BN: +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x2 + + +ALIGN_4 +.L8x2_BM: /*BM_CUR LOOP */ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_8x2 +cijle LOCAL_VAR1,0,.L8x2_mod + +ALIGN_4 +.L8x2_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) + pfd 1,64(LOCAL_VAR2) +#endif + CALC_8x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_4_BK + +ALIGN_4 +.L8x2_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L8x2_BK_Store + +ALIGN_4 +.L8x2_BK: /*BK_CUR LOOP */ + CALC_8x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_BK + +ALIGN_4 +.L8x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x2 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE + +ALIGN_4 +brctg BM_CUR,.L8x2_BM + +ALIGN_2 +.L4x2: + +tmll BM,4 +jz .L2x2 + +ALIGN_4 +.L4x2_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_4x2 +cijle LOCAL_VAR1,0,.L4x2_mod + +ALIGN_4 +.L4x2_4_BK: /*BK_CUR LOOP */ + CALC_4x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_4_BK + +ALIGN_4 +.L4x2_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L4x2_BK_Store + +ALIGN_4 +.L4x2_BK: /*BK_CUR LOOP */ + CALC_4x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_BK + +ALIGN_4 +.L4x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.L2x2: + +tmll BM,2 +jz .L1x2 + +ALIGN_4 +.L2x2_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_2x2 +cijle LOCAL_VAR1,0,.L2x2_mod + +ALIGN_4 +.L2x2_4_BK: /*BK_CUR LOOP */ + CALC_2x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_4_BK + +ALIGN_4 +.L2x2_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L2x2_BK_Store + +ALIGN_4 +.L2x2_BK: /*BK_CUR LOOP */ + CALC_2x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_BK + +ALIGN_4 +.L2x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + + +ALIGN_2 +.L1x2: + +tmll BM,1 +jz .Lx2_INNER_END + +ALIGN_4 +.L1x2_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_1x2 +cijle LOCAL_VAR1,0,.L1x2_mod + +ALIGN_4 +.L1x2_4_BK: /*BK_CUR LOOP */ + CALC_1x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_4_BK + +ALIGN_4 +.L1x2_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L1x2_BK_Store + +ALIGN_4 +.L1x2_BK: /*BK_CUR LOOP */ + CALC_1x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_BK + +ALIGN_4 +.L1x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.Lx2_INNER_END: +/*add LDC_BYTE_COPY to new*/ +la LOCAL_VAR1,0(LDC_BYTE,LDC_BYTE) /*multiply*2 */ +sllg LOCAL_VAR2,BK,4 /*muyliply*2*sizeof(double) =multiply*16* 2**4 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(double) */ + + + + +/*********************************X1 SECTION************************************************/ +ALIGN_2 +.Lx1: +tmll BN,1 +jz .L_FUNC_END + +ALIGN_4 +.Lx1_BN: +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x1 + + +ALIGN_4 +.L8x1_BM: /*BM_CUR LOOP */ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_8x1 +cijle LOCAL_VAR1,0,.L8x1_mod + +ALIGN_4 +.L8x1_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + CALC_8x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_4_BK + +ALIGN_4 +.L8x1_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L8x1_BK_Store + +ALIGN_4 +.L8x1_BK: /*BK_CUR LOOP */ + CALC_8x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_BK + +ALIGN_4 +.L8x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x1 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE + +ALIGN_4 +brctg BM_CUR,.L8x1_BM + +ALIGN_2 +.L4x1: + +tmll BM,4 +jz .L2x1 + +ALIGN_4 +.L4x1_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_4x1 +cijle LOCAL_VAR1,0,.L4x1_mod + +ALIGN_4 +.L4x1_4_BK: /*BK_CUR LOOP */ + CALC_4x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_4_BK + +ALIGN_4 +.L4x1_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L4x1_BK_Store + +ALIGN_4 +.L4x1_BK: /*BK_CUR LOOP */ + CALC_4x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_BK + +ALIGN_4 +.L4x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x1 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.L2x1: + +tmll BM,2 +jz .L1x1 + +ALIGN_4 +.L2x1_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_2x1 +cijle LOCAL_VAR1,0,.L2x1_mod + +ALIGN_4 +.L2x1_4_BK: /*BK_CUR LOOP */ + CALC_2x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_4_BK + +ALIGN_4 +.L2x1_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L2x1_BK_Store + +ALIGN_4 +.L2x1_BK: /*BK_CUR LOOP */ + CALC_2x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_BK + +ALIGN_4 +.L2x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x1 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + + +ALIGN_2 +.L1x1: + +tmll BM, 1 +jz .Lx1_INNER_END + +ALIGN_4 +.L1x1_BM: /*BM start*/ +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +ZERO_CVEC_1x1 +cijle LOCAL_VAR1,0,.L1x1_mod + +ALIGN_4 +.L1x1_4_BK: /*BK_CUR LOOP */ + CALC_1x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_4_BK + +ALIGN_4 +.L1x1_mod: +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +jz .L1x1_BK_Store + +ALIGN_4 +.L1x1_BK: /*BK_CUR LOOP */ + CALC_1x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_BK + +ALIGN_4 +.L1x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x1 ALPHA ,CIJ_LOCAL, LDC_BYTE + +ALIGN_2 +.Lx1_INNER_END: +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR2,BK,3 /*muyliply*2*sizeof(double) =multiply*8* 2**3 */ +la CIJ,0(CIJ,LDC_BYTE) /*refresh CIJ=CIJ+LDC_BYTE */ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*1*sizeof(double) */ + + +ALIGN_2 +.L_FUNC_END: +/*end*/ +lmg %r6,%r12,48(%r15) +br %r14 +.end + + + + diff --git a/kernel/zarch/kernelMacros.S b/kernel/zarch/kernelMacros.S new file mode 100644 index 0000000000..04518d1908 --- /dev/null +++ b/kernel/zarch/kernelMacros.S @@ -0,0 +1,1477 @@ +/*********************************KERNEL 8x4***********************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_8x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + vzero %v24 + vzero %v25 + vzero %v26 + vzero %v27 + vzero %v28 + vzero %v29 + vzero %v30 + vzero %v31 +.endm + +/*Calculate for 8x4 C blocks*/ +.macro CALC_8x4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,16(\PTR_B_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + vlrepg %v1,24(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v26,%v4,%v7,%v26 + la \PTR_A_REG, 64(\PTR_A_REG) + vfmadb %v27,%v5,%v7,%v27 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + la \PTR_B_REG, 32(\PTR_B_REG) + vfmadb %v30,%v4,%v1,%v30 + vfmadb %v31,%v5,%v1,%v31 +.endm + +/*Calculate for 8x4_4 C blocks*/ +.macro CALC_8x4_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,16(\PTR_B_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + vlrepg %v1,24(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v26,%v4,%v7,%v26 + vfmadb %v27,%v5,%v7,%v27 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + vfmadb %v30,%v4,%v1,%v30 + vfmadb %v31,%v5,%v1,%v31 + + vlrepg %v7, 32(\PTR_B_REG) + vlrepg %v1,40(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vl %v4, 96(\PTR_A_REG) + vl %v5, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,48(\PTR_B_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + vlrepg %v1,56(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v26,%v4,%v7,%v26 + vfmadb %v27,%v5,%v7,%v27 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + vfmadb %v30,%v4,%v1,%v30 + vfmadb %v31,%v5,%v1,%v31 + + vlrepg %v7, 64(\PTR_B_REG) + vlrepg %v1,72(\PTR_B_REG) + vl %v2, 128(\PTR_A_REG) + vl %v3, 144(\PTR_A_REG) + vl %v4, 160(\PTR_A_REG) + vl %v5, 176(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,80(\PTR_B_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + vlrepg %v1,88(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v26,%v4,%v7,%v26 + vfmadb %v27,%v5,%v7,%v27 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + vfmadb %v30,%v4,%v1,%v30 + vfmadb %v31,%v5,%v1,%v31 + + vlrepg %v7, 96(\PTR_B_REG) + vlrepg %v1,104(\PTR_B_REG) + vl %v2, 192(\PTR_A_REG) + vl %v3, 208(\PTR_A_REG) + vl %v4, 224(\PTR_A_REG) + vl %v5, 240(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,112(\PTR_B_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + vlrepg %v1,120(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v26,%v4,%v7,%v26 + vfmadb %v27,%v5,%v7,%v27 + la \PTR_B_REG, 128(\PTR_B_REG) + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + vfmadb %v30,%v4,%v1,%v30 + la \PTR_A_REG, 256(\PTR_A_REG) + vfmadb %v31,%v5,%v1,%v31 + +.endm + + +/*STORE C8X4*/ +.macro STORE_8x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + /*add LDC_BYTE_reg=LDC_BYTE_original<<1 */ + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + vl %v3,32(\CIJ_REG) + vfmadb %v3,%v18,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG) + + vl %v4,48(\CIJ_REG) + vfmadb %v4,%v19,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG) + + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + + + /*add c LDC_BYTE*/ + vl %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v1,%v20,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v2,%v21,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + + vl %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v3,%v22,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v4,%v23,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + + vl %v1,0(\CIJ_REG,LOCAL_VAR1) + vfmadb %v1,%v24,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,LOCAL_VAR1) + + vl %v2,16(\CIJ_REG,LOCAL_VAR1) + vfmadb %v2,%v25,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,LOCAL_VAR1) + + vl %v3,32(\CIJ_REG,LOCAL_VAR1) + vfmadb %v3,%v26,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG,LOCAL_VAR1) + + vl %v4,48(\CIJ_REG,LOCAL_VAR1) + vfmadb %v4,%v27,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG,LOCAL_VAR1) + + + vl %v1,0(\CIJ_REG,LOCAL_VAR2) + vfmadb %v1,%v28,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,LOCAL_VAR2) + + vl %v2,16(\CIJ_REG,LOCAL_VAR2) + vfmadb %v2,%v29,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,LOCAL_VAR2) + + vl %v3,32(\CIJ_REG,LOCAL_VAR2) + vfmadb %v3,%v30,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG,LOCAL_VAR2) + + vl %v4,48(\CIJ_REG,LOCAL_VAR2) + vfmadb %v4,%v31,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG,LOCAL_VAR2) + + la \CIJ_REG,64(\CIJ_REG) + +.endm + +/*STORE TRMM C8X4*/ +.macro STORE_TRMM_8x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + /*add LDC_BYTE_reg=LDC_BYTE_original<<1 */ + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + vfmdb %v3,%v18,\ALPHA_VECREG + vst %v3,32(\CIJ_REG) + vfmdb %v4,%v19,\ALPHA_VECREG + vst %v4,48(\CIJ_REG) + + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + + /*add c LDC_BYTE*/ + vfmdb %v1,%v20,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v2,%v21,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vfmdb %v3,%v22,\ALPHA_VECREG + vst %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v4,%v23,\ALPHA_VECREG + vst %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vfmdb %v1,%v24,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,LOCAL_VAR1) + vfmdb %v2,%v25,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,LOCAL_VAR1) + vfmdb %v3,%v26,\ALPHA_VECREG + vst %v3,32(\CIJ_REG,LOCAL_VAR1) + vfmdb %v4,%v27,\ALPHA_VECREG + vst %v4,48(\CIJ_REG,LOCAL_VAR1) + + vfmdb %v1,%v28,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,LOCAL_VAR2) + vfmdb %v2,%v29,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,LOCAL_VAR2) + vfmdb %v3,%v30,\ALPHA_VECREG + vst %v3,32(\CIJ_REG,LOCAL_VAR2) + vfmdb %v4,%v31,\ALPHA_VECREG + vst %v4,48(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,64(\CIJ_REG) + +.endm +/**************************************Kernel4x4*************************************************/ + +/*Zero C block Vectors*/ +.macro ZERO_CVEC_4x4 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 + vzero %v24 + vzero %v25 + vzero %v28 + vzero %v29 +.endm + +/*Calculate for 4x4 C blocks*/ +.macro CALC_4x4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,16(\PTR_B_REG) + vlrepg %v1,24(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + la \PTR_A_REG, 32(\PTR_A_REG) + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + la \PTR_B_REG, 32(\PTR_B_REG) +.endm + +.macro CALC_4x4_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,16(\PTR_B_REG) + vlrepg %v1,24(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + + vlrepg %v7, 32(\PTR_B_REG) + vlrepg %v1,40(\PTR_B_REG) + vl %v2, 32(\PTR_A_REG) + vl %v3, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,48(\PTR_B_REG) + vlrepg %v1,56(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + + vlrepg %v7, 64(\PTR_B_REG) + vlrepg %v1,72(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,80(\PTR_B_REG) + vlrepg %v1,88(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + + vlrepg %v7, 96(\PTR_B_REG) + vlrepg %v1,104(\PTR_B_REG) + vl %v2, 96(\PTR_A_REG) + vl %v3, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepg %v7,112(\PTR_B_REG) + la \PTR_A_REG, 128(\PTR_A_REG) + vlrepg %v1,120(\PTR_B_REG) + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v28,%v2,%v1,%v28 + la \PTR_B_REG, 128(\PTR_B_REG) + vfmadb %v29,%v3,%v1,%v29 +.endm + +/*STORE C4X4*/ +.macro STORE_4x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + /*add LDC_BYTE_reg=LDC_BYTE_original<<1 */ + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + + /*add c LDC_BYTE*/ + vl %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v1,%v20,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v2,%v21,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v1,0(\CIJ_REG,LOCAL_VAR1) + vfmadb %v1,%v24,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,LOCAL_VAR1) + + vl %v2,16(\CIJ_REG,LOCAL_VAR1) + vfmadb %v2,%v25,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,LOCAL_VAR1) + + + vl %v1,0(\CIJ_REG,LOCAL_VAR2) + vfmadb %v1,%v28,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,LOCAL_VAR2) + + vl %v2,16(\CIJ_REG,LOCAL_VAR2) + vfmadb %v2,%v29,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,LOCAL_VAR2) + + la \CIJ_REG,32(\CIJ_REG) +.endm + +/*STORE TRMM C4X4*/ +.macro STORE_TRMM_4x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + /*add LDC_BYTE_reg=LDC_BYTE_original<<1 */ + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + vfmdb %v1,%v20,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v2,%v21,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v1,%v24,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,LOCAL_VAR1) + vfmdb %v2,%v25,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,LOCAL_VAR1) + vfmdb %v1,%v28,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,LOCAL_VAR2) + vfmdb %v2,%v29,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,32(\CIJ_REG) +.endm +/**************************************Kernel2x4*************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_2x4 + vzero %v1 /*a1b1 a1b2 */ + vzero %v2 /*a1b3 a1b4 */ + vzero %v6 /*a2b1 a2b2 */ + vzero %v7 /*a2b3 a2b4 */ +.endm + +/*Calculate for 2x4_4 C blocks.This Time BroadCast A. but Load B multiple*/ +.macro CALC_2x4_4 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vl %v5,16(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + vlrepg %v16, 8(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + vfmadb %v6,%v16,%v4,%v6 + vfmadb %v7,%v16,%v5,%v7 + + vl %v4, 32(\PTR_B_REG) + vl %v5,48(\PTR_B_REG) + vlrepg %v3, 16(\PTR_A_REG) + vlrepg %v16, 24(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + vfmadb %v6,%v16,%v4,%v6 + vfmadb %v7,%v16,%v5,%v7 + + vl %v4, 64(\PTR_B_REG) + vl %v5,80(\PTR_B_REG) + vlrepg %v3, 32(\PTR_A_REG) + vlrepg %v16, 40(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + vfmadb %v6,%v16,%v4,%v6 + vfmadb %v7,%v16,%v5,%v7 + + vl %v4, 96(\PTR_B_REG) + vl %v5,112(\PTR_B_REG) + vlrepg %v3, 48(\PTR_A_REG) + vlrepg %v16, 56(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + la \PTR_B_REG, 128(\PTR_B_REG) + vfmadb %v6,%v16,%v4,%v6 + vfmadb %v7,%v16,%v5,%v7 + la \PTR_A_REG, 64(\PTR_A_REG) +.endm + +/*Calculate for 2x4 C blocks.This Time BroadCast A. but Load B multiple*/ +.macro CALC_2x4 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vl %v5,16(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + vlrepg %v16, 8(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + la \PTR_A_REG, 16(\PTR_A_REG) + vfmadb %v6,%v16,%v4,%v6 + vfmadb %v7,%v16,%v5,%v7 + la \PTR_B_REG, 32(\PTR_B_REG) +.endm + +.macro STORE_2x4 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vfmdb %v2,%v2,\ALPHA_REG + vfmdb %v6,%v6,\ALPHA_REG + vfmdb %v7,%v7,\ALPHA_REG + vrepg %v4,%v1,1 + vrepg %v5,%v6,1 + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + adb %f1, 0(\CIJ_REG) + std %f1,0(\CIJ_REG) + + adb %f6, 8(\CIJ_REG) + std %f6,8(\CIJ_REG) + + adb %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + adb %f5,8(\CIJ_REG,\LDC_BYTE_ORIGINAL) + std %f5,8(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + /*add LDC_BYTE */ + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + vrepg %v4,%v2,1 + vrepg %v5,%v7,1 + + adb %f2,0(\CIJ_REG,LOCAL_VAR1) + std %f2,0(\CIJ_REG,LOCAL_VAR1) + + adb %f7,8(\CIJ_REG,LOCAL_VAR1) + std %f7,8(\CIJ_REG,LOCAL_VAR1) + + adb %f4,0(\CIJ_REG,LOCAL_VAR2) + std %f4,0(\CIJ_REG,LOCAL_VAR2) + + adb %f5,8(\CIJ_REG,LOCAL_VAR2) + std %f5,8(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,16(\CIJ_REG) + +.endm + +.macro STORE_TRMM_2x4 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vfmdb %v2,%v2,\ALPHA_REG + vfmdb %v6,%v6,\ALPHA_REG + vfmdb %v7,%v7,\ALPHA_REG + vrepg %v4,%v1,1 + vrepg %v5,%v6,1 + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + std %f1,0(\CIJ_REG) + std %f6,8(\CIJ_REG) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + std %f5,8(\CIJ_REG,\LDC_BYTE_ORIGINAL) + /*add LDC_BYTE */ + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + vrepg %v4,%v2,1 + vrepg %v5,%v7,1 + std %f2,0(\CIJ_REG,LOCAL_VAR1) + std %f7,8(\CIJ_REG,LOCAL_VAR1) + std %f4,0(\CIJ_REG,LOCAL_VAR2) + std %f5,8(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,16(\CIJ_REG) +.endm + +/**************************************Kernel1x4*************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_1x4 + vzero %v1 + vzero %v2 +.endm +/*Calculate for 1x4 C blocks.This Time BroadCast A. but Load B multiple*/ +.macro CALC_1x4 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vl %v5,16(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + la \PTR_A_REG, 8(\PTR_A_REG) + vfmadb %v2,%v3,%v5,%v2 + la \PTR_B_REG, 32(\PTR_B_REG) +.endm + +/*Calculate for 1x4_4 C blocks.This Time BroadCast A. but Load B multiple*/ +.macro CALC_1x4_4 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vl %v5,16(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + + vl %v4, 32(\PTR_B_REG) + vl %v5,48(\PTR_B_REG) + vlrepg %v3, 8(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + + vl %v4, 64(\PTR_B_REG) + vl %v5,80(\PTR_B_REG) + vlrepg %v3, 16(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + + vl %v4, 96(\PTR_B_REG) + vl %v5,112(\PTR_B_REG) + vlrepg %v3, 24(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + vfmadb %v2,%v3,%v5,%v2 + la \PTR_A_REG, 32(\PTR_A_REG) + la \PTR_B_REG, 128(\PTR_B_REG) +.endm + +.macro STORE_1x4 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vfmdb %v2,%v2,\ALPHA_REG + vrepg %v4,%v1,1 + vrepg %v5,%v2,1 + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + adb %f1, 0(\CIJ_REG) + std %f1,0(\CIJ_REG) + + adb %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + /*add LDC_BYTE */ + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + adb %f2,0(\CIJ_REG,LOCAL_VAR1) + std %f2,0(\CIJ_REG,LOCAL_VAR1) + adb %f5,0(\CIJ_REG,LOCAL_VAR2) + std %f5,0(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,8(\CIJ_REG) + +.endm + +.macro STORE_TRMM_1x4 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vfmdb %v2,%v2,\ALPHA_REG + vrepg %v4,%v1,1 + vrepg %v5,%v2,1 + la LOCAL_VAR1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + std %f1,0(\CIJ_REG) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + /*add LDC_BYTE */ + la LOCAL_VAR2,0(LOCAL_VAR1,\LDC_BYTE_ORIGINAL ) + std %f2,0(\CIJ_REG,LOCAL_VAR1) + std %f5,0(\CIJ_REG,LOCAL_VAR2) + la \CIJ_REG,8(\CIJ_REG) +.endm +/***************************************BN=2 SECTION***************************************/ +/*************************************Kernel8x2***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_8x2 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + +.endm + +/*Calculate for 8x2 C blocks*/ +.macro CALC_8x2 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + la \PTR_A_REG, 64(\PTR_A_REG) + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + la \PTR_B_REG, 16(\PTR_B_REG) +.endm + + +/*Calculate for 8x2_4 C blocks*/ +.macro CALC_8x2_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + + vlrepg %v7, 16(\PTR_B_REG) + vlrepg %v1,24(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vl %v4, 96(\PTR_A_REG) + vl %v5, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + + vlrepg %v7, 32(\PTR_B_REG) + vlrepg %v1,40(\PTR_B_REG) + vl %v2, 128(\PTR_A_REG) + vl %v3, 144(\PTR_A_REG) + vl %v4, 160(\PTR_A_REG) + vl %v5, 176(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + + vlrepg %v7, 48(\PTR_B_REG) + vlrepg %v1,56(\PTR_B_REG) + vl %v2, 192(\PTR_A_REG) + vl %v3, 208(\PTR_A_REG) + vl %v4, 224(\PTR_A_REG) + vl %v5, 240(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + la \PTR_B_REG, 64(\PTR_B_REG) + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vfmadb %v22,%v4,%v1,%v22 + vfmadb %v23,%v5,%v1,%v23 + la \PTR_A_REG, 256(\PTR_A_REG) +.endm + +/*STORE C8X2*/ +.macro STORE_8x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + vl %v3,32(\CIJ_REG) + vfmadb %v3,%v18,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG) + + vl %v4,48(\CIJ_REG) + vfmadb %v4,%v19,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG) + + + vl %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v1,%v20,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v2,%v21,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + + vl %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v3,%v22,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v4,%v23,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + + la \CIJ_REG,64(\CIJ_REG) + +.endm + +/*STORE TRMM C8X2*/ +.macro STORE_TRMM_8x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + vfmdb %v3,%v18,\ALPHA_VECREG + vst %v3,32(\CIJ_REG) + vfmdb %v4,%v19,\ALPHA_VECREG + vst %v4,48(\CIJ_REG) + vfmdb %v1,%v20,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v2,%v21,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v3,%v22,\ALPHA_VECREG + vst %v3,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v4,%v23,\ALPHA_VECREG + vst %v4,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,64(\CIJ_REG) +.endm + +/*************************************Kernel4x2***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_4x2 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 + +.endm + +/*Calculate for 4x2 C blocks*/ +.macro CALC_4x2 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + la \PTR_A_REG, 32(\PTR_A_REG) + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + la \PTR_B_REG, 16(\PTR_B_REG) +.endm + +/*Calculate for 4x2_4 C blocks*/ +.macro CALC_4x2_4 PTR_A_REG,PTR_B_REG + + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + + vlrepg %v7, 16(\PTR_B_REG) + vlrepg %v1,24(\PTR_B_REG) + vl %v2, 32(\PTR_A_REG) + vl %v3, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + + vlrepg %v7, 32(\PTR_B_REG) + vlrepg %v1,40(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + + + vlrepg %v7, 48(\PTR_B_REG) + vlrepg %v1,56(\PTR_B_REG) + vl %v2, 96(\PTR_A_REG) + vl %v3, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + la \PTR_B_REG, 64(\PTR_B_REG) + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + la \PTR_A_REG, 128(\PTR_A_REG) +.endm + + +/*STORE C4x2*/ +.macro STORE_4x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + + vl %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v1,%v20,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + vl %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v2,%v21,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + la \CIJ_REG,32(\CIJ_REG) + +.endm + +/*STORE TRMM C4x2*/ +.macro STORE_TRMM_4x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + vfmdb %v1,%v20,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmdb %v2,%v21,\ALPHA_VECREG + vst %v2,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,32(\CIJ_REG) +.endm + +/*************************************Kernel2x2***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_2x2 + vzero %v16 + vzero %v20 + +.endm + +/*Calculate for 2x2 C blocks*/ +.macro CALC_2x2 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + la \PTR_A_REG, 16(\PTR_A_REG) + vfmadb %v20,%v2,%v1,%v20 + la \PTR_B_REG, 16(\PTR_B_REG) +.endm + +/*Calculate for 2x2_4 C blocks*/ +.macro CALC_2x2_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vlrepg %v1,8(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v20,%v2,%v1,%v20 + + vlrepg %v7, 16(\PTR_B_REG) + vlrepg %v1,24(\PTR_B_REG) + vl %v2, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v20,%v2,%v1,%v20 + + vlrepg %v7, 32(\PTR_B_REG) + vlrepg %v1,40(\PTR_B_REG) + vl %v2, 32(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v20,%v2,%v1,%v20 + + + vlrepg %v7, 48(\PTR_B_REG) + vlrepg %v1,56(\PTR_B_REG) + vl %v2, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v20,%v2,%v1,%v20 + + la \PTR_B_REG, 64(\PTR_B_REG) + la \PTR_A_REG, 64(\PTR_A_REG) +.endm + +/*STORE C2x2*/ +.macro STORE_2x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vfmadb %v1,%v20,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + la \CIJ_REG,16(\CIJ_REG) + +.endm + +/*STORE TRMM C2x2*/ +.macro STORE_TRMM_2x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v1,%v20,\ALPHA_VECREG + vst %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,16(\CIJ_REG) +.endm + +/**************************************Kernel1x2*************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_1x2 + vzero %v1 +.endm +/*Calculate for 1x2 C blocks.This Time BroadCast A. but Load B multiple*/ +.macro CALC_1x2 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + la \PTR_B_REG, 16(\PTR_B_REG) + vfmadb %v1,%v3,%v4,%v1 + la \PTR_A_REG, 8(\PTR_A_REG) +.endm + +.macro CALC_1x2_4 PTR_A_REG,PTR_B_REG + vl %v4, 0(\PTR_B_REG) + vlrepg %v3, 0(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + + vl %v4, 16(\PTR_B_REG) + vlrepg %v3, 8(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + + vl %v4, 32(\PTR_B_REG) + vlrepg %v3, 16(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + + vl %v4, 48(\PTR_B_REG) + vlrepg %v3, 24(\PTR_A_REG) + vfmadb %v1,%v3,%v4,%v1 + + la \PTR_B_REG, 64(\PTR_B_REG) + la \PTR_A_REG, 32(\PTR_A_REG) +.endm + +.macro STORE_1x2 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vrepg %v4,%v1,1 + adb %f1, 0(\CIJ_REG) + std %f1,0(\CIJ_REG) + + adb %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + la \CIJ_REG,8(\CIJ_REG) + +.endm + +.macro STORE_TRMM_1x2 ALPHA_REG,CIJ_REG , LDC_BYTE_ORIGINAL +/**/ + vfmdb %v1,%v1,\ALPHA_REG + vrepg %v4,%v1,1 + std %f1,0(\CIJ_REG) + std %f4,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,8(\CIJ_REG) +.endm + +/**************************************BN=1*******************************************************/ +/*************************************Kernel8x1***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_8x1 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 +.endm +/*Calculate for 8x1 C blocks*/ +.macro CALC_8x1 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + la \PTR_B_REG, 8(\PTR_B_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + la \PTR_A_REG, 64(\PTR_A_REG) + vfmadb %v19,%v5,%v7,%v19 +.endm + +/*Calculate for 8x1_4 C blocks*/ +.macro CALC_8x1_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vl %v4, 32(\PTR_A_REG) + vl %v5, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + + vlrepg %v7, 8(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vl %v4, 96(\PTR_A_REG) + vl %v5, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + + vlrepg %v7, 16(\PTR_B_REG) + vl %v2, 128(\PTR_A_REG) + vl %v3, 144(\PTR_A_REG) + vl %v4, 160(\PTR_A_REG) + vl %v5, 176(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + + vlrepg %v7, 24(\PTR_B_REG) + vl %v2, 192(\PTR_A_REG) + vl %v3, 208(\PTR_A_REG) + vl %v4, 224(\PTR_A_REG) + vl %v5, 240(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v18,%v4,%v7,%v18 + vfmadb %v19,%v5,%v7,%v19 + + + la \PTR_A_REG, 256(\PTR_A_REG) + la \PTR_B_REG, 32(\PTR_B_REG) +.endm + +/*STORE C8X1*/ +.macro STORE_8x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + vl %v3,32(\CIJ_REG) + vfmadb %v3,%v18,\ALPHA_VECREG,%v3 + vst %v3,32(\CIJ_REG) + + vl %v4,48(\CIJ_REG) + vfmadb %v4,%v19,\ALPHA_VECREG,%v4 + vst %v4,48(\CIJ_REG) + + la \CIJ_REG,64(\CIJ_REG) + +.endm + +/*STORE TRMM C8X1*/ +.macro STORE_TRMM_8x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + vfmdb %v3,%v18,\ALPHA_VECREG + vst %v3,32(\CIJ_REG) + vfmdb %v4,%v19,\ALPHA_VECREG + vst %v4,48(\CIJ_REG) + la \CIJ_REG,64(\CIJ_REG) +.endm + + +/*************************************Kernel4x1***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_4x1 + vzero %v16 + vzero %v17 +.endm +/*Calculate for 4x1 C blocks*/ +.macro CALC_4x1 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + la \PTR_B_REG, 8(\PTR_B_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + la \PTR_A_REG, 32(\PTR_A_REG) +.endm + +/*Calculate for 4x1_4 C blocks*/ +.macro CALC_4x1_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vl %v3, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + + vlrepg %v7, 8(\PTR_B_REG) + vl %v2, 32(\PTR_A_REG) + vl %v3, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + + vlrepg %v7, 16(\PTR_B_REG) + vl %v2, 64(\PTR_A_REG) + vl %v3, 80(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + + vlrepg %v7, 24(\PTR_B_REG) + vl %v2, 96(\PTR_A_REG) + vl %v3, 112(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + + la \PTR_B_REG, 32(\PTR_B_REG) + la \PTR_A_REG, 128(\PTR_A_REG) +.endm + +/*STORE C4X1*/ +.macro STORE_4x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + vl %v2,16(\CIJ_REG) + vfmadb %v2,%v17,\ALPHA_VECREG,%v2 + vst %v2,16(\CIJ_REG) + + + la \CIJ_REG,32(\CIJ_REG) + +.endm + +/*STORE TRMM C4X1*/ +.macro STORE_TRMM_4x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + vfmdb %v2,%v17,\ALPHA_VECREG + vst %v2,16(\CIJ_REG) + la \CIJ_REG,32(\CIJ_REG) +.endm +/*************************************Kernel2x1***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_2x1 + vzero %v16 +.endm +/*Calculate for 2x1 C blocks*/ +.macro CALC_2x1 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + la \PTR_B_REG, 8(\PTR_B_REG) + vfmadb %v16,%v2,%v7,%v16 + la \PTR_A_REG, 16(\PTR_A_REG) +.endm + +/*Calculate for 2x1_4 C blocks*/ +.macro CALC_2x1_4 PTR_A_REG,PTR_B_REG + vlrepg %v7, 0(\PTR_B_REG) + vl %v2, 0(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + + vlrepg %v7, 8(\PTR_B_REG) + vl %v2, 16(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + + vlrepg %v7, 16(\PTR_B_REG) + vl %v2, 32(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + + vlrepg %v7, 24(\PTR_B_REG) + vl %v2, 48(\PTR_A_REG) + vfmadb %v16,%v2,%v7,%v16 + + la \PTR_B_REG, 32(\PTR_B_REG) + la \PTR_A_REG, 64(\PTR_A_REG) +.endm + +/*STORE C2X1*/ +.macro STORE_2x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + + vl %v1,0(\CIJ_REG) + vfmadb %v1,%v16,\ALPHA_VECREG,%v1 + vst %v1,0(\CIJ_REG) + + la \CIJ_REG,16(\CIJ_REG) + +.endm + +/*STORE TRMM C2X1*/ +.macro STORE_TRMM_2x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + vfmdb %v1,%v16,\ALPHA_VECREG + vst %v1,0(\CIJ_REG) + la \CIJ_REG,16(\CIJ_REG) +.endm +/*************************************Kernel1x1***************************************************/ +/*Zero C block Vectors*/ +.macro ZERO_CVEC_1x1 + LZDR %f1 +.endm +/*Calculate for 1x1 C blocks*/ +.macro CALC_1x1 PTR_A_REG,PTR_B_REG + ld %f2,0(\PTR_A_REG) /**a*/ + la \PTR_A_REG,8(\PTR_A_REG) + madb %f1,%f2,0(\PTR_B_REG) + la \PTR_B_REG,8(\PTR_B_REG) +.endm + +/*Calculate for 1x1_4 C blocks*/ +.macro CALC_1x1_4 PTR_A_REG,PTR_B_REG + ld %f2,0(\PTR_A_REG) /**a*/ + madb %f1,%f2,0(\PTR_B_REG) + + ld %f2,8(\PTR_A_REG) /**a*/ + madb %f1,%f2,8(\PTR_B_REG) + + ld %f2,16(\PTR_A_REG) /**a*/ + madb %f1,%f2,16(\PTR_B_REG) + + ld %f2,24(\PTR_A_REG) /**a*/ + madb %f1,%f2,24(\PTR_B_REG) + + la \PTR_A_REG,32(\PTR_A_REG) + la \PTR_B_REG,32(\PTR_B_REG) +.endm + +/*STORE C1X1*/ +.macro STORE_1x1 ALPHA_FLOAT,CIJ_REG,LDC_BYTE_ORIGINAL + ld %f2,0(CIJ_LOCAL) + madbr %f2,%f1,\ALPHA_FLOAT + std %f2,0(CIJ_LOCAL) + la \CIJ_REG,8(\CIJ_REG) +.endm + +/*STORE C1X1*/ +.macro STORE_TRMM_1x1 ALPHA_FLOAT,CIJ_REG,LDC_BYTE_ORIGINAL + mdbr %f1,\ALPHA_FLOAT + std %f1,0(CIJ_LOCAL) + la \CIJ_REG,8(\CIJ_REG) +.endm + + +/****************************TRMM POINTER REFRESH MACROSES*************************/ + +.macro RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B + #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /* ptrbb = bb;*/ + lgr \PTR_B,\B_VAL /*refresh BPOINT*/ + + #else + /* ptrba =ptrba+ off*C_A; + ptrbb = bb + off*C_B;*/ +.if \C_B==4 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,5 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*4*/ + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_B, \PTR_B + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,5 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==2 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,6 + agr \PTR_A,\PTR_B /*ptrba+off*8**/ + sllg \PTR_B, \OFF_VAL,4 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_B,\PTR_B /* off+off**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==1 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,6 + agr \PTR_A,\PTR_B /*ptrba+off*8**/ + sllg \PTR_B, \OFF_VAL,3 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,3 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,3 + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif +.endif + + + #endif +.endm + +/**/ +.macro RefreshTempBk TEMP_VAL,BK_VAL,OFF_VAL,INCR_A,INCR_B + #if (defined(LEFT) && !defined(TRANSA)) || (!defined(LEFT) && defined(TRANSA)) + /* temp = bk-off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + + #elif defined(LEFT) + /* temp = off+INCR_A; // number of values in A */ + la \TEMP_VAL,\INCR_A(\OFF_VAL) + #else + /* temp = off+INCR_B // number of values in B*/ + la \TEMP_VAL,\INCR_B(\OFF_VAL) + #endif + +.endm + + +.macro RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,PTR_B,PTR_A,C_A,C_B + + #if ( defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /*temp = bk - off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + #ifdef LEFT + /*temp -= 8; // number of values in A*/ + lay \TEMP_VAL,-\C_A(\TEMP_VAL) + #else + /*temp -= 4; // number of values in B*/ + lay \TEMP_VAL,-\C_B(\TEMP_VAL) + #endif + /*ptrba += temp*C_A; + ptrbb += temp*C_B;*/ + .if \C_A==8 + sllg \TEMP_VAL, \TEMP_VAL,6 + .elseif \C_A==4 + sllg \TEMP_VAL, \TEMP_VAL,5 /*temp*4*/ + .elseif \C_A==2 + sllg \TEMP_VAL, \TEMP_VAL,4 /*temp*2*/ + .elseif \C_A==1 + sllg \TEMP_VAL, \TEMP_VAL,3 /*temp*1*/ + .endif + la \PTR_A,0(\PTR_A,\TEMP_VAL) /*ptrba+temp*C_A*/ + /*we do not need to refresh ptrbb. so lets ignore it*/ + + #endif + + #ifdef LEFT + /*off += 8; // number of values in A*/ + aghi \OFF_VAL,\C_A + #endif +.endm \ No newline at end of file diff --git a/kernel/zarch/skernelMacros.S b/kernel/zarch/skernelMacros.S new file mode 100644 index 0000000000..6f74f2b14d --- /dev/null +++ b/kernel/zarch/skernelMacros.S @@ -0,0 +1,1143 @@ +/**********************************Zero Vectors**************************************************/ + +.macro ZERO_CVEC_8x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + vzero %v24 + vzero %v25 + vzero %v26 + vzero %v27 + vzero %v28 + vzero %v29 + vzero %v30 + vzero %v31 +.endm + + +.macro ZERO_CVEC_8x2 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + +.endm + +.macro ZERO_CVEC_8x1 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 +.endm + +.macro ZERO_CVEC_4x4 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 + vzero %v24 + vzero %v25 + vzero %v28 + vzero %v29 +.endm + +.macro ZERO_CVEC_4x2 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 + +.endm + +.macro ZERO_CVEC_4x1 + lzer %f1 + lzer %f2 + lzer %f3 + lzer %f4 +.endm + +.macro ZERO_CVEC_2x4 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 + +.endm + +.macro ZERO_CVEC_2x2 + vzero %v16 + vzero %v20 + +.endm + +.macro ZERO_CVEC_2x1 + lzer %f1 + lzer %f2 +.endm + +.macro ZERO_CVEC_1x4 + lzer %f1 + lzer %f2 + lzer %f3 + lzer %f4 +.endm + +.macro ZERO_CVEC_1x2 + lzer %f1 + lzer %f2 +.endm + +.macro ZERO_CVEC_1x1 + lzer %f1 +.endm + + +/***********************************Helper Calculations*************************************/ +#define unit_size 4 +#define DISP(ind,stride,disp) (ind*stride+disp) +#define DISP8(ind,disp) (ind*unit_size*8+disp) +#define DISP4(ind,disp) (ind*unit_size*4+disp) +#define DISP2(ind,disp) (ind*unit_size*2+disp) +#define DISP1(ind,disp) (ind*unit_size+disp) +#define N8 (8*unit_size) +#define N4 (4*unit_size) +#define N2 (2*unit_size) +#define N1 (1*unit_size) + +.macro Calculate_8x4_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlm %v1,%v2, DISP8(\Index , 0)(\PTR_A_REG) + vmrhf %v3,%v1,%v1 + vmrhf %v5,%v2,%v2 + vmrlf %v4,%v1,%v1 + vmrlf %v6,%v2,%v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vldeb %v5, %v5 + vlrepf %v7, DISP4(\Index ,0)(\PTR_B_REG) + vlrepf %v1, DISP4(\Index ,4)(\PTR_B_REG) + vldeb %v6, %v6 + vldeb %v7, %v7 + vldeb %v1, %v1 + + + vfmadb %v16,%v3,%v7,%v16 + vfmadb %v17,%v4,%v7,%v17 + vfmadb %v18,%v5,%v7,%v18 + vfmadb %v19,%v6,%v7,%v19 + vfmadb %v20,%v3,%v1,%v20 + vfmadb %v21,%v4,%v1,%v21 + vfmadb %v22,%v5,%v1,%v22 + vfmadb %v23,%v6,%v1,%v23 + vlrepf %v2, DISP4(\Index ,8)(\PTR_B_REG) + vlrepf %v7, DISP4(\Index ,12)(\PTR_B_REG) + vldeb %v2, %v2 + vldeb %v7, %v7 + .if \IsLast==1 + la \PTR_A_REG, DISP8(\Index ,N8)(\PTR_A_REG) + .endif + vfmadb %v24,%v3,%v2,%v24 + vfmadb %v25,%v4,%v2,%v25 + vfmadb %v26,%v5,%v2,%v26 + vfmadb %v27,%v6,%v2,%v27 + vfmadb %v28,%v3,%v7,%v28 + vfmadb %v29,%v4,%v7,%v29 + vfmadb %v30,%v5,%v7,%v30 + vfmadb %v31,%v6,%v7,%v31 + .if \IsLast==1 + la \PTR_B_REG, DISP4(\Index ,N4)(\PTR_B_REG) + .endif +.endm + +.macro Calculate_8x2_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlm %v1,%v2, DISP8(\Index , 0)(\PTR_A_REG) + vmrhf %v3,%v1,%v1 + vmrhf %v5,%v2,%v2 + vmrlf %v4,%v1,%v1 + vmrlf %v6,%v2,%v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vldeb %v5, %v5 + vlrepf %v7, DISP2(\Index ,0)(\PTR_B_REG) + vlrepf %v1, DISP2(\Index ,4)(\PTR_B_REG) + vldeb %v6, %v6 + vldeb %v7, %v7 + vldeb %v1, %v1 + vfmadb %v16,%v3,%v7,%v16 + vfmadb %v17,%v4,%v7,%v17 + vfmadb %v18,%v5,%v7,%v18 + vfmadb %v19,%v6,%v7,%v19 + vfmadb %v20,%v3,%v1,%v20 + vfmadb %v21,%v4,%v1,%v21 + .if \IsLast==1 + la \PTR_A_REG, DISP8(\Index ,N8)(\PTR_A_REG) + .endif + vfmadb %v22,%v5,%v1,%v22 + vfmadb %v23,%v6,%v1,%v23 + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,N2)(\PTR_B_REG) + .endif +.endm + +.macro Calculate_8x1_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlm %v1,%v2, DISP8(\Index , 0)(\PTR_A_REG) + vmrhf %v3,%v1,%v1 + vmrhf %v5,%v2,%v2 + vmrlf %v4,%v1,%v1 + vmrlf %v6,%v2,%v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vldeb %v5, %v5 + vlrepf %v7, DISP1(\Index ,0)(\PTR_B_REG) + vldeb %v6, %v6 + vldeb %v7, %v7 + vfmadb %v16,%v3,%v7,%v16 + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,N1)(\PTR_B_REG) + .endif + + vfmadb %v17,%v4,%v7,%v17 + vfmadb %v18,%v5,%v7,%v18 + vfmadb %v19,%v6,%v7,%v19 + .if \IsLast==1 + la \PTR_A_REG, DISP8(\Index ,N8)(\PTR_A_REG) + .endif +.endm + +.macro Calculate_4x4_I PTR_A_REG,PTR_B_REG,Index,IsLast + vl %v5, DISP4(\Index , 0)(\PTR_A_REG) + vlrepf %v7, DISP4(\Index ,0)(\PTR_B_REG) + vlrepf %v1, DISP4(\Index ,4)(\PTR_B_REG) + vmrhf %v2,%v5,%v5 + vmrlf %v3,%v5,%v5 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v7, %v7 + vldeb %v1, %v1 + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + vlrepf %v7, DISP4(\Index ,8)(\PTR_B_REG) + vlrepf %v1, DISP4(\Index ,12)(\PTR_B_REG) + vldeb %v7, %v7 + vldeb %v1, %v1 + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,N4)(\PTR_A_REG) + .endif + vfmadb %v24,%v2,%v7,%v24 + vfmadb %v25,%v3,%v7,%v25 + vfmadb %v28,%v2,%v1,%v28 + vfmadb %v29,%v3,%v1,%v29 + .if \IsLast==1 + la \PTR_B_REG, DISP4(\Index ,N4)(\PTR_B_REG) + .endif +.endm + +.macro Calculate_4x2_I PTR_A_REG,PTR_B_REG,Index,IsLast + vl %v5, DISP4(\Index , 0)(\PTR_A_REG) + vlrepf %v7, DISP2(\Index ,0)(\PTR_B_REG) + vlrepf %v1, DISP2(\Index ,4)(\PTR_B_REG) + vmrhf %v2,%v5,%v5 + vmrlf %v3,%v5,%v5 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v7, %v7 + vldeb %v1, %v1 + vfmadb %v16,%v2,%v7,%v16 + vfmadb %v17,%v3,%v7,%v17 + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,N2)(\PTR_B_REG) + .endif + vfmadb %v20,%v2,%v1,%v20 + vfmadb %v21,%v3,%v1,%v21 + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,N4)(\PTR_A_REG) + .endif +.endm + +.macro Calculate_4x1_I PTR_A_REG,PTR_B_REG,Index,IsLast + le %f5,DISP1(\Index ,0)(\PTR_B_REG) + maeb %f1,%f5,DISP4(\Index ,0)(\PTR_A_REG) + maeb %f2,%f5,DISP4(\Index ,4)(\PTR_A_REG) + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,N1)(\PTR_B_REG) + .endif + maeb %f3,%f5,DISP4(\Index ,8)(\PTR_A_REG) + maeb %f4,%f5,DISP4(\Index ,12)(\PTR_A_REG) + .if \IsLast==1 + la \PTR_A_REG, DISP4(\Index ,N4)(\PTR_A_REG) + .endif +.endm + +.macro Calculate_2x2_I PTR_A_REG,PTR_B_REG,Index,IsLast + vlrepf %v7, DISP2(\Index ,0)(\PTR_B_REG) + vlrepf %v1, DISP2(\Index ,4)(\PTR_B_REG) + vlef %v2, DISP2(\Index ,0)(\PTR_A_REG) ,0 + vlef %v2, DISP2(\Index ,4)(\PTR_A_REG) ,2 + vldeb %v7, %v7 + vldeb %v2,%v2 + vldeb %v1, %v1 + + vfmadb %v16,%v2,%v7,%v16 + .if \IsLast==1 + la \PTR_A_REG, DISP2(\Index ,N2)(\PTR_A_REG) + .endif + vfmadb %v20,%v2,%v1,%v20 + .if \IsLast==1 + la \PTR_B_REG, DISP2(\Index ,N2)(\PTR_B_REG) + .endif +.endm + + + +.macro Calculate_2x1_I PTR_A_REG,PTR_B_REG,Index,IsLast + + le %f3,DISP1(\Index ,0)(\PTR_B_REG) + maeb %f1,%f3,DISP2(\Index ,0)(\PTR_A_REG) + .if \IsLast==1 + la \PTR_B_REG, DISP1(\Index ,N1)(\PTR_B_REG) + .endif + maeb %f2, %f3,DISP2(\Index ,4)(\PTR_A_REG) + .if \IsLast==1 + la \PTR_A_REG, DISP2(\Index ,N2)(\PTR_A_REG) + .endif +.endm + +.macro Calculate_1x1_I PTR_A_REG,PTR_B_REG,Index,IsLast + le %f2,DISP1(\Index ,0)(\PTR_A_REG) /**a*/ + .if \IsLast==1 + la \PTR_A_REG,DISP1(\Index ,N1)(\PTR_A_REG) + .endif + maeb %f1,%f2,DISP1(\Index ,0)(\PTR_B_REG) + .if \IsLast==1 + la \PTR_B_REG,DISP1(\Index ,N1)(\PTR_B_REG) + .endif +.endm + +.macro CALC_8x4 PTR_A_REG,PTR_B_REG + Calculate_8x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_8x4_4 PTR_A_REG,PTR_B_REG + Calculate_8x4_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_8x4_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_8x4_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_8x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_8x2 PTR_A_REG,PTR_B_REG + Calculate_8x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_8x2_4 PTR_A_REG,PTR_B_REG + Calculate_8x2_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_8x2_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_8x2_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_8x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_8x1 PTR_A_REG,PTR_B_REG + Calculate_8x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_8x1_4 PTR_A_REG,PTR_B_REG + Calculate_8x1_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_8x1_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_8x1_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_8x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_4x4 PTR_A_REG,PTR_B_REG + Calculate_4x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_4x4_4 PTR_A_REG,PTR_B_REG + Calculate_4x4_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_4x4_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_4x4_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_4x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_4x2 PTR_A_REG,PTR_B_REG + Calculate_4x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_4x2_4 PTR_A_REG,PTR_B_REG + Calculate_4x2_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_4x2_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_4x2_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_4x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_4x1 PTR_A_REG,PTR_B_REG + Calculate_4x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_4x1_4 PTR_A_REG,PTR_B_REG + Calculate_4x1_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_4x1_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_4x1_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_4x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_2x4 PTR_A_REG,PTR_B_REG + Calculate_4x2_I \PTR_B_REG,\PTR_A_REG,0,1 +.endm + +.macro CALC_2x4_4 PTR_A_REG,PTR_B_REG + Calculate_4x2_I \PTR_B_REG,\PTR_A_REG,0,0 + Calculate_4x2_I \PTR_B_REG,\PTR_A_REG,1,0 + Calculate_4x2_I \PTR_B_REG,\PTR_A_REG,2,0 + Calculate_4x2_I \PTR_B_REG,\PTR_A_REG,3,1 +.endm + +.macro CALC_2x2 PTR_A_REG,PTR_B_REG + Calculate_2x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_2x2_4 PTR_A_REG,PTR_B_REG + Calculate_2x2_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_2x2_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_2x2_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_2x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_2x1 PTR_A_REG,PTR_B_REG + Calculate_2x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_2x1_4 PTR_A_REG,PTR_B_REG + Calculate_2x1_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_2x1_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_2x1_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_2x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro CALC_1x4 PTR_A_REG,PTR_B_REG + Calculate_4x1_I \PTR_B_REG,\PTR_A_REG,0,1 +.endm + +.macro CALC_1x4_4 PTR_A_REG,PTR_B_REG + Calculate_4x1_I \PTR_B_REG,\PTR_A_REG,0,0 + Calculate_4x1_I \PTR_B_REG,\PTR_A_REG,1,0 + Calculate_4x1_I \PTR_B_REG,\PTR_A_REG,2,0 + Calculate_4x1_I \PTR_B_REG,\PTR_A_REG,3,1 +.endm + +.macro CALC_1x2 PTR_A_REG,PTR_B_REG + Calculate_2x1_I \PTR_B_REG,\PTR_A_REG,0,1 +.endm + +.macro CALC_1x2_4 PTR_A_REG,PTR_B_REG + Calculate_2x1_I \PTR_B_REG,\PTR_A_REG,0,0 + Calculate_2x1_I \PTR_B_REG,\PTR_A_REG,1,0 + Calculate_2x1_I \PTR_B_REG,\PTR_A_REG,2,0 + Calculate_2x1_I \PTR_B_REG,\PTR_A_REG,3,1 +.endm + +.macro CALC_1x1 PTR_A_REG,PTR_B_REG + Calculate_1x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro CALC_1x1_4 PTR_A_REG,PTR_B_REG + Calculate_1x1_I \PTR_A_REG,\PTR_B_REG,0,0 + Calculate_1x1_I \PTR_A_REG,\PTR_B_REG,1,0 + Calculate_1x1_I \PTR_A_REG,\PTR_B_REG,2,0 + Calculate_1x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + + +/**************************************STORAGE*************************************************/ + + +.macro Multiply_8x1 vr1,vr2,vr3,vr4,va1,va2,va3,va4,vb1 + #if defined(TRMMKERNEL) + vfmdb \vr1,\va1,\vb1 + vfmdb \vr2,\va2,\vb1 + vfmdb \vr3,\va3,\vb1 + vfmdb \vr4,\va4,\vb1 + #else + vfmadb \vr1,\va1,\vb1,\vr1 + vfmadb \vr2,\va2,\vb1,\vr2 + vfmadb \vr3,\va3,\vb1,\vr3 + vfmadb \vr4,\va4,\vb1,\vr4 + #endif +.endm + +.macro Multiply_4x1 vr1,vr2, va1,va2, vb1 + #if defined(TRMMKERNEL) + vfmdb \vr1,\va1,\vb1 + vfmdb \vr2,\va2,\vb1 + #else + vfmadb \vr1,\va1,\vb1,\vr1 + vfmadb \vr2,\va2,\vb1,\vr2 + #endif +.endm + +.macro Multiply_2x1 vr1, va1,vb1 + #if defined(TRMMKERNEL) + vfmdb \vr1,\va1,\vb1 + #else + vfmadb \vr1,\va1,\vb1,\vr1 + #endif +.endm + + +.macro STORE_8x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL , LV1 ,LV2 + la \LV1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG) + vl %v1 , 16(\CIJ_REG) + vmrhf %v2,%v5,%v5 + vmrhf %v4,%v1,%v1 + vmrlf %v3,%v5,%v5 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v1,%v1 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v16,%v17,%v18,%v19 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG),0 + vstef %v2, 4(\CIJ_REG),2 + vstef %v3, 8(\CIJ_REG),0 + vstef %v3, 12(\CIJ_REG),2 + vstef %v4, 16(\CIJ_REG),0 + vstef %v4, 20(\CIJ_REG),2 + vstef %v5, 24(\CIJ_REG),0 + vstef %v5, 28(\CIJ_REG),2 + + + la \LV2,0(\LV1,\LDC_BYTE_ORIGINAL ) +#if !defined(TRMMKERNEL) + vl %v16,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vl %v17,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vmrhf %v2,%v16,%v16 + vmrhf %v4,%v17,%v17 + vmrlf %v3,%v16,%v16 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v17,%v17 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v20,%v21,%v22,%v23 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v2, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v3, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v3, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v4, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v4, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v5, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v5, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + + #if !defined(TRMMKERNEL) + vl %v17,0(\CIJ_REG,\LV1) + vl %v18,16(\CIJ_REG,\LV1) + vmrhf %v2,%v17,%v17 + vmrhf %v4,%v18,%v18 + vmrlf %v3,%v17,%v17 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v18,%v18 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v24,%v25,%v26,%v27 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG,\LV1),0 + vstef %v2, 4(\CIJ_REG,\LV1),2 + vstef %v3, 8(\CIJ_REG,\LV1),0 + vstef %v3, 12(\CIJ_REG,\LV1),2 + vstef %v4, 16(\CIJ_REG,\LV1),0 + vstef %v4, 20(\CIJ_REG,\LV1),2 + vstef %v5, 24(\CIJ_REG,\LV1),0 + vstef %v5, 28(\CIJ_REG,\LV1),2 + +#if !defined(TRMMKERNEL) + vl %v16,0(\CIJ_REG,\LV2) + vl %v17,16(\CIJ_REG,\LV2) + vmrhf %v2,%v16,%v16 + vmrhf %v4,%v17,%v17 + vmrlf %v3,%v16,%v16 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v17,%v17 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v28,%v29,%v30,%v31 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG,\LV2),0 + vstef %v2, 4(\CIJ_REG,\LV2),2 + vstef %v3, 8(\CIJ_REG,\LV2),0 + vstef %v3, 12(\CIJ_REG,\LV2),2 + vstef %v4, 16(\CIJ_REG,\LV2),0 + vstef %v4, 20(\CIJ_REG,\LV2),2 + vstef %v5, 24(\CIJ_REG,\LV2),0 + vstef %v5, 28(\CIJ_REG,\LV2),2 + + la \CIJ_REG,N8(\CIJ_REG) + +.endm + +.macro STORE_8x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG) + vl %v1 , 16(\CIJ_REG) + vmrhf %v2,%v5,%v5 + vmrhf %v4,%v1,%v1 + vmrlf %v3,%v5,%v5 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v1,%v1 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v16,%v17,%v18,%v19 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG),0 + vstef %v2, 4(\CIJ_REG),2 + vstef %v3, 8(\CIJ_REG),0 + vstef %v3, 12(\CIJ_REG),2 + vstef %v4, 16(\CIJ_REG),0 + vstef %v4, 20(\CIJ_REG),2 + vstef %v5, 24(\CIJ_REG),0 + vstef %v5, 28(\CIJ_REG),2 + +#if !defined(TRMMKERNEL) + vl %v16,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vl %v17,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vmrhf %v2,%v16,%v16 + vmrhf %v4,%v17,%v17 + vmrlf %v3,%v16,%v16 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v17,%v17 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v20,%v21,%v22,%v23 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v2, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v3, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v3, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v4, 16(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v4, 20(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + vstef %v5, 24(\CIJ_REG,\LDC_BYTE_ORIGINAL),0 + vstef %v5, 28(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + + la \CIJ_REG,N8(\CIJ_REG) + +.endm + +.macro STORE_8x1 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG) + vl %v1 , 16(\CIJ_REG) + vmrhf %v2,%v5,%v5 + vmrhf %v4,%v1,%v1 + vmrlf %v3,%v5,%v5 + vldeb %v2, %v2 + vldeb %v3, %v3 + vldeb %v4, %v4 + vmrlf %v5,%v1,%v1 + vldeb %v5, %v5 +#endif + Multiply_8x1 %v2,%v3,%v4,%v5, %v16,%v17,%v18,%v19 ,\ALPHA_VECREG + vledb %v2, %v2,0,0 + vledb %v3, %v3,0,0 + vledb %v4, %v4,0,0 + vledb %v5, %v5,0,0 + vstef %v2, 0(\CIJ_REG),0 + vstef %v2, 4(\CIJ_REG),2 + vstef %v3, 8(\CIJ_REG),0 + vstef %v3, 12(\CIJ_REG),2 + vstef %v4, 16(\CIJ_REG),0 + vstef %v4, 20(\CIJ_REG),2 + vstef %v5, 24(\CIJ_REG),0 + vstef %v5, 28(\CIJ_REG),2 + + la \CIJ_REG,N8(\CIJ_REG) +.endm + + +.macro STORE_4x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL, LV1 ,LV2 + la \LV1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG) + vmrhf %v1,%v5,%v5 + vmrlf %v2,%v5,%v5 + vldeb %v1, %v1 + vldeb %v2, %v2 + +#endif + Multiply_4x1 %v1,%v2 , %v16,%v17 ,\ALPHA_VECREG + vledb %v1, %v1,0,0 + vledb %v2, %v2,0,0 + vstef %v1, 0(\CIJ_REG),0 + vstef %v1, 4(\CIJ_REG),2 + vstef %v2, 8(\CIJ_REG),0 + vstef %v2, 12(\CIJ_REG),2 + + la \LV2,0(\LV1,\LDC_BYTE_ORIGINAL ) +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL ) + vmrhf %v16,%v5,%v5 + vmrlf %v17,%v5,%v5 + vldeb %v16, %v16 + vldeb %v17, %v17 +#endif + Multiply_4x1 %v16,%v17 , %v20,%v21 ,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vledb %v2, %v17,0,0 + vstef %v1, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL ),0 + vstef %v1, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + vstef %v2, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL ),0 + vstef %v2, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + + #if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG,\LV1 ) + vmrhf %v16,%v5,%v5 + vmrlf %v17,%v5,%v5 + vldeb %v16, %v16 + vldeb %v17, %v17 +#endif + Multiply_4x1 %v16,%v17 , %v24,%v25 ,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vledb %v2, %v17,0,0 + vstef %v1, 0(\CIJ_REG,\LV1 ),0 + vstef %v1, 4(\CIJ_REG,\LV1 ),2 + vstef %v2, 8(\CIJ_REG,\LV1 ),0 + vstef %v2, 12(\CIJ_REG,\LV1 ),2 + +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG,\LV2 ) + vmrhf %v16,%v5,%v5 + vmrlf %v17,%v5,%v5 + vldeb %v16, %v16 + vldeb %v17, %v17 +#endif + Multiply_4x1 %v16,%v17, %v28,%v29 ,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vledb %v2, %v17,0,0 + vstef %v1, 0(\CIJ_REG,\LV2 ),0 + vstef %v1, 4(\CIJ_REG,\LV2 ),2 + vstef %v2, 8(\CIJ_REG,\LV2 ),0 + vstef %v2, 12(\CIJ_REG,\LV2 ),2 + + la \CIJ_REG,N4(\CIJ_REG) + +.endm + + +.macro STORE_4x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG) + vmrhf %v1,%v5,%v5 + vmrlf %v2,%v5,%v5 + vldeb %v1, %v1 + vldeb %v2, %v2 + +#endif + Multiply_4x1 %v1,%v2 , %v16,%v17 ,\ALPHA_VECREG + vledb %v1, %v1,0,0 + vledb %v2, %v2,0,0 + vstef %v1, 0(\CIJ_REG),0 + vstef %v1, 4(\CIJ_REG),2 + vstef %v2, 8(\CIJ_REG),0 + vstef %v2, 12(\CIJ_REG),2 + +#if !defined(TRMMKERNEL) + vl %v5, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL ) + vmrhf %v16,%v5,%v5 + vmrlf %v17,%v5,%v5 + vldeb %v16, %v16 + vldeb %v17, %v17 +#endif + Multiply_4x1 %v16,%v17 , %v20,%v21 ,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vledb %v2, %v17,0,0 + vstef %v1, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL ),0 + vstef %v1, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + vstef %v2, 8(\CIJ_REG,\LDC_BYTE_ORIGINAL ),0 + vstef %v2, 12(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + + + la \CIJ_REG,N4(\CIJ_REG) + +.endm + +.macro STORE_4x1 ALPHA_FLOAT,CIJ_REG , LDC_BYTE_ORIGINAL + ledbr %f7,\ALPHA_FLOAT +#if defined(TRMMKERNEL) + meebr %f1,%f7 + meebr %f2,%f7 + meebr %f3,%f7 + meebr %f4,%f7 + ste %f1,0(\CIJ_REG) + ste %f2,4(\CIJ_REG ) + ste %f3,8(\CIJ_REG ) + ste %f4,12(\CIJ_REG) +#else + le %f5,0(\CIJ_REG) + maebr %f5,%f1,%f7 + ste %f5,0(\CIJ_REG) + + + le %f6,4(\CIJ_REG ) + maebr %f6,%f2,%f7 + ste %f6,4(\CIJ_REG ) + + le %f5,8(\CIJ_REG) + maebr %f5,%f3,%f7 + ste %f5,8(\CIJ_REG) + + le %f6,12(\CIJ_REG) + maebr %f6,%f4,%f7 + ste %f6,12(\CIJ_REG) +#endif + + la \CIJ_REG,N4(\CIJ_REG) + +.endm + +.macro STORE_2x2 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL + +#if !defined(TRMMKERNEL) + vlef %v1,0(\CIJ_REG) ,0 + vlef %v1,4(\CIJ_REG) ,2 + vldeb %v1,%v1 + +#endif + Multiply_2x1 %v1, %v16,\ALPHA_VECREG + vledb %v1, %v1,0,0 + vstef %v1, 0(\CIJ_REG),0 + vstef %v1, 4(\CIJ_REG),2 + +#if !defined(TRMMKERNEL) + vlef %v16,0(\CIJ_REG,\LDC_BYTE_ORIGINAL ) ,0 + vlef %v16,4(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + vldeb %v16,%v16 +#endif + Multiply_2x1 %v16, %v20,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vstef %v1, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL ),0 + vstef %v1, 4(\CIJ_REG,\LDC_BYTE_ORIGINAL ),2 + + la \CIJ_REG,N2(\CIJ_REG) + +.endm + + +.macro STORE_2x1 ALPHA_FLOAT,CIJ_REG , LDC_BYTE_ORIGINAL + ledbr %f3,\ALPHA_FLOAT +#if defined(TRMMKERNEL) + meebr %f1,%f3 + meebr %f2,%f3 + ste %f1,0(\CIJ_REG) + ste %f2,4(\CIJ_REG) +#else + le %f4,0(\CIJ_REG) + le %f5,4(\CIJ_REG) + maebr %f4,%f1,%f3 + maebr %f5,%f2,%f3 + ste %f4,0(\CIJ_REG) + ste %f5,4(\CIJ_REG) +#endif + + la \CIJ_REG,N2(\CIJ_REG) +.endm + + +/*STORE C1X1*/ +.macro STORE_1x1 ALPHA_FLOAT,CIJ_REG,LDC_BYTE_ORIGINAL + ledbr %f3,\ALPHA_FLOAT +#if defined(TRMMKERNEL) + meebr %f1,%f3 + ste %f1,0(\CIJ_REG) +#else + le %f2,0(\CIJ_REG) + maebr %f2,%f1,%f3 + ste %f2,0(\CIJ_REG) +#endif + la \CIJ_REG,N1(\CIJ_REG) +.endm + +/*reversed ones*/ + +.macro STORE_2x4 ALPHA_VECREG,CIJ_REG , LDC_BYTE_ORIGINAL , LV1 ,LV2 +#if !defined(TRMMKERNEL) + vlef %v1,0(\CIJ_REG) ,0 + vlef %v1,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) ,2 + vldeb %v1,%v1 +#endif + la \LV1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + Multiply_2x1 %v1, %v16 ,\ALPHA_VECREG + + la \LV2,0(\LV1,\LDC_BYTE_ORIGINAL ) + vledb %v1, %v1,0,0 + vstef %v1, 0(\CIJ_REG),0 + vstef %v1, 0(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + +#if !defined(TRMMKERNEL) + vlef %v16,0(\CIJ_REG,\LV1 ) ,0 + vlef %v16,0(\CIJ_REG,\LV2 ),2 + vldeb %v16,%v16 +#endif + Multiply_2x1 %v16, %v17,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vstef %v1, 0(\CIJ_REG ,\LV1 ),0 + vstef %v1, 0(\CIJ_REG,\LV2 ),2 +/*2nd*/ +#if !defined(TRMMKERNEL) + vlef %v1,4(\CIJ_REG) ,0 + vlef %v1,4(\CIJ_REG,\LDC_BYTE_ORIGINAL) ,2 + vldeb %v1,%v1 + +#endif + Multiply_2x1 %v1, %v20 ,\ALPHA_VECREG + vledb %v1, %v1,0,0 + vstef %v1, 4(\CIJ_REG),0 + vstef %v1,4(\CIJ_REG,\LDC_BYTE_ORIGINAL),2 + +#if !defined(TRMMKERNEL) + vlef %v16,4(\CIJ_REG,\LV1 ) ,0 + vlef %v16,4(\CIJ_REG,\LV2 ),2 + vldeb %v16,%v16 +#endif + Multiply_2x1 %v16, %v21,\ALPHA_VECREG + vledb %v1, %v16,0,0 + vstef %v1, 4(\CIJ_REG ,\LV1 ),0 + vstef %v1, 4(\CIJ_REG,\LV2 ),2 + + la \CIJ_REG,N2(\CIJ_REG) + +.endm + +.macro STORE_1x4 ALPHA_FLOAT,CIJ_REG , LDC_BYTE_ORIGINAL , LV1 ,LV2 + + la \LV1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + ledbr %f7,\ALPHA_FLOAT + la \LV2,0(\LV1,\LDC_BYTE_ORIGINAL ) +#if defined(TRMMKERNEL) + meebr %f1,%f7 + meebr %f2,%f7 + meebr %f3,%f7 + meebr %f4,%f7 + ste %f1,0(\CIJ_REG) + ste %f2,0(\CIJ_REG, \LDC_BYTE_ORIGINAL) + ste %f3,0(\CIJ_REG, \LV1) + ste %f4,0(\CIJ_REG, \LV2) +#else + le %f5,0(\CIJ_REG) + maebr %f5,%f1,%f7 + ste %f5,0(\CIJ_REG) + + le %f6,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + maebr %f6,%f2,%f7 + ste %f6,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + le %f5,0(\CIJ_REG, \LV1) + maebr %f5,%f3,%f7 + ste %f5,0(\CIJ_REG, \LV1) + + le %f6,0(\CIJ_REG, \LV2) + maebr %f6,%f4,%f7 + ste %f6,0(\CIJ_REG, \LV2) +#endif + + la \CIJ_REG,N1(\CIJ_REG) + +.endm + + .macro STORE_1x2 ALPHA_FLOAT,CIJ_REG , LDC_BYTE_ORIGINAL + ledbr %f3,\ALPHA_FLOAT +#if defined(TRMMKERNEL) + meebr %f1,%f3 + meebr %f2,%f3 + ste %f1,0(\CIJ_REG) + ste %f2,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) +#else + le %f4,0(\CIJ_REG) + maebr %f4,%f1,%f3 + ste %f4,0(\CIJ_REG) + + le %f5,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + maebr %f5,%f2,%f3 + ste %f5,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) +#endif + + + la \CIJ_REG,N1(\CIJ_REG) + +.endm + + + + +/****************************TRMM POINTER REFRESH MACROSES*************************/ + +.macro RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B + #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /* ptrbb = bb;*/ + lgr \PTR_B,\B_VAL /*refresh BPOINT*/ + + #else + /* ptrba =ptrba+ off*C_A; + ptrbb = bb + off*C_B;*/ +.if \C_B==4 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*4*/ + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_B, \PTR_B + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,2 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,4 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==2 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*8**/ + sllg \PTR_B, \OFF_VAL,3 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,3 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,3 + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,2 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_B,\PTR_B /* off+off**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==1 + .if \C_A==8 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*8**/ + sllg \PTR_B, \OFF_VAL,2 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==4 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,2 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,2 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,2 + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif +.endif + + + #endif +.endm + +/**/ +.macro RefreshTempBk TEMP_VAL,BK_VAL,OFF_VAL,INCR_A,INCR_B + #if (defined(LEFT) && !defined(TRANSA)) || (!defined(LEFT) && defined(TRANSA)) + /* temp = bk-off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + + #elif defined(LEFT) + /* temp = off+INCR_A; // number of values in A */ + la \TEMP_VAL,\INCR_A(\OFF_VAL) + #else + /* temp = off+INCR_B // number of values in B*/ + la \TEMP_VAL,\INCR_B(\OFF_VAL) + #endif + +.endm + + +.macro RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,PTR_B,PTR_A,C_A,C_B + + #if ( defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /*temp = bk - off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + #ifdef LEFT + /*temp -= 8; // number of values in A*/ + lay \TEMP_VAL,-\C_A(\TEMP_VAL) + #else + /*temp -= 4; // number of values in B*/ + lay \TEMP_VAL,-\C_B(\TEMP_VAL) + #endif + /*ptrba += temp*C_A; + ptrbb += temp*C_B;*/ + .if \C_A==8 + sllg \TEMP_VAL, \TEMP_VAL,5 + .elseif \C_A==4 + sllg \TEMP_VAL, \TEMP_VAL,4 /*temp*4*/ + .elseif \C_A==2 + sllg \TEMP_VAL, \TEMP_VAL,3 /*temp*2*/ + .elseif \C_A==1 + sllg \TEMP_VAL, \TEMP_VAL,2 /*temp*1*/ + .endif + la \PTR_A,0(\PTR_A,\TEMP_VAL) /*ptrba+temp*C_A*/ + /*we do not need to refresh ptrbb. so lets ignore it*/ + + #endif + + #ifdef LEFT + /*off += 8; // number of values in A*/ + aghi \OFF_VAL,\C_A + #endif +.endm \ No newline at end of file diff --git a/kernel/zarch/strmm8x4V.S b/kernel/zarch/strmm8x4V.S new file mode 100644 index 0000000000..f8e7481670 --- /dev/null +++ b/kernel/zarch/strmm8x4V.S @@ -0,0 +1,855 @@ +/*************************************************************************** +Copyright (c) 2013-2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +/************************************************************************************** +* 2017/03/01 AbdelRauf (quickwritereader@gmail.com) +* BLASTEST : passed +* CTEST : passed +* TEST : passed +**************************************************************************************/ + +/*********************************************************************/ +/* Copyright 2009, 2010 The University of Texas at Austin. */ +/* All rights reserved. */ +/* */ +/* Redistribution and use in source and binary forms, with or */ +/* without modification, are permitted provided that the following */ +/* conditions are met: */ +/* */ +/* 1. Redistributions of source code must retain the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer. */ +/* */ +/* 2. Redistributions in binary form must reproduce the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer in the documentation and/or other materials */ +/* provided with the distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, */ +/* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF */ +/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE */ +/* DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ +/* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES */ +/* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE */ +/* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR */ +/* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF */ +/* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT */ +/* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ +/* POSSIBILITY OF SUCH DAMAGE. */ +/* */ +/* The views and conclusions contained in the software and */ +/* documentation are those of the authors and should not be */ +/* interpreted as representing official policies, either expressed */ +/* or implied, of The University of Texas at Austin. */ +/*********************************************************************/ + +#define ASSEMBLER +#include "common.h" + + +/* + +#BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc + ##bm=r2,bn=r3, bk=r4, alpha=f0,ba=r5,bb=r6,stack[160] ,ldc=stack[168] +offset=stack[176] +**********************************************************************************************/ +/*Note: r0 can not be used as address disp register */ + +#define BM %r2 +#define BM_CUR %r0 +#define BN %r3 +#define BN_CUR %r10 +#define BK %r4 +#define LDC_BYTE %r8 +#define ALPHA %f0 +#define ALPHA_VECT %v0 +#define LOCAL_VAR1 %r9 +#define LOCAL_VAR2 %r1 +#define LOCAL_VAR3 %r11 +#define A %r5 +#define B %r6 +#define CIJ %r7 +#define CIJ_LOCAL %r12 +#define OFF %r13 +#define OFFSET %f8 +#define ALIGN_4 .align 16 +#define ALIGN_2 .align 8 +#define PREFETCH_INS 1 + +/**************************Include kernel helper macrosses**********************************/ +#include "skernelMacros.S" + + + +/***********************************DGEMM***********************************************************/ + +PROLOGUE +#if defined(TRMMKERNEL) + std OFFSET,40(%r15) + stmg %r6,%r13,48(%r15) +#else + stmg %r6,%r12,48(%r15) +#endif +lg CIJ, 160(%r15) +lg LOCAL_VAR1, 168(%r15) +#if defined(TRMMKERNEL) +lg OFF,176(%r15) +ldgr OFFSET ,OFF +#endif +srlg BN_CUR,BN,2 +vrepf ALPHA_VECT,ALPHA_VECT,0 /*replicate alpha which in f0*/ +vldeb ALPHA_VECT,ALPHA_VECT + +sllg LDC_BYTE, LOCAL_VAR1,2 /*calculate lcd stride with bytes float=4 x<<2 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + /*off = -offset;*/ + lgdr LOCAL_VAR1,OFFSET + lcgr OFF,LOCAL_VAR1 +#endif +cijle BN_CUR,0,.LX2 + +ALIGN_4 +.LX4_BN: +#if defined(PREFETCH_INS) + pfd 1, 0(A) + pfd 1, 0(B) +#endif +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x4 +ALIGN_4 +.L8x4_BM: /*BM_CUR LOOP */ + +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,4 + + RefreshTempBk LOCAL_VAR1,BK,OFF,8,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif + +ZERO_CVEC_8x4 +cijle LOCAL_VAR1,0,.L8x4_mod + + +ALIGN_4 +.L8x4_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + CALC_8x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 128(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L8x4_4_BK + +ALIGN_4 +.L8x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x4_BK_Store + +ALIGN_4 +.L8x4_BK: /*BK_CUR LOOP */ + CALC_8x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x4_BK + +ALIGN_4 +.L8x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x4 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE , LOCAL_VAR1 ,LOCAL_VAR2 +#if defined(TRMMKERNEL) + /*RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,L_VAR,PTR_A,C_A*/ + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,4 +#endif +brctg BM_CUR,.L8x4_BM + +ALIGN_4 +.L4x4: + +tmll BM,4 +jz .L2x4 + +ALIGN_4 +.L4x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x4 +cijle LOCAL_VAR1,0,.L4x4_mod + +ALIGN_4 +.L4x4_4_BK: /*BK_CUR LOOP */ + CALC_4x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_4_BK + +ALIGN_4 +.L4x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + nill LOCAL_VAR1,3 +#else + la LOCAL_VAR1,3(0,0) + NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x4_BK_Store + +ALIGN_4 +.L4x4_BK: /*BK_CUR LOOP */ + CALC_4x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_BK + +ALIGN_4 +.L4x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE , LOCAL_VAR1 ,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,4 +#endif +ALIGN_2 +.L2x4: + +tmll BM,2 +jz .L1x4 + +ALIGN_4 +.L2x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,4 + + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x4 +cijle LOCAL_VAR1,0,.L2x4_mod + +ALIGN_4 +.L2x4_4_BK: /*BK_CUR LOOP */ + CALC_2x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_4_BK + +ALIGN_4 +.L2x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x4_BK_Store + +ALIGN_4 +.L2x4_BK: /*BK_CUR LOOP */ + CALC_2x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_BK + +ALIGN_4 +.L2x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE , LOCAL_VAR1 ,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,4 +#endif + +ALIGN_4 +.L1x4: + +tmll BM,1 +jz .Lx4_INNER_END + +ALIGN_4 +.L1x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x4 +cijle LOCAL_VAR1,0,.L1x4_mod + +ALIGN_4 +.L1x4_4_BK: /*BK_CUR LOOP */ + CALC_1x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_4_BK + +ALIGN_4 +.L1x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x4_BK_Store + +ALIGN_4 +.L1x4_BK: /*BK_CUR LOOP */ + CALC_1x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_BK + +ALIGN_4 +.L1x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x4 ALPHA ,CIJ_LOCAL, LDC_BYTE , LOCAL_VAR1 ,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,4 +#endif +ALIGN_2 +.Lx4_INNER_END: + + +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR1,LDC_BYTE,2 /*op*4 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,4 +#endif +sllg LOCAL_VAR2,BK,4 /*op*4*sizeof(float) =op*16* 2**4 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(float) */ + +brctg BN_CUR,.LX4_BN + +/*********************************X2 SECTION************************************************/ +ALIGN_4 +.LX2: +tmll BN,2 +jz .Lx1 + +ALIGN_4 +.Lx2_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif + +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x2 + + +ALIGN_4 +.L8x2_BM: /*BM_CUR LOOP */ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,8,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_8x2 +cijle LOCAL_VAR1,0,.L8x2_mod + +ALIGN_4 +.L8x2_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + CALC_8x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_4_BK + +ALIGN_4 +.L8x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x2_BK_Store + +ALIGN_4 +.L8x2_BK: /*BK_CUR LOOP */ + CALC_8x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_BK + +ALIGN_4 +.L8x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x2 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,2 +#endif +ALIGN_4 +brctg BM_CUR,.L8x2_BM + +ALIGN_2 +.L4x2: + +tmll BM,4 +jz .L2x2 + +ALIGN_4 +.L4x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x2 +cijle LOCAL_VAR1,0,.L4x2_mod + +ALIGN_4 +.L4x2_4_BK: /*BK_CUR LOOP */ + CALC_4x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_4_BK + +ALIGN_4 +.L4x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x2_BK_Store + +ALIGN_4 +.L4x2_BK: /*BK_CUR LOOP */ + CALC_4x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_BK + +ALIGN_4 +.L4x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,2 +#endif +ALIGN_2 +.L2x2: + +tmll BM,2 +jz .L1x2 + +ALIGN_4 +.L2x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x2 +cijle LOCAL_VAR1,0,.L2x2_mod + +ALIGN_4 +.L2x2_4_BK: /*BK_CUR LOOP */ + CALC_2x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_4_BK + +ALIGN_4 +.L2x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x2_BK_Store + +ALIGN_4 +.L2x2_BK: /*BK_CUR LOOP */ + CALC_2x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_BK + +ALIGN_4 +.L2x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,2 +#endif + +ALIGN_2 +.L1x2: + +tmll BM,1 +jz .Lx2_INNER_END + +ALIGN_4 +.L1x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x2 +cijle LOCAL_VAR1,0,.L1x2_mod + +ALIGN_4 +.L1x2_4_BK: /*BK_CUR LOOP */ + CALC_1x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_4_BK + +ALIGN_4 +.L1x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x2_BK_Store + +ALIGN_4 +.L1x2_BK: /*BK_CUR LOOP */ + CALC_1x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_BK + +ALIGN_4 +.L1x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x2 ALPHA ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,2 +#endif +ALIGN_2 +.Lx2_INNER_END: +/*add LDC_BYTE_COPY to new*/ +la LOCAL_VAR1,0(LDC_BYTE,LDC_BYTE) /*op*2 */ +sllg LOCAL_VAR2,BK,3 /*op*2*sizeof(float) =op*8 2**3 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,2 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(float) */ + + + + +/*********************************X1 SECTION************************************************/ +ALIGN_2 +.Lx1: +tmll BN,1 +jz .L_FUNC_END + +ALIGN_4 +.Lx1_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x1 + + +ALIGN_4 +.L8x1_BM: /*BM_CUR LOOP */ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,8,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_8x1 +cijle LOCAL_VAR1,0,.L8x1_mod + +ALIGN_4 +.L8x1_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + CALC_8x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_4_BK + +ALIGN_4 +.L8x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x1_BK_Store + +ALIGN_4 +.L8x1_BK: /*BK_CUR LOOP */ + CALC_8x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_BK + +ALIGN_4 +.L8x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x1 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,1 +#endif +ALIGN_4 +brctg BM_CUR,.L8x1_BM + +ALIGN_2 +.L4x1: + +tmll BM,4 +jz .L2x1 + +ALIGN_4 +.L4x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x1 +cijle LOCAL_VAR1,0,.L4x1_mod + +ALIGN_4 +.L4x1_4_BK: /*BK_CUR LOOP */ + CALC_4x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_4_BK + +ALIGN_4 +.L4x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x1_BK_Store + +ALIGN_4 +.L4x1_BK: /*BK_CUR LOOP */ + CALC_4x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_BK + +ALIGN_4 +.L4x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x1 ALPHA ,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,1 +#endif +ALIGN_2 +.L2x1: + +tmll BM,2 +jz .L1x1 + +ALIGN_4 +.L2x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x1 +cijle LOCAL_VAR1,0,.L2x1_mod + +ALIGN_4 +.L2x1_4_BK: /*BK_CUR LOOP */ + CALC_2x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_4_BK + +ALIGN_4 +.L2x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x1_BK_Store + +ALIGN_4 +.L2x1_BK: /*BK_CUR LOOP */ + CALC_2x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_BK + +ALIGN_4 +.L2x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x1 ALPHA ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,1 +#endif + +ALIGN_2 +.L1x1: + +tmll BM, 1 +jz .Lx1_INNER_END + +ALIGN_4 +.L1x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x1 +cijle LOCAL_VAR1,0,.L1x1_mod + +ALIGN_4 +.L1x1_4_BK: /*BK_CUR LOOP */ + CALC_1x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_4_BK + +ALIGN_4 +.L1x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x1_BK_Store + +ALIGN_4 +.L1x1_BK: /*BK_CUR LOOP */ + CALC_1x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_BK + +ALIGN_4 +.L1x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x1 ALPHA ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,1 +#endif +ALIGN_2 +.Lx1_INNER_END: +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR2,BK,2 /*op*1*sizeof(float) =op*4 2**2 */ +la CIJ,0(CIJ,LDC_BYTE) /*refresh CIJ=CIJ+LDC_BYTE */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,1 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*1*sizeof(float) */ + + +ALIGN_2 +.L_FUNC_END: +/*end*/ +#if defined(TRMMKERNEL) + ld OFFSET,40(%r15) + lmg %r6,%r13,48(%r15) +#else + lmg %r6,%r12,48(%r15) +#endif +br %r14 +.end + + + + + + + diff --git a/kernel/zarch/trmm8x4V.S b/kernel/zarch/trmm8x4V.S new file mode 100644 index 0000000000..4da113ff30 --- /dev/null +++ b/kernel/zarch/trmm8x4V.S @@ -0,0 +1,874 @@ +/*************************************************************************** +Copyright (c) 2013-2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +/************************************************************************************** +* 2017/01/01 AbdelRauf (quickwritereader@gmail.com) +* BLASTEST : OK +* CTEST : OK +* TEST : OK +**************************************************************************************/ + +/*********************************************************************/ +/* Copyright 2009, 2010 The University of Texas at Austin. */ +/* All rights reserved. */ +/* */ +/* Redistribution and use in source and binary forms, with or */ +/* without modification, are permitted provided that the following */ +/* conditions are met: */ +/* */ +/* 1. Redistributions of source code must retain the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer. */ +/* */ +/* 2. Redistributions in binary form must reproduce the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer in the documentation and/or other materials */ +/* provided with the distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, */ +/* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF */ +/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE */ +/* DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ +/* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES */ +/* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE */ +/* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR */ +/* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF */ +/* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT */ +/* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ +/* POSSIBILITY OF SUCH DAMAGE. */ +/* */ +/* The views and conclusions contained in the software and */ +/* documentation are those of the authors and should not be */ +/* interpreted as representing official policies, either expressed */ +/* or implied, of The University of Texas at Austin. */ +/*********************************************************************/ + +#define ASSEMBLER +#include "common.h" + + +/* + +#BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alpha,FLOAT* ba,FLOAT* bb,FLOAT* C,BLASLONG ldc + ##bm=r2,bn=r3, bk=r4, alpha=f0,ba=r5,bb=r6,stack[160] ,ldc=stack[168] +offset=stack[176] +**********************************************************************************************/ +/*Note: r0 can not be used as address disp register */ + +#define BM %r2 +#define BM_CUR %r0 +#define BN %r3 +#define BN_CUR %r10 +#define BK %r4 +#define LDC_BYTE %r8 +#define ALPHA %f0 +#define ALPHA_VECT %v0 +#define LOCAL_VAR1 %r9 +#define LOCAL_VAR2 %r1 +#define LOCAL_VAR3 %r11 +#define A %r5 +#define B %r6 +#define CIJ %r7 +#define CIJ_LOCAL %r12 +#define OFF %r13 +#define OFFSET %f8 +#define ALIGN_4 .align 16 +#define ALIGN_2 .align 8 +#define PREFETCH_INS 1 + +/**************************Include kernel helper macrosses**********************************/ +#include "kernelMacros.S" + +#if defined (TRMMKERNEL) + +#define STORE_8x4 STORE_TRMM_8x4 +#define STORE_4x4 STORE_TRMM_4x4 +#define STORE_2x4 STORE_TRMM_2x4 +#define STORE_1x4 STORE_TRMM_1x4 + +#define STORE_8x2 STORE_TRMM_8x2 +#define STORE_4x2 STORE_TRMM_4x2 +#define STORE_2x2 STORE_TRMM_2x2 +#define STORE_1x2 STORE_TRMM_1x2 + +#define STORE_8x1 STORE_TRMM_8x1 +#define STORE_4x1 STORE_TRMM_4x1 +#define STORE_2x1 STORE_TRMM_2x1 +#define STORE_1x1 STORE_TRMM_1x1 + +#endif + +/***********************************DGEMM***********************************************************/ + +PROLOGUE +#if defined(TRMMKERNEL) + std OFFSET,40(%r15) + stmg %r6,%r13,48(%r15) +#else + stmg %r6,%r12,48(%r15) +#endif +lg CIJ, 160(%r15) +lg LOCAL_VAR1, 168(%r15) +#if defined(TRMMKERNEL) +lg OFF,176(%r15) +ldgr OFFSET ,OFF +#endif +srlg BN_CUR,BN,2 +vrepg ALPHA_VECT,ALPHA_VECT,0 /*replicate alpha which in f0*/ + +sllg LDC_BYTE, LOCAL_VAR1,3 /*calculate lcd stride with bytes double=8 x<<3 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + /*off = -offset;*/ + lgdr LOCAL_VAR1,OFFSET + lcgr OFF,LOCAL_VAR1 +#endif +cijle BN_CUR,0,.LX2 + +ALIGN_4 +.LX4_BN: +#if defined(PREFETCH_INS) + pfd 1, 0(A) + pfd 1, 256(A) + pfd 1, 0(B) + pfd 1, 256(B) +#endif +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x4 +ALIGN_4 +.L8x4_BM: /*BM_CUR LOOP */ + +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,4 + + RefreshTempBk LOCAL_VAR1,BK,OFF,8,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif + +ZERO_CVEC_8x4 +cijle LOCAL_VAR1,0,.L8x4_mod + + +ALIGN_4 +.L8x4_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 512(LOCAL_VAR3) +#endif + CALC_8x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 512(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L8x4_4_BK + +ALIGN_4 +.L8x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x4_BK_Store + +ALIGN_4 +.L8x4_BK: /*BK_CUR LOOP */ + CALC_8x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x4_BK + +ALIGN_4 +.L8x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x4 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + /*RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,L_VAR,PTR_A,C_A*/ + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,4 +#endif +brctg BM_CUR,.L8x4_BM + +ALIGN_4 +.L4x4: + +tmll BM,4 +jz .L2x4 + +ALIGN_4 +.L4x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x4 +cijle LOCAL_VAR1,0,.L4x4_mod + +ALIGN_4 +.L4x4_4_BK: /*BK_CUR LOOP */ + CALC_4x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_4_BK + +ALIGN_4 +.L4x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + nill LOCAL_VAR1,3 +#else + la LOCAL_VAR1,3(0,0) + NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x4_BK_Store + +ALIGN_4 +.L4x4_BK: /*BK_CUR LOOP */ + CALC_4x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_BK + +ALIGN_4 +.L4x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,4 +#endif +ALIGN_2 +.L2x4: + +tmll BM,2 +jz .L1x4 + +ALIGN_4 +.L2x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,4 + + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x4 +cijle LOCAL_VAR1,0,.L2x4_mod + +ALIGN_4 +.L2x4_4_BK: /*BK_CUR LOOP */ + CALC_2x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_4_BK + +ALIGN_4 +.L2x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x4_BK_Store + +ALIGN_4 +.L2x4_BK: /*BK_CUR LOOP */ + CALC_2x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_BK + +ALIGN_4 +.L2x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,4 +#endif + +ALIGN_4 +.L1x4: + +tmll BM,1 +jz .Lx4_INNER_END + +ALIGN_4 +.L1x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x4 +cijle LOCAL_VAR1,0,.L1x4_mod + +ALIGN_4 +.L1x4_4_BK: /*BK_CUR LOOP */ + CALC_1x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_4_BK + +ALIGN_4 +.L1x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x4_BK_Store + +ALIGN_4 +.L1x4_BK: /*BK_CUR LOOP */ + CALC_1x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_BK + +ALIGN_4 +.L1x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x4 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,4 +#endif +ALIGN_2 +.Lx4_INNER_END: + + +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR1,LDC_BYTE,2 /*multiply*4 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,4 +#endif +sllg LOCAL_VAR2,BK,5 /*muyliply*4*sizeof(double) =multiply*32* 2**5 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(double) */ + +brctg BN_CUR,.LX4_BN + +/*********************************X2 SECTION************************************************/ +ALIGN_4 +.LX2: +tmll BN,2 +jz .Lx1 + +ALIGN_4 +.Lx2_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif + +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x2 + + +ALIGN_4 +.L8x2_BM: /*BM_CUR LOOP */ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,8,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_8x2 +cijle LOCAL_VAR1,0,.L8x2_mod + +ALIGN_4 +.L8x2_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) + pfd 1,64(LOCAL_VAR2) +#endif + CALC_8x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_4_BK + +ALIGN_4 +.L8x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x2_BK_Store + +ALIGN_4 +.L8x2_BK: /*BK_CUR LOOP */ + CALC_8x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x2_BK + +ALIGN_4 +.L8x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x2 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,2 +#endif +ALIGN_4 +brctg BM_CUR,.L8x2_BM + +ALIGN_2 +.L4x2: + +tmll BM,4 +jz .L2x2 + +ALIGN_4 +.L4x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x2 +cijle LOCAL_VAR1,0,.L4x2_mod + +ALIGN_4 +.L4x2_4_BK: /*BK_CUR LOOP */ + CALC_4x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_4_BK + +ALIGN_4 +.L4x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x2_BK_Store + +ALIGN_4 +.L4x2_BK: /*BK_CUR LOOP */ + CALC_4x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_BK + +ALIGN_4 +.L4x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,2 +#endif +ALIGN_2 +.L2x2: + +tmll BM,2 +jz .L1x2 + +ALIGN_4 +.L2x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x2 +cijle LOCAL_VAR1,0,.L2x2_mod + +ALIGN_4 +.L2x2_4_BK: /*BK_CUR LOOP */ + CALC_2x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_4_BK + +ALIGN_4 +.L2x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x2_BK_Store + +ALIGN_4 +.L2x2_BK: /*BK_CUR LOOP */ + CALC_2x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_BK + +ALIGN_4 +.L2x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,2 +#endif + +ALIGN_2 +.L1x2: + +tmll BM,1 +jz .Lx2_INNER_END + +ALIGN_4 +.L1x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x2 +cijle LOCAL_VAR1,0,.L1x2_mod + +ALIGN_4 +.L1x2_4_BK: /*BK_CUR LOOP */ + CALC_1x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_4_BK + +ALIGN_4 +.L1x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x2_BK_Store + +ALIGN_4 +.L1x2_BK: /*BK_CUR LOOP */ + CALC_1x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_BK + +ALIGN_4 +.L1x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x2 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,2 +#endif +ALIGN_2 +.Lx2_INNER_END: +/*add LDC_BYTE_COPY to new*/ +la LOCAL_VAR1,0(LDC_BYTE,LDC_BYTE) /*multiply*2 */ +sllg LOCAL_VAR2,BK,4 /*muyliply*2*sizeof(double) =multiply*16* 2**4 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,2 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(double) */ + + + + +/*********************************X1 SECTION************************************************/ +ALIGN_2 +.Lx1: +tmll BN,1 +jz .L_FUNC_END + +ALIGN_4 +.Lx1_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,3 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L4x1 + + +ALIGN_4 +.L8x1_BM: /*BM_CUR LOOP */ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,8,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,8,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_8x1 +cijle LOCAL_VAR1,0,.L8x1_mod + +ALIGN_4 +.L8x1_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + CALC_8x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_4_BK + +ALIGN_4 +.L8x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,8,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L8x1_BK_Store + +ALIGN_4 +.L8x1_BK: /*BK_CUR LOOP */ + CALC_8x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L8x1_BK + +ALIGN_4 +.L8x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_8x1 ALPHA_VECT,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,8,1 +#endif +ALIGN_4 +brctg BM_CUR,.L8x1_BM + +ALIGN_2 +.L4x1: + +tmll BM,4 +jz .L2x1 + +ALIGN_4 +.L4x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_4x1 +cijle LOCAL_VAR1,0,.L4x1_mod + +ALIGN_4 +.L4x1_4_BK: /*BK_CUR LOOP */ + CALC_4x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_4_BK + +ALIGN_4 +.L4x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x1_BK_Store + +ALIGN_4 +.L4x1_BK: /*BK_CUR LOOP */ + CALC_4x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_BK + +ALIGN_4 +.L4x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_4x1 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,4,1 +#endif +ALIGN_2 +.L2x1: + +tmll BM,2 +jz .L1x1 + +ALIGN_4 +.L2x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_2x1 +cijle LOCAL_VAR1,0,.L2x1_mod + +ALIGN_4 +.L2x1_4_BK: /*BK_CUR LOOP */ + CALC_2x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_4_BK + +ALIGN_4 +.L2x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x1_BK_Store + +ALIGN_4 +.L2x1_BK: /*BK_CUR LOOP */ + CALC_2x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_BK + +ALIGN_4 +.L2x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_2x1 ALPHA_VECT ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,2,1 +#endif + +ALIGN_2 +.L1x1: + +tmll BM, 1 +jz .Lx1_INNER_END + +ALIGN_4 +.L1x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_CVEC_1x1 +cijle LOCAL_VAR1,0,.L1x1_mod + +ALIGN_4 +.L1x1_4_BK: /*BK_CUR LOOP */ + CALC_1x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_4_BK + +ALIGN_4 +.L1x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x1_BK_Store + +ALIGN_4 +.L1x1_BK: /*BK_CUR LOOP */ + CALC_1x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_BK + +ALIGN_4 +.L1x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +STORE_1x1 ALPHA ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR2,LOCAL_VAR3,1,1 +#endif +ALIGN_2 +.Lx1_INNER_END: +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR2,BK,3 /*muyliply*2*sizeof(double) =multiply*8* 2**3 */ +la CIJ,0(CIJ,LDC_BYTE) /*refresh CIJ=CIJ+LDC_BYTE */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,1 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*1*sizeof(double) */ + + +ALIGN_2 +.L_FUNC_END: +/*end*/ +#if defined(TRMMKERNEL) + ld OFFSET,40(%r15) + lmg %r6,%r13,48(%r15) +#else + lmg %r6,%r12,48(%r15) +#endif +br %r14 +.end + + + + + + + diff --git a/kernel/zarch/zkernelMacrosV.S b/kernel/zarch/zkernelMacrosV.S new file mode 100644 index 0000000000..ae3b78fbc0 --- /dev/null +++ b/kernel/zarch/zkernelMacrosV.S @@ -0,0 +1,1335 @@ +/****************************************Implementation**Details**********************************************/ +/* */ +/* Lets denote (a,a1i) complex which is mathematically a+a1*i */ +/* Complex number multiplication: (a,a1i)*(b,b1i) */ +/* As i*i=-1 .The multiplication result will be: */ +/* (a+a1*i)(b+b1*i)=a*b+a1*i*b1*i+ a1*i*b+a*b1*i=a*b-a1*b1 + (a1*b+a*b1)*i which is (ab-a1b1,a1b+ab1) */ +/* so let c= ab-a1b1 , ci=a1b+ab1 then */ +/* c=c+a*b-a1*b1 => c=a*b-( a1*b1-c) => c= a1*b1-c then c=a*b-c two mseb */ +/* ci=ci+a1*b+a*b1 => ci= a1*b+ci then ci= a*b1+ci */ +/* For simd real and imaginary parts will be grouped together */ +/* such (realA,realK) and (imageA ,imageK) */ +/* Simd(0,1)=(a*b,k*b)-((ai*bi,ki*bi)-Simd(0,1)) */ +/* SimdI(0,1)=SimdI(0,1)+(a*bi,k*bi)+(ai*b,ki*b) */ +/* */ +/* */ +/* for defined(NR) || defined(NC) || defined(TR) || defined(TC) */ +/* (a+a1*I)(b-b1*I)=ab+a1*b1+I(a1b-ab1) */ +/* */ +/* c=c+ab+a1b1 => c=a1b1+c;c=ab+c */ +/* ci=ci+a1b-ab1 => ci=a1*b-(ab1-ci) => ci=ab1-ci; ci=a1*b-ci */ +/* */ +/* */ +/* for defined(RN) || defined(RT) || defined(CN) || defined(CT) */ +/* (a-a1*I)(b+b1*I)=ab+a1*b1+I(-a1b+ab1) */ +/* */ +/* c=c+ab+a1b1 => c=a1b1+c;c=ab+c */ +/* ci=ci+a1b-ab1 => ci=a*b1-(a1b-ci) => ci=a1b-ci; ci=a*b1-ci */ +/* */ +/* */ +/* for defined(RR) || defined(RC) || defined(CR) || defined(CC) */ +/* (a-a1*I)(b-b1*I)=ab-a1*b1+I(-a1b-ab1) */ +/* */ +/* c= a1*b1-c then c=a*b-c */ +/* ci = ci-a1*b -a*b1; */ +/* as ibm z13 only has x*z-m x*z+m instructions implementation will be changed a bit */ +/* Assuming ci=0; and cix=cix+a1b+ab1 ; ci=ci-cix will work */ +/* cix= a*b1+cix ; cix= a1*b+cix (two madb) ci=ci-cix (sign change if ci=0) */ +/* As c=0 then */ +/* c=a*b-c then c=a1*b1-c => c=(a1*b1-(a*b-c)) which is -1*( a*b -(a1*b1-c)) */ +/* */ +/* Values will be equal to (-c) and (-ci) */ +/* To change sign it'll be multiplied by -1*(alpha+alpha_i) */ +/* This is done once: */ +/* lcdbr ALPHA_I,ALPHA_I */ +/* lcdbr ALPHA ,ALPHA */ +/*************************************************************************************************************/ + +/*************************Zero vectors***************************************/ +/*zero vectors for 4x4 */ +.macro ZERO_ZCVEC_4x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 + vzero %v24 + vzero %v25 + vzero %v26 + vzero %v27 + vzero %v28 + vzero %v29 + vzero %v30 + vzero %v31 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 + vzero %v20 + vzero %v21 + vzero %v22 + vzero %v23 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_1x4 + vzero %v16 + vzero %v17 + vzero %v18 + vzero %v19 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_4x2 + ZERO_ZCVEC_2x4 +.endm + +.macro ZERO_ZCVEC_4x1 + ZERO_ZCVEC_1x4 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x2 + vzero %v16 + vzero %v17 + vzero %v20 + vzero %v21 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_1x2 + vzero %v16 + vzero %v17 +.endm + +/*zero vectors for */ +.macro ZERO_ZCVEC_2x1 + vzero %v16 + vzero %v17 +.endm + +/*zero vectors for 1x1*/ +.macro ZERO_ZCVEC_1x1 + lzdr %f6 + lzdr %f7 +.endm + + +/* + Calculate for 4x2 inner +*/ +.macro CalcComplex_4x2 vResR1, vResI1, vResR2, vResI2, vResR3, vResI3, vResR4, vResI4, vr1, vi1, vr2, vi2, vrB, viB,vrB2, viB2 + + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + + #endif + +.endm + +/* + Calculate for 2x4 inner +*/ +.macro CalcComplex_2x4 vResR1, vResI1, vResR2, vResI2, vResR3, vResI3, vResR4, vResI4, vr1, vi1, vr2, vi2, vrB, viB,vrB2, viB2 + + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vi1, \viB, \vResR1 + vfmsdb \vResI1, \vi1, \vrB, \vResI1 + vfmadb \vResR2, \vi2, \viB, \vResR2 + vfmsdb \vResI2, \vi2, \vrB, \vResI2 + + vfmadb \vResR3, \vi1, \viB2, \vResR3 + vfmsdb \vResI3, \vi1, \vrB2, \vResI3 + vfmadb \vResR4, \vi2, \viB2, \vResR4 + vfmsdb \vResI4, \vi2, \vrB2, \vResI4 + + vfmadb \vResR1, \vr1, \vrB, \vResR1 + vfmsdb \vResI1, \vr1, \viB, \vResI1 + vfmadb \vResR2, \vr2, \vrB, \vResR2 + vfmsdb \vResI2, \vr2, \viB, \vResI2 + + vfmadb \vResR3, \vr1, \vrB2, \vResR3 + vfmsdb \vResI3, \vr1, \viB2, \vResI3 + vfmadb \vResR4, \vr2, \vrB2, \vResR4 + vfmsdb \vResI4, \vr2, \viB2, \vResI4 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vResR1, \vr1, \vrB, \vResR1 + vfmadb \vResI1, \vi1, \vrB, \vResI1 + vfmsdb \vResR2, \vr2, \vrB, \vResR2 + vfmadb \vResI2, \vi2, \vrB, \vResI2 + + vfmsdb \vResR3, \vr1, \vrB2, \vResR3 + vfmadb \vResI3, \vi1, \vrB2, \vResI3 + vfmsdb \vResR4, \vr2, \vrB2, \vResR4 + vfmadb \vResI4, \vi2, \vrB2, \vResI4 + + vfmsdb \vResR1, \vi1, \viB, \vResR1 + vfmadb \vResI1, \vr1, \viB, \vResI1 + vfmsdb \vResR2, \vi2, \viB, \vResR2 + vfmadb \vResI2, \vr2, \viB, \vResI2 + + vfmsdb \vResR3, \vi1, \viB2, \vResR3 + vfmadb \vResI3, \vr1, \viB2, \vResI3 + vfmsdb \vResR4, \vi2, \viB2, \vResR4 + vfmadb \vResI4, \vr2, \viB2, \vResI4 + + + #endif + +.endm + +/* + Calculate for 2x2 inner +*/ +.macro CalcComplex_2x2 vResR1, vResI1,vResR2, vResI2, vR1, vI1, vRB, vIB, vRB2, vIB2 + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vResR1, \vI1, \vIB, \vResR1 + vfmadb \vResI1, \vR1, \vIB, \vResI1 + + vfmsdb \vResR2, \vI1, \vIB2, \vResR2 + vfmadb \vResI2, \vR1, \vIB2, \vResI2 + + vfmsdb \vResR1, \vR1, \vRB, \vResR1 + vfmadb \vResI1, \vI1, \vRB, \vResI1 + + vfmsdb \vResR2, \vR1, \vRB2, \vResR2 + vfmadb \vResI2, \vI1, \vRB2, \vResI2 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vResR1, \vI1, \vIB, \vResR1 + vfmsdb \vResI1, \vR1, \vIB, \vResI1 + + vfmadb \vResR2, \vI1, \vIB2, \vResR2 + vfmsdb \vResI2, \vR1, \vIB2, \vResI2 + + vfmadb \vResR1, \vR1, \vRB, \vResR1 + vfmsdb \vResI1, \vI1, \vRB, \vResI1 + + vfmadb \vResR2, \vR1, \vRB2, \vResR2 + vfmsdb \vResI2, \vI1, \vRB2, \vResI2 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vResR1, \vI1, \vIB, \vResR1 + vfmsdb \vResI1, \vI1, \vRB, \vResI1 + + vfmadb \vResR2, \vI1, \vIB2, \vResR2 + vfmsdb \vResI2, \vI1, \vRB2, \vResI2 + + vfmadb \vResR1, \vR1, \vRB, \vResR1 + vfmsdb \vResI1, \vR1, \vIB, \vResI1 + + vfmadb \vResR2, \vR1, \vRB2, \vResR2 + vfmsdb \vResI2, \vR1, \vIB2, \vResI2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vResR1, \vR1, \vRB, \vResR1 + vfmadb \vResI1, \vI1, \vRB, \vResI1 + + vfmsdb \vResR2, \vR1, \vRB2, \vResR2 + vfmadb \vResI2, \vI1, \vRB2, \vResI2 + + vfmsdb \vResR1, \vI1, \vIB, \vResR1 + vfmadb \vResI1, \vR1, \vIB, \vResI1 + + vfmsdb \vResR2, \vI1, \vIB2, \vResR2 + vfmadb \vResI2, \vR1, \vIB2, \vResI2 + #endif +.endm + +/* + Calculate for 2x1 inner +*/ +.macro CalcComplex_2x1 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif +.endm + +/* + Calculate for 1x2 inner +*/ +.macro CalcComplex_1x2 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(RN) || defined(CN) || defined(RT) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + #endif + + #if defined(NR) || defined(TR) || defined(NC) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + #endif +.endm + + +/* + Calculate for 4x1 inner +*/ +.macro CalcComplex_4x1 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + +.endm + +/* + Calculate for 1x4 inner +*/ +.macro CalcComplex_1x4 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(RN) || defined(CN) || defined(RT) || defined(CT) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + #endif + + #if defined(NR) || defined(TR) || defined(NC) || defined(TC) + vfmadb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmsdb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmadb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmsdb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmadb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmsdb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmadb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmsdb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 + #endif + +.endm + +.macro CalcComplex_1x1 RealResult1, ImageResult1, Real1, Image1, RealB, ImageB + #if defined(NN) || defined(NT) || defined(TN) || defined(TT) + msdbr \RealResult1, \Image1, \ImageB + madbr \ImageResult1, \Real1, \ImageB + msdbr \RealResult1, \Real1, \RealB + madbr \ImageResult1, \Image1, \RealB + #endif + + #if defined(NR) || defined(NC) || defined(TR) || defined(TC) + madbr \RealResult1, \Image1, \ImageB + msdbr \ImageResult1, \Real1, \ImageB + madbr \RealResult1, \Real1, \RealB + msdbr \ImageResult1, \Image1, \RealB + #endif + + #if defined(RN) || defined(RT) || defined(CN) || defined(CT) + madbr \RealResult1, \Image1, \ImageB + msdbr \ImageResult1, \Image1, \RealB + madbr \RealResult1, \Real1, \RealB + msdbr \ImageResult1, \Real1, \ImageB + #endif + #if defined(RR) || defined(RC) || defined(CR) || defined(CC) + msdbr \RealResult1, \Real1, \RealB + madbr \ImageResult1, \Image1, \RealB + msdbr \RealResult1, \Image1, \ImageB + madbr \ImageResult1, \Real1, \ImageB + #endif +.endm + +#define DISP(ind,stride,disp) (ind*stride+disp) +#define DISP64(ind,disp) (ind*64+disp) +#define DISP32(ind,disp) (ind*32+disp) +#define DISP16(ind,disp) (ind*16+disp) +#define USE_VLM 1 + +.macro ZCALC_4x4_I PTR_A_REG,PTR_B_REG,Index,IsLast +#if defined(USE_VLM) + vlm %v4,%v7, DISP64(\Index ,0) (\PTR_A_REG) +#else + vl %v4 , DISP64(\Index ,0) (\PTR_A_REG) + vl %v5 , DISP64(\Index ,16)(\PTR_A_REG) + vl %v6 , DISP64(\Index ,32)(\PTR_A_REG) + vl %v7 , DISP64(\Index ,48)(\PTR_A_REG) +#endif + + vlrepg %v9, DISP64(\Index ,0)(\PTR_B_REG) + vlrepg %v10 , DISP64(\Index ,8)(\PTR_B_REG) + vlrepg %v11, DISP64(\Index ,16)(\PTR_B_REG) + vlrepg %v12 , DISP64(\Index ,24)(\PTR_B_REG) + + vpdi %v1,%v4,%v5,0 + vpdi %v5,%v4,%v5,0b101 + vpdi %v3,%v6,%v7,0 + vpdi %v7,%v6,%v7,0b101 + + CalcComplex_4x2 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + vlrepg %v9, DISP64(\Index ,32)(\PTR_B_REG) + vlrepg %v10 , DISP64(\Index ,40)(\PTR_B_REG) + vlrepg %v11, DISP64(\Index ,48)(\PTR_B_REG) + vlrepg %v12 , DISP64(\Index ,56)(\PTR_B_REG) + .if \IsLast==1 + la \PTR_A_REG, DISP64(\Index ,64)(\PTR_A_REG) + .endif + CalcComplex_4x2 %v24,%v25,%v26,%v27,%v28,%v29,%v30,%v31,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_B_REG, DISP64(\Index ,64)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_4x2_I PTR_A_REG,PTR_B_REG,Index,IsLast +#if defined(USE_VLM) + vlm %v4,%v7, DISP64(\Index ,0) (\PTR_A_REG) +#else + vl %v4 , DISP64(\Index ,0) (\PTR_A_REG) + vl %v5 , DISP64(\Index ,16)(\PTR_A_REG) + vl %v6 , DISP64(\Index ,32)(\PTR_A_REG) + vl %v7 , DISP64(\Index ,48)(\PTR_A_REG) +#endif + vlrepg %v9, DISP32(\Index ,0)(\PTR_B_REG) + vlrepg %v10 , DISP32(\Index ,8)(\PTR_B_REG) + vlrepg %v11, DISP32(\Index ,16)(\PTR_B_REG) + vlrepg %v12 , DISP32(\Index ,24)(\PTR_B_REG) + + vpdi %v1,%v4,%v5,0 + vpdi %v5,%v4,%v5,0b101 + vpdi %v3,%v6,%v7,0 + vpdi %v7,%v6,%v7,0b101 + .if \IsLast==1 + la \PTR_A_REG, DISP64(\Index ,64)(\PTR_A_REG) + .endif + CalcComplex_4x2 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_B_REG, DISP32(\Index ,32)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_2x4_I PTR_A_REG,PTR_B_REG,Index,IsLast +#if defined(USE_VLM) + vlm %v4,%v7, DISP64(\Index ,0) (\PTR_B_REG) +#else + vl %v4 , DISP64(\Index ,0) (\PTR_B_REG) + vl %v5 , DISP64(\Index ,16)(\PTR_B_REG) + vl %v6 , DISP64(\Index ,32)(\PTR_B_REG) + vl %v7 , DISP64(\Index ,48)(\PTR_B_REG) +#endif + vlrepg %v9, DISP32(\Index ,0)(\PTR_A_REG) + vlrepg %v10 , DISP32(\Index ,8)(\PTR_A_REG) + vlrepg %v11, DISP32(\Index ,16)(\PTR_A_REG) + vlrepg %v12 , DISP32(\Index ,24)(\PTR_A_REG) + + vpdi %v1,%v4,%v5,0 + vpdi %v5,%v4,%v5,0b101 + vpdi %v3,%v6,%v7,0 + vpdi %v7,%v6,%v7,0b101 + .if \IsLast==1 + la \PTR_B_REG, DISP64(\Index ,64)(\PTR_B_REG) + .endif + CalcComplex_2x4 %v16,%v17,%v18,%v19,%v20,%v21,%v22,%v23,%v1,%v5,%v3,%v7,%v9,%v10,%v11,%v12 + + .if \IsLast==1 + la \PTR_A_REG, DISP32(\Index ,32)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_4x1_I PTR_A_REG,PTR_B_REG,Index,IsLast +#if defined(USE_VLM) + vlm %v4,%v7, DISP64(\Index ,0) (\PTR_A_REG) +#else + vl %v4 , DISP64(\Index ,0) (\PTR_A_REG) + vl %v5 , DISP64(\Index ,16)(\PTR_A_REG) + vl %v6 , DISP64(\Index ,32)(\PTR_A_REG) + vl %v7 , DISP64(\Index ,48)(\PTR_A_REG) +#endif + vlrepg %v9, DISP16(\Index ,0)(\PTR_B_REG) + vlrepg %v10 , DISP16(\Index ,8)(\PTR_B_REG) + + vpdi %v1,%v4,%v5,0 + vpdi %v11,%v4,%v5,0b101 + vpdi %v3,%v6,%v7,0 + vpdi %v12,%v6,%v7,0b101 + .if \IsLast==1 + la \PTR_A_REG, DISP64(\Index ,64)(\PTR_A_REG) + .endif + CalcComplex_4x1 %v16,%v17,%v18,%v19,%v1,%v11,%v3,%v12,%v9,%v10 + .if \IsLast==1 + la \PTR_B_REG, DISP16(\Index ,16)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_1x4_I PTR_A_REG,PTR_B_REG,Index,IsLast +#if defined(USE_VLM) + vlm %v4,%v7, DISP64(\Index ,0) (\PTR_B_REG) +#else + vl %v4 , DISP64(\Index ,0) (\PTR_B_REG) + vl %v5 , DISP64(\Index ,16)(\PTR_B_REG) + vl %v6 , DISP64(\Index ,32)(\PTR_B_REG) + vl %v7 , DISP64(\Index ,48)(\PTR_B_REG) +#endif + vlrepg %v9, DISP16(\Index ,0)(\PTR_A_REG) + vlrepg %v10 , DISP16(\Index ,8)(\PTR_A_REG) + + vpdi %v1,%v4,%v5,0 + vpdi %v11,%v4,%v5,0b101 + vpdi %v3,%v6,%v7,0 + vpdi %v12,%v6,%v7,0b101 + .if \IsLast==1 + la \PTR_B_REG, DISP64(\Index ,64)(\PTR_B_REG) + .endif + CalcComplex_1x4 %v16,%v17,%v18,%v19,%v1,%v11,%v3,%v12,%v9,%v10 + .if \IsLast==1 + la \PTR_A_REG, DISP16(\Index ,16)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_2x2_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vl %v1 , DISP32(\Index ,0)(\PTR_A_REG) + vl %v3 , DISP32(\Index ,16)(\PTR_A_REG) + vlrepg %v9, DISP32(\Index ,0)(\PTR_B_REG) + vlrepg %v10 , DISP32(\Index ,8)(\PTR_B_REG) + vlrepg %v11, DISP32(\Index ,16)(\PTR_B_REG) + vlrepg %v12 , DISP32(\Index ,24)(\PTR_B_REG) + vpdi %v5,%v1,%v3,0 + vpdi %v6,%v1,%v3,0b101 + + .if \IsLast==1 + la \PTR_A_REG, DISP32(\Index ,32)(\PTR_A_REG) + .endif + CalcComplex_2x2 %v16,%v17,%v20,%v21,%v5,%v6, %v9,%v10,%v11,%v12 + .if \IsLast==1 + la \PTR_B_REG, DISP32(\Index ,32)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_2x1_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vl %v1 , DISP32(\Index ,0)(\PTR_A_REG) + vl %v3 , DISP32(\Index ,16)(\PTR_A_REG) + vlrepg %v6, DISP16(\Index ,0)(\PTR_B_REG) + vlrepg %v7 , DISP16(\Index ,8)(\PTR_B_REG) + vpdi %v4,%v1,%v3,0 + vpdi %v5,%v1,%v3,0b101 + + .if \IsLast==1 + la \PTR_A_REG, DISP32(\Index ,32)(\PTR_A_REG) + .endif + CalcComplex_2x1 %v16,%v17,%v4,%v5,%v6,%v7 + .if \IsLast==1 + la \PTR_B_REG, DISP16(\Index ,16)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_1x2_I PTR_A_REG,PTR_B_REG ,Index,IsLast + vl %v1 , DISP32(\Index ,0)(\PTR_B_REG) + vl %v3 , DISP32(\Index ,16)(\PTR_B_REG) + vlrepg %v6, DISP16(\Index ,0)(\PTR_A_REG) + vlrepg %v7 , DISP16(\Index ,8)(\PTR_A_REG) + vpdi %v4,%v1,%v3,0 + vpdi %v5,%v1,%v3,0b101 + + .if \IsLast==1 + la \PTR_B_REG, DISP32(\Index ,32)(\PTR_B_REG) + .endif + CalcComplex_1x2 %v16,%v17,%v4,%v5,%v6,%v7 + .if \IsLast==1 + la \PTR_A_REG, DISP16(\Index ,16)(\PTR_A_REG) + .endif +.endm + +.macro ZCALC_1x1_I PTR_A_REG,PTR_B_REG ,Index,IsLast + ld %f1 , DISP16(\Index ,0)(\PTR_A_REG) + ld %f3 , DISP16(\Index ,8)(\PTR_A_REG) + ld %f4 , DISP16(\Index ,0)(\PTR_B_REG) + ld %f5 , DISP16(\Index ,8)(\PTR_B_REG) + .if \IsLast==1 + la \PTR_A_REG, DISP16(\Index ,16)(\PTR_A_REG) + .endif + CalcComplex_1x1 %f6,%f7,%f1,%f3,%f4,%f5 + .if \IsLast==1 + la \PTR_B_REG, DISP16(\Index ,16)(\PTR_B_REG) + .endif +.endm + +.macro ZCALC_4x4 PTR_A_REG,PTR_B_REG + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_4x2 PTR_A_REG,PTR_B_REG + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_4x1 PTR_A_REG,PTR_B_REG + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_4x4_4 PTR_A_REG,PTR_B_REG + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm +.macro ZCALC_4x2_4 PTR_A_REG,PTR_B_REG + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm +.macro ZCALC_4x1_4 PTR_A_REG,PTR_B_REG + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_4x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x4_4 PTR_A_REG,PTR_B_REG + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x4 PTR_A_REG,PTR_B_REG + ZCALC_2x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_1x4_4 PTR_A_REG,PTR_B_REG + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x4 PTR_A_REG,PTR_B_REG + ZCALC_1x4_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm +.macro ZCALC_2x2 PTR_A_REG,PTR_B_REG + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_2x2_4 PTR_A_REG,PTR_B_REG + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_2x1 PTR_A_REG,PTR_B_REG + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_2x1_4 PTR_A_REG,PTR_B_REG + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_2x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + + +.macro ZCALC_1x2_4 PTR_A_REG,PTR_B_REG + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x2 PTR_A_REG,PTR_B_REG + ZCALC_1x2_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + +.macro ZCALC_1x1_4 PTR_A_REG,PTR_B_REG + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,0,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,1,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,2,0 + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,3,1 +.endm + +.macro ZCALC_1x1 PTR_A_REG,PTR_B_REG + ZCALC_1x1_I \PTR_A_REG,\PTR_B_REG,0,1 +.endm + + + +/*****************************STORE RESULTS************************************/ +.macro CalcMultAlpha_4x1 vRealResult1, vImageResult1, vRealResult2, vImageResult2, vReal1, vImage1, vReal2, vImage2, vecRealB, vecImageB + #if defined (TRMMKERNEL) + vfmdb \vRealResult1, \vImage1, \vecImageB + vfmdb \vImageResult1, \vReal1, \vecImageB + vfmdb \vRealResult2, \vImage2, \vecImageB + vfmdb \vImageResult2, \vReal2, \vecImageB + #else + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 + vfmsdb \vRealResult2, \vImage2, \vecImageB, \vRealResult2 + vfmadb \vImageResult2, \vReal2, \vecImageB, \vImageResult2 +#endif + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 + vfmsdb \vRealResult2, \vReal2, \vecRealB, \vRealResult2 + vfmadb \vImageResult2, \vImage2, \vecRealB, \vImageResult2 + +.endm + +.macro CalcMultAlpha_2x1 vRealResult1, vImageResult1, vReal1, vImage1, vecRealB, vecImageB + #if defined (TRMMKERNEL) + vfmdb \vRealResult1, \vImage1, \vecImageB + vfmdb \vImageResult1, \vReal1, \vecImageB +#else + vfmsdb \vRealResult1, \vImage1, \vecImageB, \vRealResult1 + vfmadb \vImageResult1, \vReal1, \vecImageB, \vImageResult1 +#endif + vfmsdb \vRealResult1, \vReal1, \vecRealB, \vRealResult1 + vfmadb \vImageResult1, \vImage1, \vecRealB, \vImageResult1 +.endm + +.macro CalcMultAlpha_1x1 RealResult1, ImageResult1, Real1, Image1, RealB, ImageB + + msdbr \RealResult1, \Image1, \ImageB + madbr \ImageResult1, \Real1, \ImageB + msdbr \RealResult1, \Real1, \RealB + madbr \ImageResult1, \Image1, \RealB +.endm + +.macro ZSTORE_4x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL ,LC1,LC2 + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 16(\CIJ_REG) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG) + vst %v19,48(\CIJ_REG) + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vl %v4 , 16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3 ,%v4,0b0101 + vst %v16,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vst %v19,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + +#if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG,\LC1) + vl %v4 , 16(\CIJ_REG,\LC1) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG,\LC1) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG,\LC1) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v24,%v25,%v26,%v27,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3 ,%v4,0b0101 + vst %v16,0(\CIJ_REG,\LC1) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG,\LC1) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG,\LC1) + vst %v19,48(\CIJ_REG,\LC1) + + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG,\LC2) + vl %v4 , 16(\CIJ_REG,\LC2) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG,\LC2) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG,\LC2) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v28,%v29,%v30,%v31,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3 ,%v4,0b0101 + vst %v16,0(\CIJ_REG,\LC2) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG,\LC2) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG,\LC2) + vst %v19,48(\CIJ_REG,\LC2) + la \CIJ_REG,64(\CIJ_REG) +.endm + +.macro ZSTORE_4x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 16(\CIJ_REG) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG) + vst %v19,48(\CIJ_REG) + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vl %v4 , 16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v20, %v3 ,%v4,0 + vpdi %v21, %v3 ,%v4,0b0101 + vst %v20,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v22, %v1 ,%v6,0 + vst %v21,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v23, %v1 ,%v6,0b0101 + vst %v22,32(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vst %v23,48(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,64(\CIJ_REG) +.endm +.macro ZSTORE_4x1 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 16(\CIJ_REG) + vpdi %v3,%v1,%v4,0 + vl %v7 , 32(\CIJ_REG) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 48 (\CIJ_REG) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vpdi %v18, %v1 ,%v6,0 + vst %v17,16(\CIJ_REG) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,32(\CIJ_REG) + vst %v19,48(\CIJ_REG) + la \CIJ_REG,64(\CIJ_REG) +.endm +.macro ZSTORE_1x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL,LC1,LC2 + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vl %v4 , 0(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vpdi %v3,%v1,%v4,0 + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + vl %v7 , 0(\CIJ_REG, \LC1) + vpdi %v4,%v1,%v4,0b101 + vl %v6 , 0 (\CIJ_REG,\LC2) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 +#else + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI +#if defined(TRMMKERNEL) + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) +#endif + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vpdi %v18, %v1 ,%v6,0 + vst %v17,0(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,0(\CIJ_REG, \LC1) + vst %v19,0(\CIJ_REG,\LC2) + la \CIJ_REG,16(\CIJ_REG) +.endm +.macro ZSTORE_2x4 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL,LC1,LC2 + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v26 , 16(\CIJ_REG) + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) + vl %v4 , 0(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vl %v25 , 16(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vpdi %v3,%v1,%v4,0 + vpdi %v24,%v26,%v25,0 + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) + vl %v7 , 0(\CIJ_REG, \LC1) + vl %v28 , 16(\CIJ_REG, \LC1) + vpdi %v4,%v1,%v4,0b101 + vpdi %v25,%v26,%v25,0b101 + vl %v6 , 0 (\CIJ_REG,\LC2) + vl %v27 , 16 (\CIJ_REG,\LC2) + vpdi %v1,%v7,%v6,0 + vpdi %v6,%v7,%v6,0b101 + vpdi %v26,%v28,%v27,0 + vpdi %v27,%v28,%v27,0b101 +#else + la \LC1,0(\LDC_BYTE_ORIGINAL, \LDC_BYTE_ORIGINAL) +#endif + CalcMultAlpha_4x1 %v3,%v4,%v1,%v6,%v16,%v17,%v18,%v19,\ALPHA_VECREG,\ALPHA_VECI + CalcMultAlpha_4x1 %v24,%v25,%v26,%v27,%v20,%v21,%v22,%v23,\ALPHA_VECREG,\ALPHA_VECI +#if defined(TRMMKERNEL) + la \LC2,0(\LC1,\LDC_BYTE_ORIGINAL ) +#endif + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vpdi %v20, %v24 ,%v25,0 + vpdi %v21, %v24,%v25,0b0101 + vpdi %v22, %v26 ,%v27,0 + vpdi %v23, %v26 ,%v27,0b0101 + vst %v16,0(\CIJ_REG) + vst %v20,16(\CIJ_REG) + vpdi %v18, %v1 ,%v6,0 + vst %v17,0(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vst %v21,16(\CIJ_REG, \LDC_BYTE_ORIGINAL) + vpdi %v19, %v1 ,%v6,0b0101 + vst %v18,0(\CIJ_REG, \LC1) + vst %v22,16(\CIJ_REG, \LC1) + vst %v19,0(\CIJ_REG,\LC2) + vst %v23,16(\CIJ_REG,\LC2) + la \CIJ_REG,32(\CIJ_REG) + +.endm + +.macro ZSTORE_2x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 16(\CIJ_REG) + vpdi %v3,%v1,%v4,0 + vpdi %v4,%v1,%v4,0b101 + vl %v5 , 0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vl %v7 , 16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v6,%v5,%v7,0 + vpdi %v7,%v5,%v7,0b101 +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + CalcMultAlpha_2x1 %v6,%v7, %v20,%v21 ,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vst %v17,16(\CIJ_REG) + vpdi %v20, %v6 ,%v7,0 + vpdi %v21, %v6 ,%v7,0b0101 + vst %v20,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vst %v21,16(\CIJ_REG,\LDC_BYTE_ORIGINAL) + + la \CIJ_REG,32(\CIJ_REG) +.endm + +.macro ZSTORE_2x1 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 16(\CIJ_REG) + vpdi %v3,%v1,%v4,0 + vpdi %v4,%v1,%v4,0b101 +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vst %v17,16(\CIJ_REG) + la \CIJ_REG,32(\CIJ_REG) +.endm + +.macro ZSTORE_1x2 ALPHA_VECREG,ALPHA_VECI,CIJ_REG , LDC_BYTE_ORIGINAL + #if !defined(TRMMKERNEL) + vl %v1 , 0(\CIJ_REG) + vl %v4 , 0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + vpdi %v3,%v1,%v4,0 + vpdi %v4,%v1,%v4,0b101 +#endif + CalcMultAlpha_2x1 %v3,%v4, %v16,%v17,\ALPHA_VECREG,\ALPHA_VECI + vpdi %v16, %v3 ,%v4,0 + vpdi %v17, %v3,%v4,0b0101 + vst %v16,0(\CIJ_REG) + vst %v17,0(\CIJ_REG,\LDC_BYTE_ORIGINAL) + la \CIJ_REG,16(\CIJ_REG) +.endm + +.macro ZSTORE_1x1 ALPHA_RR,ALPHA_RI ,CIJ_REG + #if defined (TRMMKERNEL) + lzdr %f1 + lzdr %f4 +#else + ld %f1 , 0(\CIJ_REG) + ld %f4 , 8(\CIJ_REG ) +#endif + CalcMultAlpha_1x1 %f1,%f4, %f6,%f7,\ALPHA_RR,\ALPHA_RI + std %f1,0(\CIJ_REG) + std %f4,8(\CIJ_REG) + la \CIJ_REG,16(\CIJ_REG) +.endm + +/****************************TRMM POINTER REFRESH MACROSES*************************/ + +.macro RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B + #if (defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /* ptrbb = bb;*/ + lgr \PTR_B,\B_VAL /*refresh BPOINT*/ + + #else + /* ptrba =ptrba+ off*C_A; + ptrbb = bb + off*C_B;*/ +.if \C_B==4 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,6 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,5 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_B, \PTR_B + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,6 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==2 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,5 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*2**/ + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,5 + agr \PTR_A,\PTR_B /*ptrba+off*2**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_B,\PTR_B /* off+off**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif + +.elseif \C_B==1 + .if \C_A==4 + sllg \PTR_B, \OFF_VAL,6 + agr \PTR_A,\PTR_B /*ptrba+off*4**/ + sllg \PTR_B, \OFF_VAL,4 + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .elseif \C_A==2 + sllg \PTR_B, \OFF_VAL,4 + la \PTR_A,0(\PTR_A,\PTR_B) /*ptrba+off*1**/ + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + + .elseif \C_A==1 + sllg \PTR_B, \OFF_VAL,4 + agr \PTR_A,\PTR_B /*ptrba+off*1**/ + la \PTR_B,0(\B_VAL,\PTR_B) /*refresh BPOINT*/ + .endif +.endif + + #endif +.endm + +/**/ +.macro RefreshTempBk TEMP_VAL,BK_VAL,OFF_VAL,INCR_A,INCR_B + #if (defined(LEFT) && !defined(TRANSA)) || (!defined(LEFT) && defined(TRANSA)) + /* temp = bk-off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + + #elif defined(LEFT) + /* temp = off+INCR_A; // number of values in A */ + la \TEMP_VAL,\INCR_A(\OFF_VAL) + #else + /* temp = off+INCR_B // number of values in B*/ + la \TEMP_VAL,\INCR_B(\OFF_VAL) + #endif + +.endm + +.macro RefreshPointersAndOFF TEMP_VAL,BK_VAL,OFF_VAL,PTR_A,C_A,C_B + + #if ( defined(LEFT) && defined(TRANSA)) || (!defined(LEFT) && !defined(TRANSA)) + /*temp = bk - off;*/ + sgrk \TEMP_VAL,\BK_VAL,\OFF_VAL + #ifdef LEFT + /*temp -= 8; // number of values in A*/ + lay \TEMP_VAL,-\C_A(\TEMP_VAL) + #else + /*temp -= 4; // number of values in B*/ + lay \TEMP_VAL,-\C_B(\TEMP_VAL) + #endif + /*ptrba += temp*C_A; + ptrbb += temp*C_B;*/ + + .if \C_A==4 + sllg \TEMP_VAL, \TEMP_VAL,6 /*temp*4*/ + .elseif \C_A==2 + sllg \TEMP_VAL, \TEMP_VAL,5 /*temp*2*/ + .elseif \C_A==1 + sllg \TEMP_VAL, \TEMP_VAL,4 /*temp*1*/ + .endif + la \PTR_A,0(\PTR_A,\TEMP_VAL) /*ptrba+temp*C_A*/ + #endif + + #ifdef LEFT + /*off += \c_A; // number of values in A*/ + aghi \OFF_VAL,\C_A + #endif +.endm + diff --git a/kernel/zarch/ztrmm4x4V.S b/kernel/zarch/ztrmm4x4V.S new file mode 100644 index 0000000000..52ee15f06c --- /dev/null +++ b/kernel/zarch/ztrmm4x4V.S @@ -0,0 +1,738 @@ +/*************************************************************************** +Copyright (c) 2013-2017, The OpenBLAS Project +All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution. +3. Neither the name of the OpenBLAS project nor the names of +its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*****************************************************************************/ + +/************************************************************************************** +* 2017/02/26 AbdelRauf (quickwritereader@gmail.com) +* BLASTEST : OK +* CTEST : OK +* TEST : OK +**************************************************************************************/ + +/*********************************************************************/ +/* Copyright 2009, 2010 The University of Texas at Austin. */ +/* All rights reserved. */ +/* */ +/* Redistribution and use in source and binary forms, with or */ +/* without modification, are permitted provided that the following */ +/* conditions are met: */ +/* */ +/* 1. Redistributions of source code must retain the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer. */ +/* */ +/* 2. Redistributions in binary form must reproduce the above */ +/* copyright notice, this list of conditions and the following */ +/* disclaimer in the documentation and/or other materials */ +/* provided with the distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, */ +/* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF */ +/* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE */ +/* DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS AT */ +/* AUSTIN OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ +/* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES */ +/* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE */ +/* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR */ +/* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF */ +/* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT */ +/* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ +/* POSSIBILITY OF SUCH DAMAGE. */ +/* */ +/* The views and conclusions contained in the software and */ +/* documentation are those of the authors and should not be */ +/* interpreted as representing official policies, either expressed */ +/* or implied, of The University of Texas at Austin. */ +/*********************************************************************/ + +#define ASSEMBLER +#include "common.h" + +/* + + +BLASLONG bm,BLASLONG bn,BLASLONG bk,FLOAT alphar,FLOAT alphai,FLOAT* ba,FLOAT* bb, + FLOAT* C,BLASLONG ldc, BLASLONG offset) + ##bm=r2,bn=r3, bk=r4, alpha=f0,aplhai=f2, ba=r5,bb=r6,stack[160] ,ldc=stack[168] +offset=stack[176] + +**********************************************************************************************/ +/*Note: r0 can not be used as address disp register */ + +#define BM %r2 +#define BM_CUR %r0 +#define BN %r3 +#define BN_CUR %r10 +#define BK %r4 +#define LDC_BYTE %r8 +#define ALPHA %f0 +#define ALPHA_I %f2 +#define ALPHA_VECT %v0 +#define ALPHA_VECT_I %v2 +#define LOCAL_VAR1 %r9 +#define LOCAL_VAR2 %r1 +#define LOCAL_VAR3 %r11 +#define A %r5 +#define B %r6 +#define CIJ %r7 +#define CIJ_LOCAL %r12 +#define OFF %r13 +#define OFFSET %f8 +#define ALIGN_4 .align 32 +#define ALIGN_2 .align 16 +#define PREFETCH_INS 1 + +/**************************Include kernel helper macrosses**********************************/ +#include "zkernelMacrosV.S" + + + +/***********************************ZGEMM**4x4*******************************************************/ + +PROLOGUE +#if defined(TRMMKERNEL) + std OFFSET ,40(%r15) + stmg %r6,%r13,48(%r15) +#else + stmg %r6,%r12,48(%r15) +#endif +std %f9, 128(%r15) +std %f10,136(%r15) +std %f11,144(%r15) +std %f12,152(%r15) + +lg CIJ, 160(%r15) +lg LOCAL_VAR1, 168(%r15) +#if defined(TRMMKERNEL) + lg OFF,176(%r15) + ldgr OFFSET ,OFF +#endif +srlg BN_CUR,BN,2 +#if defined(RR) || defined(RC) || defined(CR) || defined(CC) + lcdbr ALPHA_I,ALPHA_I + lcdbr ALPHA ,ALPHA +#endif + +vrepg ALPHA_VECT,ALPHA_VECT,0 /*replicate alpha which in f0*/ + +sllg LDC_BYTE, LOCAL_VAR1,4 /*calculate lcd stride with complex=16 x<<4 */ +vrepg ALPHA_VECT_I,ALPHA_VECT_I,0 /*replicate alpha which in f0*/ +#if defined(TRMMKERNEL) && !defined(LEFT) + /*off = -offset;*/ + lgdr LOCAL_VAR1,OFFSET + lcgr OFF,LOCAL_VAR1 +#endif +cijle BN_CUR,0,.LX2 + +ALIGN_4 +.LX4_BN: +#if defined(PREFETCH_INS) + pfd 1, 0(A) + pfd 1, 0(B) +#endif +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x4 + +ALIGN_4 +.L4x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x4 +cijle LOCAL_VAR1,0,.L4x4_mod + +ALIGN_4 +.L4x4_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) + pfd 1, 256(LOCAL_VAR2 ) +#endif + ZCALC_4x4_4 LOCAL_VAR3,LOCAL_VAR2 + +brctg LOCAL_VAR1,.L4x4_4_BK + +ALIGN_4 +.L4x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,4 + nill LOCAL_VAR1,3 +#else + la LOCAL_VAR1,3(0,0) + NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x4_BK_Store + +ALIGN_4 +.L4x4_BK: /*BK_CUR LOOP */ + ZCALC_4x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x4_BK + +ALIGN_4 +.L4x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,4 +#endif + +brctg BM_CUR,.L4x4_BM + +ALIGN_2 +.L2x4: + +tmll BM,2 +jz .L1x4 + +ALIGN_4 +.L2x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,4 + + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x4 +cijle LOCAL_VAR1,0,.L2x4_mod + +ALIGN_4 +.L2x4_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR2) +#endif + ZCALC_2x4_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif +brctg LOCAL_VAR1,.L2x4_4_BK + +ALIGN_4 +.L2x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x4_BK_Store + +ALIGN_4 +.L2x4_BK: /*BK_CUR LOOP */ + ZCALC_2x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x4_BK + +ALIGN_4 +.L2x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE ,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,4 +#endif + +ALIGN_4 +.L1x4: + +tmll BM,1 +jz .Lx4_INNER_END + +ALIGN_4 +.L1x4_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,4 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x4 +cijle LOCAL_VAR1,0,.L1x4_mod + +ALIGN_4 +.L1x4_4_BK: /*BK_CUR LOOP */ + ZCALC_1x4_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_4_BK + +ALIGN_4 +.L1x4_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,4 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x4_BK_Store + +ALIGN_4 +.L1x4_BK: /*BK_CUR LOOP */ + ZCALC_1x4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x4_BK + +ALIGN_4 +.L1x4_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_1x4 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE,LOCAL_VAR1,LOCAL_VAR2 +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,4 +#endif +ALIGN_2 +.Lx4_INNER_END: + + +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR1,LDC_BYTE,2 /*multiply*4 */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,4 +#endif +sllg LOCAL_VAR2,BK,6 /*multiply*4*sizeof(complex) =multiply*4*16* 2**6 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*4*/ +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*4*sizeof(complex) */ + +brctg BN_CUR,.LX4_BN + +/*********************************X2 SECTION************************************************/ +ALIGN_4 +.LX2: +tmll BN,2 +jz .Lx1 + +ALIGN_4 +.Lx2_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif + +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x2 + +ALIGN_4 +.L4x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + srl LOCAL_VAR1,2 + +#else + srlg LOCAL_VAR1,BK,2 /*refresh BK*/ + lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x2 +cijle LOCAL_VAR1,0,.L4x2_mod + +ALIGN_4 +.L4x2_4_BK: /*BK_CUR LOOP */ +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) +#endif + ZCALC_4x2_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR2 ) +#endif +brctg LOCAL_VAR1,.L4x2_4_BK + +ALIGN_4 +.L4x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x2_BK_Store + +ALIGN_4 +.L4x2_BK: /*BK_CUR LOOP */ + ZCALC_4x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x2_BK + +ALIGN_4 +.L4x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,2 +#endif +ALIGN_4 +brctg BM_CUR,.L4x2_BM + +ALIGN_2 +.L2x2: + +tmll BM,2 +jz .L1x2 + +ALIGN_4 +.L2x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x2 +cijle LOCAL_VAR1,0,.L2x2_mod + +ALIGN_4 +.L2x2_4_BK: /*BK_CUR LOOP */ + ZCALC_2x2_4 LOCAL_VAR3,LOCAL_VAR2 +#if defined(PREFETCH_INS) + pfd 1, 256(LOCAL_VAR3) + pfd 1, 256(LOCAL_VAR2) +#endif +brctg LOCAL_VAR1,.L2x2_4_BK + +ALIGN_4 +.L2x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x2_BK_Store + +ALIGN_4 +.L2x2_BK: /*BK_CUR LOOP */ + ZCALC_2x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x2_BK + +ALIGN_4 +.L2x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,2 +#endif + +ALIGN_2 +.L1x2: + +tmll BM,1 +jz .Lx2_INNER_END + +ALIGN_4 +.L1x2_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,2 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x2 +cijle LOCAL_VAR1,0,.L1x2_mod + +ALIGN_4 +.L1x2_4_BK: /*BK_CUR LOOP */ + ZCALC_1x2_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_4_BK + +ALIGN_4 +.L1x2_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,2 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x2_BK_Store + +ALIGN_4 +.L1x2_BK: /*BK_CUR LOOP */ + ZCALC_1x2 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x2_BK + +ALIGN_4 +.L1x2_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_1x2 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,2 +#endif +ALIGN_2 +.Lx2_INNER_END: +/*add LDC_BYTE_COPY to new*/ +la LOCAL_VAR1,0(LDC_BYTE,LDC_BYTE) /*multiply*2 */ +sllg LOCAL_VAR2,BK,5 /*multiply*2*sizeof(complex) =multiply*2*16 2^5 */ +la CIJ,0(CIJ,LOCAL_VAR1) /*refresh CIJ=CIJ+LDC_BYTE*2*/ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,2 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*2*sizeof(complex) */ + + + + +/*********************************X1 SECTION************************************************/ +ALIGN_2 +.Lx1: +tmll BN,1 +jz .L_FUNC_END + +ALIGN_4 +.Lx1_BN: + +#if defined(TRMMKERNEL) && defined(LEFT) + /*off = offset;*/ + lgdr OFF,OFFSET +#endif +srlg BM_CUR,BM,2 +lgr LOCAL_VAR3,A +lgr CIJ_LOCAL,CIJ +cijle BM_CUR,0,.L2x1 + +ALIGN_4 +.L4x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,4,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_4x1 +cijle LOCAL_VAR1,0,.L4x1_mod + +ALIGN_4 +.L4x1_4_BK: /*BK_CUR LOOP */ + ZCALC_4x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_4_BK + +ALIGN_4 +.L4x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,4,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L4x1_BK_Store + +ALIGN_4 +.L4x1_BK: /*BK_CUR LOOP */ + ZCALC_4x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L4x1_BK + +ALIGN_4 +.L4x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_4x1 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE + #if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,4,1 +#endif +ALIGN_4 +brctg BM_CUR , .L4x1_BM + +ALIGN_2 +.L2x1: + +tmll BM,2 +jz .L1x1 + +ALIGN_4 +.L2x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,2,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_2x1 +cijle LOCAL_VAR1,0,.L2x1_mod + +ALIGN_4 +.L2x1_4_BK: /*BK_CUR LOOP */ + ZCALC_2x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_4_BK + +ALIGN_4 +.L2x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,2,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L2x1_BK_Store + +ALIGN_4 +.L2x1_BK: /*BK_CUR LOOP */ + ZCALC_2x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L2x1_BK + +ALIGN_4 +.L2x1_BK_Store: +/*store C and use LDC_BYTE AND CIJ_COPY for mem storing*/ +ZSTORE_2x1 ALPHA_VECT,ALPHA_VECT_I ,CIJ_LOCAL, LDC_BYTE +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,2,1 +#endif + +ALIGN_2 +.L1x1: + +tmll BM, 1 +jz .Lx1_INNER_END + +ALIGN_4 +.L1x1_BM: /*BM start*/ +#if defined(TRMMKERNEL) + /* RefreshPointers PTR_A,PTR_B,OFF_VAL,B_VAL,C_A,C_B */ + RefreshPointers LOCAL_VAR3,LOCAL_VAR2,OFF,B,1,1 + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + srl LOCAL_VAR1,2 + +#else +srlg LOCAL_VAR1,BK,2 /*refresh BK*/ +lgr LOCAL_VAR2,B /*refresh BPOINT*/ +#endif +ZERO_ZCVEC_1x1 +cijle LOCAL_VAR1,0,.L1x1_mod + +ALIGN_4 +.L1x1_4_BK: /*BK_CUR LOOP */ + ZCALC_1x1_4 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_4_BK + +ALIGN_4 +.L1x1_mod: +#if defined(TRMMKERNEL) + RefreshTempBk LOCAL_VAR1,BK,OFF,1,1 + nill LOCAL_VAR1,3 +#else +la LOCAL_VAR1,3(0,0) +NGR LOCAL_VAR1,BK /*refresh BK*/ +#endif +jz .L1x1_BK_Store + +ALIGN_4 +.L1x1_BK: /*BK_CUR LOOP */ + ZCALC_1x1 LOCAL_VAR3,LOCAL_VAR2 +brctg LOCAL_VAR1,.L1x1_BK + +ALIGN_4 +.L1x1_BK_Store: +/*store C and use CIJ_COPY for mem storing*/ +ZSTORE_1x1 ALPHA,ALPHA_I ,CIJ_LOCAL +#if defined(TRMMKERNEL) + RefreshPointersAndOFF LOCAL_VAR1,BK,OFF,LOCAL_VAR3,1,1 +#endif +ALIGN_2 +.Lx1_INNER_END: +/*add LDC_BYTE_COPY to new*/ +sllg LOCAL_VAR2,BK,4 /*multiply*1*sizeof(complex) =multiply*1*16* 2^4 */ +la CIJ,0(CIJ,LDC_BYTE) /*refresh CIJ=CIJ+LDC_BYTE */ +#if defined(TRMMKERNEL) && !defined(LEFT) + aghi OFF,1 +#endif +la B,0(B,LOCAL_VAR2) /*refresh B=B+Bk*1*sizeof(complex) */ + + +ALIGN_2 +.L_FUNC_END: +/*end*/ + + +#if defined(TRMMKERNEL) +ld OFFSET,40(%r15) +lmg %r6,%r13,48(%r15) +#else +lmg %r6,%r12,48(%r15) +#endif +ld %f9, 128(%r15) +ld %f10,136(%r15) +ld %f11,144(%r15) +ld %f12,152(%r15) +br %r14 +.end + + + + + + + + + + + + + + + + diff --git a/lapack-devel.log b/lapack-devel.log deleted file mode 100644 index 739e7aa92d..0000000000 --- a/lapack-devel.log +++ /dev/null @@ -1,19 +0,0 @@ -======================================================================================== -2014/05/07 Saar - -Platform: BULLDOZER single thread - - - --> LAPACK TESTING SUMMARY <-- - Processing LAPACK Testing output found in the TESTING direcory -SUMMARY nb test run numerical error other error -================ =========== ================= ================ -REAL 1079349 0 (0.000%) 0 (0.000%) -DOUBLE PRECISION 1080161 0 (0.000%) 0 (0.000%) -COMPLEX 556022 0 (0.000%) 0 (0.000%) -COMPLEX16 556834 0 (0.000%) 0 (0.000%) - ---> ALL PRECISIONS 3272366 0 (0.000%) 0 (0.000%) - -======================================================================================== - diff --git a/lapack-netlib/BLAS/CMakeLists.txt b/lapack-netlib/BLAS/CMakeLists.txt index 45e68e9960..42cd4f6195 100644 --- a/lapack-netlib/BLAS/CMakeLists.txt +++ b/lapack-netlib/BLAS/CMakeLists.txt @@ -1,8 +1,8 @@ add_subdirectory(SRC) if(BUILD_TESTING) add_subdirectory(TESTING) -endif(BUILD_TESTING) -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/blas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/blas.pc) +endif() +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/blas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/blas.pc @ONLY) install(FILES ${CMAKE_CURRENT_BINARY_DIR}/blas.pc DESTINATION ${PKG_CONFIG_DIR} diff --git a/lapack-netlib/BLAS/SRC/CMakeLists.txt b/lapack-netlib/BLAS/SRC/CMakeLists.txt index 7d8066c44e..a9306fc415 100644 --- a/lapack-netlib/BLAS/SRC/CMakeLists.txt +++ b/lapack-netlib/BLAS/SRC/CMakeLists.txt @@ -57,19 +57,19 @@ # Comment out the next 6 definitions if you already have # the Level 1 BLAS. #--------------------------------------------------------- -set(SBLAS1 isamax.f sasum.f saxpy.f scopy.f sdot.f snrm2.f +set(SBLAS1 isamax.f sasum.f saxpy.f scopy.f sdot.f snrm2.f srot.f srotg.f sscal.f sswap.f sdsdot.f srotmg.f srotm.f) -set(CBLAS1 scabs1.f scasum.f scnrm2.f icamax.f caxpy.f ccopy.f +set(CBLAS1 scabs1.f scasum.f scnrm2.f icamax.f caxpy.f ccopy.f cdotc.f cdotu.f csscal.f crotg.f cscal.f cswap.f csrot.f) -set(DBLAS1 idamax.f dasum.f daxpy.f dcopy.f ddot.f dnrm2.f +set(DBLAS1 idamax.f dasum.f daxpy.f dcopy.f ddot.f dnrm2.f drot.f drotg.f dscal.f dsdot.f dswap.f drotmg.f drotm.f) -set(ZBLAS1 dcabs1.f dzasum.f dznrm2.f izamax.f zaxpy.f zcopy.f +set(ZBLAS1 dcabs1.f dzasum.f dznrm2.f izamax.f zaxpy.f zcopy.f zdotc.f zdotu.f zdscal.f zrotg.f zscal.f zswap.f zdrot.f) -set(CB1AUX isamax.f sasum.f saxpy.f scopy.f snrm2.f sscal.f) +set(CB1AUX isamax.f sasum.f saxpy.f scopy.f snrm2.f sscal.f) set(ZB1AUX idamax.f dasum.f daxpy.f dcopy.f dnrm2.f dscal.f) @@ -78,64 +78,64 @@ set(ZB1AUX idamax.f dasum.f daxpy.f dcopy.f dnrm2.f dscal.f) # Level 2 and Level 3 BLAS. Comment it out only if you already have # both the Level 2 and 3 BLAS. #--------------------------------------------------------------------- -set(ALLBLAS lsame.f xerbla.f xerbla_array.f) +set(ALLBLAS lsame.f xerbla.f xerbla_array.f) #--------------------------------------------------------- # Comment out the next 4 definitions if you already have # the Level 2 BLAS. #--------------------------------------------------------- -set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f - strmv.f stbmv.f stpmv.f strsv.f stbsv.f stpsv.f +set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f + strmv.f stbmv.f stpmv.f strsv.f stbsv.f stpsv.f sger.f ssyr.f sspr.f ssyr2.f sspr2.f) -set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f - ctrmv.f ctbmv.f ctpmv.f ctrsv.f ctbsv.f ctpsv.f +set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f + ctrmv.f ctbmv.f ctpmv.f ctrsv.f ctbsv.f ctpsv.f cgerc.f cgeru.f cher.f chpr.f cher2.f chpr2.f) -set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f - dtrmv.f dtbmv.f dtpmv.f dtrsv.f dtbsv.f dtpsv.f +set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f + dtrmv.f dtbmv.f dtpmv.f dtrsv.f dtbsv.f dtpsv.f dger.f dsyr.f dspr.f dsyr2.f dspr2.f) -set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f - ztrmv.f ztbmv.f ztpmv.f ztrsv.f ztbsv.f ztpsv.f +set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f + ztrmv.f ztbmv.f ztpmv.f ztrsv.f ztbsv.f ztpsv.f zgerc.f zgeru.f zher.f zhpr.f zher2.f zhpr2.f) #--------------------------------------------------------- # Comment out the next 4 definitions if you already have # the Level 3 BLAS. #--------------------------------------------------------- -set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f ) +set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f) -set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f +set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f chemm.f cherk.f cher2k.f) set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f) -set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f +set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f zhemm.f zherk.f zher2k.f) # default build all of it -set(ALLOBJ ${SBLAS1} ${SBLAS2} ${SBLAS3} ${DBLAS1} ${DBLAS2} ${DBLAS3} - ${CBLAS1} ${CBLAS2} ${CBLAS3} ${ZBLAS1} +set(ALLOBJ ${SBLAS1} ${SBLAS2} ${SBLAS3} ${DBLAS1} ${DBLAS2} ${DBLAS3} + ${CBLAS1} ${CBLAS2} ${CBLAS3} ${ZBLAS1} ${ZBLAS2} ${ZBLAS3} ${ALLBLAS}) if(BLAS_SINGLE) - set(ALLOBJ ${SBLAS1} ${ALLBLAS} + set(ALLOBJ ${SBLAS1} ${ALLBLAS} ${SBLAS2} ${SBLAS3}) endif() if(BLAS_DOUBLE) - set(ALLOBJ ${DBLAS1} ${ALLBLAS} + set(ALLOBJ ${DBLAS1} ${ALLBLAS} ${DBLAS2} ${DBLAS3}) endif() if(BLAS_COMPLEX) - set(ALLOBJ ${BLASLIB} ${CBLAS1} ${CB1AUX} + set(ALLOBJ ${BLASLIB} ${CBLAS1} ${CB1AUX} ${ALLBLAS} ${CBLAS2}) endif() if(BLAS_COMPLEX16) - set(ALLOBJ ${BLASLIB} ${ZBLAS1} ${ZB1AUX} + set(ALLOBJ ${BLASLIB} ${ZBLAS1} ${ZB1AUX} ${ALLBLAS} ${ZBLAS2} ${ZBLAS3}) endif() - - + + add_library(blas ${ALLOBJ}) #if(UNIX) # target_link_libraries(blas m) diff --git a/lapack-netlib/BLAS/SRC/Makefile b/lapack-netlib/BLAS/SRC/Makefile index 43dbfb749d..47a15824cf 100644 --- a/lapack-netlib/BLAS/SRC/Makefile +++ b/lapack-netlib/BLAS/SRC/Makefile @@ -56,7 +56,7 @@ include ../../make.inc ####################################################################### all: $(BLASLIB) - + #--------------------------------------------------------- # Comment out the next 6 definitions if you already have # the Level 1 BLAS. @@ -88,8 +88,8 @@ $(ZB1AUX): $(FRC) # Level 2 and Level 3 BLAS. Comment it out only if you already have # both the Level 2 and 3 BLAS. #--------------------------------------------------------------------- -ALLBLAS = lsame.o xerbla.o xerbla_array.o -$(ALLBLAS) : $(FRC) +ALLBLAS = lsame.o xerbla.o xerbla_array.o +$(ALLBLAS): $(FRC) #--------------------------------------------------------- # Comment out the next 4 definitions if you already have @@ -119,7 +119,7 @@ $(ZBLAS2): $(FRC) # Comment out the next 4 definitions if you already have # the Level 3 BLAS. #--------------------------------------------------------- -SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o +SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o $(SBLAS3): $(FRC) CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \ @@ -133,7 +133,7 @@ ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ zhemm.o zherk.o zher2k.o $(ZBLAS3): $(FRC) -ALLOBJ=$(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \ +ALLOBJ = $(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \ $(CBLAS1) $(CBLAS2) $(CBLAS3) $(ZBLAS1) \ $(ZBLAS2) $(ZBLAS3) $(ALLBLAS) @@ -167,5 +167,5 @@ FRC: clean: rm -f *.o -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/BLAS/SRC/caxpy.f b/lapack-netlib/BLAS/SRC/caxpy.f index 7b23a3476a..7ee77747c0 100644 --- a/lapack-netlib/BLAS/SRC/caxpy.f +++ b/lapack-netlib/BLAS/SRC/caxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) -* +* * .. Scalar Arguments .. * COMPLEX CA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX CA diff --git a/lapack-netlib/BLAS/SRC/ccopy.f b/lapack-netlib/BLAS/SRC/ccopy.f index 9c11db0d97..eeb5f299ad 100644 --- a/lapack-netlib/BLAS/SRC/ccopy.f +++ b/lapack-netlib/BLAS/SRC/ccopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -50,10 +50,10 @@ * ===================================================================== SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/cdotc.f b/lapack-netlib/BLAS/SRC/cdotc.f index 75c72a63bf..cd3416980a 100644 --- a/lapack-netlib/BLAS/SRC/cdotc.f +++ b/lapack-netlib/BLAS/SRC/cdotc.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/cdotu.f b/lapack-netlib/BLAS/SRC/cdotu.f index b3b21ada13..1e127bc0e6 100644 --- a/lapack-netlib/BLAS/SRC/cdotu.f +++ b/lapack-netlib/BLAS/SRC/cdotu.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/cgbmv.f b/lapack-netlib/BLAS/SRC/cgbmv.f index 2525003785..de12852a8c 100644 --- a/lapack-netlib/BLAS/SRC/cgbmv.f +++ b/lapack-netlib/BLAS/SRC/cgbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER INCX,INCY,KL,KU,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -160,12 +160,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/cgemm.f b/lapack-netlib/BLAS/SRC/cgemm.f index 6a2c806307..018ffad628 100644 --- a/lapack-netlib/BLAS/SRC/cgemm.f +++ b/lapack-netlib/BLAS/SRC/cgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/cgemv.f b/lapack-netlib/BLAS/SRC/cgemv.f index 30c94758e5..aeb94090c7 100644 --- a/lapack-netlib/BLAS/SRC/cgemv.f +++ b/lapack-netlib/BLAS/SRC/cgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -158,10 +158,10 @@ * ===================================================================== SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/cgerc.f b/lapack-netlib/BLAS/SRC/cgerc.f index a99d5b9293..e730edfde2 100644 --- a/lapack-netlib/BLAS/SRC/cgerc.f +++ b/lapack-netlib/BLAS/SRC/cgerc.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/cgeru.f b/lapack-netlib/BLAS/SRC/cgeru.f index c551782d2a..bc7540faad 100644 --- a/lapack-netlib/BLAS/SRC/cgeru.f +++ b/lapack-netlib/BLAS/SRC/cgeru.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/chbmv.f b/lapack-netlib/BLAS/SRC/chbmv.f index bbfeb1fabd..435c8dd2e6 100644 --- a/lapack-netlib/BLAS/SRC/chbmv.f +++ b/lapack-netlib/BLAS/SRC/chbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER INCX,INCY,K,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -160,12 +160,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/chemm.f b/lapack-netlib/BLAS/SRC/chemm.f index 069491c992..834b209a30 100644 --- a/lapack-netlib/BLAS/SRC/chemm.f +++ b/lapack-netlib/BLAS/SRC/chemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/chemv.f b/lapack-netlib/BLAS/SRC/chemv.f index 56f8359199..215092979d 100644 --- a/lapack-netlib/BLAS/SRC/chemv.f +++ b/lapack-netlib/BLAS/SRC/chemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -154,10 +154,10 @@ * ===================================================================== SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/cher.f b/lapack-netlib/BLAS/SRC/cher.f index 8cd6f0c283..78a4e0b7f8 100644 --- a/lapack-netlib/BLAS/SRC/cher.f +++ b/lapack-netlib/BLAS/SRC/cher.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/cher2.f b/lapack-netlib/BLAS/SRC/cher2.f index cdbeba35ad..fd65f97076 100644 --- a/lapack-netlib/BLAS/SRC/cher2.f +++ b/lapack-netlib/BLAS/SRC/cher2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -150,10 +150,10 @@ * ===================================================================== SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/cher2k.f b/lapack-netlib/BLAS/SRC/cher2k.f index 0c8218d0ae..ace3c5d24d 100644 --- a/lapack-netlib/BLAS/SRC/cher2k.f +++ b/lapack-netlib/BLAS/SRC/cher2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * REAL BETA @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -197,10 +197,10 @@ * ===================================================================== SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/cherk.f b/lapack-netlib/BLAS/SRC/cherk.f index cbc59555f2..1c47e57bbf 100644 --- a/lapack-netlib/BLAS/SRC/cherk.f +++ b/lapack-netlib/BLAS/SRC/cherk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/chpmv.f b/lapack-netlib/BLAS/SRC/chpmv.f index 93c03424d4..b182bfb915 100644 --- a/lapack-netlib/BLAS/SRC/chpmv.f +++ b/lapack-netlib/BLAS/SRC/chpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/chpr.f b/lapack-netlib/BLAS/SRC/chpr.f index 8b0cecd539..6212c04380 100644 --- a/lapack-netlib/BLAS/SRC/chpr.f +++ b/lapack-netlib/BLAS/SRC/chpr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/chpr2.f b/lapack-netlib/BLAS/SRC/chpr2.f index eea346b751..3ca388a486 100644 --- a/lapack-netlib/BLAS/SRC/chpr2.f +++ b/lapack-netlib/BLAS/SRC/chpr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/crotg.f b/lapack-netlib/BLAS/SRC/crotg.f index 1a2efd44f0..1cdb662ee7 100644 --- a/lapack-netlib/BLAS/SRC/crotg.f +++ b/lapack-netlib/BLAS/SRC/crotg.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CROTG(CA,CB,C,S) -* +* * .. Scalar Arguments .. * COMPLEX CA,CB,S * REAL C * .. -* +* * *> \par Purpose: * ============= @@ -27,22 +27,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * * ===================================================================== SUBROUTINE CROTG(CA,CB,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX CA,CB,S diff --git a/lapack-netlib/BLAS/SRC/cscal.f b/lapack-netlib/BLAS/SRC/cscal.f index cceb77e967..1405a977de 100644 --- a/lapack-netlib/BLAS/SRC/cscal.f +++ b/lapack-netlib/BLAS/SRC/cscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSCAL(N,CA,CX,INCX) -* +* * .. Scalar Arguments .. * COMPLEX CA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX CX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE CSCAL(N,CA,CX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX CA diff --git a/lapack-netlib/BLAS/SRC/csrot.f b/lapack-netlib/BLAS/SRC/csrot.f index b600d9afbe..aa8564e7fe 100644 --- a/lapack-netlib/BLAS/SRC/csrot.f +++ b/lapack-netlib/BLAS/SRC/csrot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * REAL C, S @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * * ===================================================================== SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/BLAS/SRC/csscal.f b/lapack-netlib/BLAS/SRC/csscal.f index f2edde8eaa..dc02654f1c 100644 --- a/lapack-netlib/BLAS/SRC/csscal.f +++ b/lapack-netlib/BLAS/SRC/csscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSSCAL(N,SA,CX,INCX) -* +* * .. Scalar Arguments .. * REAL SA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX CX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE CSSCAL(N,SA,CX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL SA diff --git a/lapack-netlib/BLAS/SRC/cswap.f b/lapack-netlib/BLAS/SRC/cswap.f index 2e4bedf86e..369a294ea9 100644 --- a/lapack-netlib/BLAS/SRC/cswap.f +++ b/lapack-netlib/BLAS/SRC/cswap.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX CX(*),CY(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level1 * @@ -50,10 +50,10 @@ * ===================================================================== SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/csymm.f b/lapack-netlib/BLAS/SRC/csymm.f index 9d6d743afa..906a57201b 100644 --- a/lapack-netlib/BLAS/SRC/csymm.f +++ b/lapack-netlib/BLAS/SRC/csymm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/csyr2k.f b/lapack-netlib/BLAS/SRC/csyr2k.f index dfa68e075d..1fdeadc0fb 100644 --- a/lapack-netlib/BLAS/SRC/csyr2k.f +++ b/lapack-netlib/BLAS/SRC/csyr2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER K,LDA,LDB,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -188,10 +188,10 @@ * ===================================================================== SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/csyrk.f b/lapack-netlib/BLAS/SRC/csyrk.f index 8bf58ad2bc..c4494c5a8b 100644 --- a/lapack-netlib/BLAS/SRC/csyrk.f +++ b/lapack-netlib/BLAS/SRC/csyrk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/ctbmv.f b/lapack-netlib/BLAS/SRC/ctbmv.f index 45d17b8610..1513c1a343 100644 --- a/lapack-netlib/BLAS/SRC/ctbmv.f +++ b/lapack-netlib/BLAS/SRC/ctbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -146,7 +146,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ctbsv.f b/lapack-netlib/BLAS/SRC/ctbsv.f index 3e6c663bc7..f4cc3306f1 100644 --- a/lapack-netlib/BLAS/SRC/ctbsv.f +++ b/lapack-netlib/BLAS/SRC/ctbsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ctpmv.f b/lapack-netlib/BLAS/SRC/ctpmv.f index 14c7417d9d..4582acc9fc 100644 --- a/lapack-netlib/BLAS/SRC/ctpmv.f +++ b/lapack-netlib/BLAS/SRC/ctpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -102,7 +102,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/ctpsv.f b/lapack-netlib/BLAS/SRC/ctpsv.f index 40844debff..2fcd19bac0 100644 --- a/lapack-netlib/BLAS/SRC/ctpsv.f +++ b/lapack-netlib/BLAS/SRC/ctpsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/ctrmm.f b/lapack-netlib/BLAS/SRC/ctrmm.f index b0ac1dd9f4..a23fb27c66 100644 --- a/lapack-netlib/BLAS/SRC/ctrmm.f +++ b/lapack-netlib/BLAS/SRC/ctrmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/ctrmv.f b/lapack-netlib/BLAS/SRC/ctrmv.f index f2bfbc2ecc..8795e8702d 100644 --- a/lapack-netlib/BLAS/SRC/ctrmv.f +++ b/lapack-netlib/BLAS/SRC/ctrmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ctrsm.f b/lapack-netlib/BLAS/SRC/ctrsm.f index b87bfe3e4a..7ee5c9470a 100644 --- a/lapack-netlib/BLAS/SRC/ctrsm.f +++ b/lapack-netlib/BLAS/SRC/ctrsm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -112,7 +112,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX array of DIMENSION ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' +*> where k is m when SIDE = 'L' or 'l' *> and k is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level3 * @@ -180,10 +180,10 @@ * ===================================================================== SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA diff --git a/lapack-netlib/BLAS/SRC/ctrsv.f b/lapack-netlib/BLAS/SRC/ctrsv.f index 90897286b2..7981a21d18 100644 --- a/lapack-netlib/BLAS/SRC/ctrsv.f +++ b/lapack-netlib/BLAS/SRC/ctrsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_blas_level2 * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/dasum.f b/lapack-netlib/BLAS/SRC/dasum.f index c1bd78ac81..fd3d910446 100644 --- a/lapack-netlib/BLAS/SRC/dasum.f +++ b/lapack-netlib/BLAS/SRC/dasum.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/daxpy.f b/lapack-netlib/BLAS/SRC/daxpy.f index 64a02d68bc..5203e50cfb 100644 --- a/lapack-netlib/BLAS/SRC/daxpy.f +++ b/lapack-netlib/BLAS/SRC/daxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lapack-netlib/BLAS/SRC/dcabs1.f b/lapack-netlib/BLAS/SRC/dcabs1.f index 1ea86a95cd..d71fe7af62 100644 --- a/lapack-netlib/BLAS/SRC/dcabs1.f +++ b/lapack-netlib/BLAS/SRC/dcabs1.f @@ -2,47 +2,47 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DCABS1(Z) -* +* * .. Scalar Arguments .. * COMPLEX*16 Z * .. * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== DOUBLE PRECISION FUNCTION DCABS1(Z) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 Z diff --git a/lapack-netlib/BLAS/SRC/dcopy.f b/lapack-netlib/BLAS/SRC/dcopy.f index d9d5ac7aa2..bbc38a75c6 100644 --- a/lapack-netlib/BLAS/SRC/dcopy.f +++ b/lapack-netlib/BLAS/SRC/dcopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N @@ -85,7 +85,7 @@ SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) DY(I) = DX(I) END DO IF (N.LT.7) RETURN - END IF + END IF MP1 = M + 1 DO I = MP1,N,7 DY(I) = DX(I) @@ -96,7 +96,7 @@ SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) DY(I+5) = DX(I+5) DY(I+6) = DX(I+6) END DO - ELSE + ELSE * * code for unequal increments or equal increments * not equal to 1 diff --git a/lapack-netlib/BLAS/SRC/ddot.f b/lapack-netlib/BLAS/SRC/ddot.f index cc0c1b7a43..1aea8240bb 100644 --- a/lapack-netlib/BLAS/SRC/ddot.f +++ b/lapack-netlib/BLAS/SRC/ddot.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/dgbmv.f b/lapack-netlib/BLAS/SRC/dgbmv.f index 1d90f50664..3769e18b0e 100644 --- a/lapack-netlib/BLAS/SRC/dgbmv.f +++ b/lapack-netlib/BLAS/SRC/dgbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,KL,KU,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dgemm.f b/lapack-netlib/BLAS/SRC/dgemm.f index 4bae243a8f..5c5a2ac2b0 100644 --- a/lapack-netlib/BLAS/SRC/dgemm.f +++ b/lapack-netlib/BLAS/SRC/dgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dgemv.f b/lapack-netlib/BLAS/SRC/dgemv.f index e04cc07cf1..dd14c3509f 100644 --- a/lapack-netlib/BLAS/SRC/dgemv.f +++ b/lapack-netlib/BLAS/SRC/dgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -156,10 +156,10 @@ * ===================================================================== SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dger.f b/lapack-netlib/BLAS/SRC/dger.f index a042483703..289141e8e8 100644 --- a/lapack-netlib/BLAS/SRC/dger.f +++ b/lapack-netlib/BLAS/SRC/dger.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dnrm2.f b/lapack-netlib/BLAS/SRC/dnrm2.f index 5ea257a200..0d7062fdc0 100644 --- a/lapack-netlib/BLAS/SRC/dnrm2.f +++ b/lapack-netlib/BLAS/SRC/dnrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION X(*) * .. -* +* * *> \par Purpose: * ============= @@ -32,12 +32,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -54,10 +54,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/drot.f b/lapack-netlib/BLAS/SRC/drot.f index 1615ef6a87..baaae5c9fc 100644 --- a/lapack-netlib/BLAS/SRC/drot.f +++ b/lapack-netlib/BLAS/SRC/drot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION C,S * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION C,S diff --git a/lapack-netlib/BLAS/SRC/drotg.f b/lapack-netlib/BLAS/SRC/drotg.f index 1026151136..85d04cd8f4 100644 --- a/lapack-netlib/BLAS/SRC/drotg.f +++ b/lapack-netlib/BLAS/SRC/drotg.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DROTG(DA,DB,C,S) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION C,DA,DB,S * .. -* +* * *> \par Purpose: * ============= @@ -26,12 +26,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -46,10 +46,10 @@ * ===================================================================== SUBROUTINE DROTG(DA,DB,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION C,DA,DB,S diff --git a/lapack-netlib/BLAS/SRC/drotm.f b/lapack-netlib/BLAS/SRC/drotm.f index 538af67be9..b006dbd50a 100644 --- a/lapack-netlib/BLAS/SRC/drotm.f +++ b/lapack-netlib/BLAS/SRC/drotm.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DPARAM(5),DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/drotmg.f b/lapack-netlib/BLAS/SRC/drotmg.f index d18d258f04..1fb025faab 100644 --- a/lapack-netlib/BLAS/SRC/drotmg.f +++ b/lapack-netlib/BLAS/SRC/drotmg.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DD1,DD2,DX1,DY1 * .. * .. Array Arguments .. * DOUBLE PRECISION DPARAM(5) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DD1,DD2,DX1,DY1 @@ -135,7 +135,7 @@ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) DFLAG = -TWO DPARAM(1) = DFLAG RETURN - END IF + END IF * REGULAR-CASE.. DP1 = DD1*DX1 DQ2 = DP2*DY1 @@ -203,7 +203,7 @@ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) END IF ENDDO END IF - + IF (DD2.NE.ZERO) THEN DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) IF (DFLAG.EQ.ZERO) THEN @@ -223,10 +223,10 @@ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) DD2 = DD2/GAM**2 DH21 = DH21*GAM DH22 = DH22*GAM - END IF + END IF END DO END IF - + END IF IF (DFLAG.LT.ZERO) THEN @@ -236,7 +236,7 @@ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) DPARAM(5) = DH22 ELSE IF (DFLAG.EQ.ZERO) THEN DPARAM(3) = DH21 - DPARAM(4) = DH12 + DPARAM(4) = DH12 ELSE DPARAM(2) = DH11 DPARAM(5) = DH22 @@ -245,7 +245,7 @@ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) DPARAM(1) = DFLAG RETURN END - - - - + + + + diff --git a/lapack-netlib/BLAS/SRC/dsbmv.f b/lapack-netlib/BLAS/SRC/dsbmv.f index 734668b09e..aea1213451 100644 --- a/lapack-netlib/BLAS/SRC/dsbmv.f +++ b/lapack-netlib/BLAS/SRC/dsbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,K,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -157,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -184,10 +184,10 @@ * ===================================================================== SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dscal.f b/lapack-netlib/BLAS/SRC/dscal.f index 3337de8e63..8bbfec6f3f 100644 --- a/lapack-netlib/BLAS/SRC/dscal.f +++ b/lapack-netlib/BLAS/SRC/dscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSCAL(N,DA,DX,INCX) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -53,10 +53,10 @@ * ===================================================================== SUBROUTINE DSCAL(N,DA,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lapack-netlib/BLAS/SRC/dsdot.f b/lapack-netlib/BLAS/SRC/dsdot.f index f95a9ab5e9..f9cb498025 100644 --- a/lapack-netlib/BLAS/SRC/dsdot.f +++ b/lapack-netlib/BLAS/SRC/dsdot.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * AUTHORS * ======= -* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), * Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) -* +* * *> \par Purpose: * ============= @@ -79,12 +79,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -99,7 +99,7 @@ *> *> \verbatim *> -*> +*> *> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. *> Krogh, Basic linear algebra subprograms for Fortran *> usage, Algorithm No. 539, Transactions on Mathematical @@ -119,10 +119,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N @@ -133,7 +133,7 @@ DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) * * Authors: * ======== -* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), * Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) * * ===================================================================== diff --git a/lapack-netlib/BLAS/SRC/dspmv.f b/lapack-netlib/BLAS/SRC/dspmv.f index fd3e2a04d9..72a28fedeb 100644 --- a/lapack-netlib/BLAS/SRC/dspmv.f +++ b/lapack-netlib/BLAS/SRC/dspmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dspr.f b/lapack-netlib/BLAS/SRC/dspr.f index 6a575e7d5f..e89f87d4e8 100644 --- a/lapack-netlib/BLAS/SRC/dspr.f +++ b/lapack-netlib/BLAS/SRC/dspr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dspr2.f b/lapack-netlib/BLAS/SRC/dspr2.f index 5861b29ace..4cd416f574 100644 --- a/lapack-netlib/BLAS/SRC/dspr2.f +++ b/lapack-netlib/BLAS/SRC/dspr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dswap.f b/lapack-netlib/BLAS/SRC/dswap.f index e567bd93ec..5bd8f7d29f 100644 --- a/lapack-netlib/BLAS/SRC/dswap.f +++ b/lapack-netlib/BLAS/SRC/dswap.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*),DY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/dsymm.f b/lapack-netlib/BLAS/SRC/dsymm.f index ee8df4df4b..77c797ea6a 100644 --- a/lapack-netlib/BLAS/SRC/dsymm.f +++ b/lapack-netlib/BLAS/SRC/dsymm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dsymv.f b/lapack-netlib/BLAS/SRC/dsymv.f index 5522023834..af2dfd2a2b 100644 --- a/lapack-netlib/BLAS/SRC/dsymv.f +++ b/lapack-netlib/BLAS/SRC/dsymv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -152,10 +152,10 @@ * ===================================================================== SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dsyr.f b/lapack-netlib/BLAS/SRC/dsyr.f index 0b8a762817..c998ee8218 100644 --- a/lapack-netlib/BLAS/SRC/dsyr.f +++ b/lapack-netlib/BLAS/SRC/dsyr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -132,10 +132,10 @@ * ===================================================================== SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dsyr2.f b/lapack-netlib/BLAS/SRC/dsyr2.f index 05e148105c..8bfa5fe0f5 100644 --- a/lapack-netlib/BLAS/SRC/dsyr2.f +++ b/lapack-netlib/BLAS/SRC/dsyr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dsyr2k.f b/lapack-netlib/BLAS/SRC/dsyr2k.f index 2dde293eae..6dd7ca2957 100644 --- a/lapack-netlib/BLAS/SRC/dsyr2k.f +++ b/lapack-netlib/BLAS/SRC/dsyr2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDB,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dsyrk.f b/lapack-netlib/BLAS/SRC/dsyrk.f index d91c3369f6..bd70dfba0c 100644 --- a/lapack-netlib/BLAS/SRC/dsyrk.f +++ b/lapack-netlib/BLAS/SRC/dsyrk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -169,10 +169,10 @@ * ===================================================================== SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/dtbmv.f b/lapack-netlib/BLAS/SRC/dtbmv.f index 86e027f87c..20dd83eac2 100644 --- a/lapack-netlib/BLAS/SRC/dtbmv.f +++ b/lapack-netlib/BLAS/SRC/dtbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -146,7 +146,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/dtbsv.f b/lapack-netlib/BLAS/SRC/dtbsv.f index 5e25a927b8..ad468288de 100644 --- a/lapack-netlib/BLAS/SRC/dtbsv.f +++ b/lapack-netlib/BLAS/SRC/dtbsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/dtpmv.f b/lapack-netlib/BLAS/SRC/dtpmv.f index 5af8f1d9a5..3b0e620945 100644 --- a/lapack-netlib/BLAS/SRC/dtpmv.f +++ b/lapack-netlib/BLAS/SRC/dtpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -102,7 +102,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/dtpsv.f b/lapack-netlib/BLAS/SRC/dtpsv.f index 9376f21a04..a5d9faa482 100644 --- a/lapack-netlib/BLAS/SRC/dtpsv.f +++ b/lapack-netlib/BLAS/SRC/dtpsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/dtrmm.f b/lapack-netlib/BLAS/SRC/dtrmm.f index cbd5ce7034..e315d5960f 100644 --- a/lapack-netlib/BLAS/SRC/dtrmm.f +++ b/lapack-netlib/BLAS/SRC/dtrmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dtrmv.f b/lapack-netlib/BLAS/SRC/dtrmv.f index 71459fe7c8..83959d064a 100644 --- a/lapack-netlib/BLAS/SRC/dtrmv.f +++ b/lapack-netlib/BLAS/SRC/dtrmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/dtrsm.f b/lapack-netlib/BLAS/SRC/dtrsm.f index 065df9a153..bc440f068f 100644 --- a/lapack-netlib/BLAS/SRC/dtrsm.f +++ b/lapack-netlib/BLAS/SRC/dtrsm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -112,7 +112,7 @@ *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array of DIMENSION ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' +*> where k is m when SIDE = 'L' or 'l' *> and k is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level3 * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/dtrsv.f b/lapack-netlib/BLAS/SRC/dtrsv.f index e54303a93a..cab3fd9895 100644 --- a/lapack-netlib/BLAS/SRC/dtrsv.f +++ b/lapack-netlib/BLAS/SRC/dtrsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -131,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * * ===================================================================== SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/dzasum.f b/lapack-netlib/BLAS/SRC/dzasum.f index fe5faaa63a..9f0d3fd08b 100644 --- a/lapack-netlib/BLAS/SRC/dzasum.f +++ b/lapack-netlib/BLAS/SRC/dzasum.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/dznrm2.f b/lapack-netlib/BLAS/SRC/dznrm2.f index b5713a2bfa..3b6bf61328 100644 --- a/lapack-netlib/BLAS/SRC/dznrm2.f +++ b/lapack-netlib/BLAS/SRC/dznrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX*16 X(*) * .. -* +* * *> \par Purpose: * ============= @@ -32,12 +32,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_blas_level1 * @@ -54,10 +54,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/icamax.f b/lapack-netlib/BLAS/SRC/icamax.f index e9dee107b5..37035c7afe 100644 --- a/lapack-netlib/BLAS/SRC/icamax.f +++ b/lapack-netlib/BLAS/SRC/icamax.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION ICAMAX(N,CX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX CX(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup aux_blas * @@ -51,10 +51,10 @@ * ===================================================================== INTEGER FUNCTION ICAMAX(N,CX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/idamax.f b/lapack-netlib/BLAS/SRC/idamax.f index 845a71b5e5..9585660289 100644 --- a/lapack-netlib/BLAS/SRC/idamax.f +++ b/lapack-netlib/BLAS/SRC/idamax.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION IDAMAX(N,DX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * DOUBLE PRECISION DX(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup aux_blas * @@ -51,10 +51,10 @@ * ===================================================================== INTEGER FUNCTION IDAMAX(N,DX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/isamax.f b/lapack-netlib/BLAS/SRC/isamax.f index 79d944b986..e73122353f 100644 --- a/lapack-netlib/BLAS/SRC/isamax.f +++ b/lapack-netlib/BLAS/SRC/isamax.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION ISAMAX(N,SX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * REAL SX(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup aux_blas * @@ -51,10 +51,10 @@ * ===================================================================== INTEGER FUNCTION ISAMAX(N,SX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/izamax.f b/lapack-netlib/BLAS/SRC/izamax.f index 71cb2a6641..2ee9b66435 100644 --- a/lapack-netlib/BLAS/SRC/izamax.f +++ b/lapack-netlib/BLAS/SRC/izamax.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION IZAMAX(N,ZX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup aux_blas * @@ -51,10 +51,10 @@ * ===================================================================== INTEGER FUNCTION IZAMAX(N,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/lsame.f b/lapack-netlib/BLAS/SRC/lsame.f index f19f9cda9e..d819478696 100644 --- a/lapack-netlib/BLAS/SRC/lsame.f +++ b/lapack-netlib/BLAS/SRC/lsame.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION LSAME(CA,CB) -* +* * .. Scalar Arguments .. * CHARACTER CA,CB * .. -* +* * *> \par Purpose: * ============= @@ -41,12 +41,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_blas * @@ -56,7 +56,7 @@ LOGICAL FUNCTION LSAME(CA,CB) * -- Reference BLAS level1 routine (version 3.1) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER CA,CB diff --git a/lapack-netlib/BLAS/SRC/sasum.f b/lapack-netlib/BLAS/SRC/sasum.f index 46a4ecc1b6..a453ff7087 100644 --- a/lapack-netlib/BLAS/SRC/sasum.f +++ b/lapack-netlib/BLAS/SRC/sasum.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SASUM(N,SX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * REAL SX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== REAL FUNCTION SASUM(N,SX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/saxpy.f b/lapack-netlib/BLAS/SRC/saxpy.f index 3fd45d73f5..610dfe795a 100644 --- a/lapack-netlib/BLAS/SRC/saxpy.f +++ b/lapack-netlib/BLAS/SRC/saxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * REAL SA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL SA diff --git a/lapack-netlib/BLAS/SRC/scabs1.f b/lapack-netlib/BLAS/SRC/scabs1.f index d76aeb6572..b68f76f2f9 100644 --- a/lapack-netlib/BLAS/SRC/scabs1.f +++ b/lapack-netlib/BLAS/SRC/scabs1.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SCABS1(Z) -* +* * .. Scalar Arguments .. * COMPLEX Z * .. -* +* * *> \par Purpose: * ============= @@ -26,22 +26,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_blas_level1 * * ===================================================================== REAL FUNCTION SCABS1(Z) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX Z diff --git a/lapack-netlib/BLAS/SRC/scasum.f b/lapack-netlib/BLAS/SRC/scasum.f index 7601b10a5b..5fc1a56a5a 100644 --- a/lapack-netlib/BLAS/SRC/scasum.f +++ b/lapack-netlib/BLAS/SRC/scasum.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SCASUM(N,CX,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX CX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== REAL FUNCTION SCASUM(N,CX,INCX) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/scnrm2.f b/lapack-netlib/BLAS/SRC/scnrm2.f index 4a581e8e17..4f1f03a5f6 100644 --- a/lapack-netlib/BLAS/SRC/scnrm2.f +++ b/lapack-netlib/BLAS/SRC/scnrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SCNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * COMPLEX X(*) * .. -* +* * *> \par Purpose: * ============= @@ -32,12 +32,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -54,10 +54,10 @@ * ===================================================================== REAL FUNCTION SCNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/scopy.f b/lapack-netlib/BLAS/SRC/scopy.f index 3376fb0192..4755797175 100644 --- a/lapack-netlib/BLAS/SRC/scopy.f +++ b/lapack-netlib/BLAS/SRC/scopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N @@ -85,7 +85,7 @@ SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) SY(I) = SX(I) END DO IF (N.LT.7) RETURN - END IF + END IF MP1 = M + 1 DO I = MP1,N,7 SY(I) = SX(I) @@ -96,7 +96,7 @@ SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) SY(I+5) = SX(I+5) SY(I+6) = SX(I+6) END DO - ELSE + ELSE * * code for unequal increments or equal increments * not equal to 1 diff --git a/lapack-netlib/BLAS/SRC/sdot.f b/lapack-netlib/BLAS/SRC/sdot.f index 68555aad86..5a54ee2490 100644 --- a/lapack-netlib/BLAS/SRC/sdot.f +++ b/lapack-netlib/BLAS/SRC/sdot.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/sdsdot.f b/lapack-netlib/BLAS/SRC/sdsdot.f index 39d3a2e6cb..7ee6ad6bf8 100644 --- a/lapack-netlib/BLAS/SRC/sdsdot.f +++ b/lapack-netlib/BLAS/SRC/sdsdot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * REAL SB * INTEGER INCX,INCY,N @@ -17,59 +17,59 @@ * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * PURPOSE * ======= -* +* * Compute the inner product of two vectors with extended * precision accumulation. -* +* * Returns S.P. result with dot product accumulated in D.P. * SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), * where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is * defined in a similar way using INCY. -* +* * AUTHOR * ====== * Lawson, C. L., (JPL), Hanson, R. J., (SNLA), * Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) -* -* ARGUMENTS +* +* ARGUMENTS * ========= -* +* * N (input) INTEGER * number of elements in input vector(s) -* +* * SB (input) REAL * single precision scalar to be added to inner product -* +* * SX (input) REAL array, dimension (N) * single precision vector with N elements -* +* * INCX (input) INTEGER * storage spacing between elements of SX -* +* * SY (input) REAL array, dimension (N) * single precision vector with N elements -* +* * INCY (input) INTEGER * storage spacing between elements of SY -* +* * SDSDOT (output) REAL * single precision dot product (SB if N .LE. 0) -* +* * Further Details * =============== -* +* * REFERENCES -* +* * C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. * Krogh, Basic linear algebra subprograms for Fortran * usage, Algorithm No. 539, Transactions on Mathematical * Software 5, 3 (September 1979), pp. 308-323. -* +* * REVISION HISTORY (YYMMDD) -* +* * 791001 DATE WRITTEN * 890531 Changed all specific intrinsics to generic. (WRB) * 890831 Modified array declarations. (WRB) @@ -78,9 +78,9 @@ * 920310 Corrected definition of LX in DESCRIPTION. (WRB) * 920501 Reformatted the REFERENCES section. (WRB) * 070118 Reformat to LAPACK coding style -* +* * ===================================================================== -* +* * .. Local Scalars .. * DOUBLE PRECISION DSDOT * INTEGER I,KX,KY,NS @@ -92,19 +92,19 @@ * IF (N.LE.0) THEN * SDSDOT = DSDOT * RETURN -* END IF +* END IF * IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN -* +* * Code for equal and positive increments. -* +* * NS = N*INCX * DO I = 1,NS,INCX * DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) * END DO * ELSE -* +* * Code for unequal or nonpositive increments. -* +* * KX = 1 * KY = 1 * IF (INCX.LT.0) KX = 1 + (1-N)*INCX @@ -128,22 +128,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * * ===================================================================== REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL SB @@ -169,7 +169,7 @@ REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) * Lawson, C. L., (JPL), Hanson, R. J., (SNLA), * Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) * -* ARGUMENTS +* ARGUMENTS * ========= * * N (input) INTEGER @@ -204,7 +204,7 @@ REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) * Software 5, 3 (September 1979), pp. 308-323. * * REVISION HISTORY (YYMMDD) -* +* * 791001 DATE WRITTEN * 890531 Changed all specific intrinsics to generic. (WRB) * 890831 Modified array declarations. (WRB) @@ -227,7 +227,7 @@ REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) IF (N.LE.0) THEN SDSDOT = DSDOT RETURN - END IF + END IF IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN * * Code for equal and positive increments. diff --git a/lapack-netlib/BLAS/SRC/sgbmv.f b/lapack-netlib/BLAS/SRC/sgbmv.f index 51fe8527e8..92896324ea 100644 --- a/lapack-netlib/BLAS/SRC/sgbmv.f +++ b/lapack-netlib/BLAS/SRC/sgbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER INCX,INCY,KL,KU,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/sgemm.f b/lapack-netlib/BLAS/SRC/sgemm.f index e310110013..d7bdb9c4dd 100644 --- a/lapack-netlib/BLAS/SRC/sgemm.f +++ b/lapack-netlib/BLAS/SRC/sgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/sgemv.f b/lapack-netlib/BLAS/SRC/sgemv.f index 1d47e82d98..0dfb1fc084 100644 --- a/lapack-netlib/BLAS/SRC/sgemv.f +++ b/lapack-netlib/BLAS/SRC/sgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -156,10 +156,10 @@ * ===================================================================== SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/sger.f b/lapack-netlib/BLAS/SRC/sger.f index cf85ffdc0b..c2a9958f95 100644 --- a/lapack-netlib/BLAS/SRC/sger.f +++ b/lapack-netlib/BLAS/SRC/sger.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/snrm2.f b/lapack-netlib/BLAS/SRC/snrm2.f index a3674a6d7e..7de03d222f 100644 --- a/lapack-netlib/BLAS/SRC/snrm2.f +++ b/lapack-netlib/BLAS/SRC/snrm2.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SNRM2(N,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * .. * .. Array Arguments .. * REAL X(*) * .. -* +* * *> \par Purpose: * ============= @@ -32,12 +32,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -54,10 +54,10 @@ * ===================================================================== REAL FUNCTION SNRM2(N,X,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/srot.f b/lapack-netlib/BLAS/SRC/srot.f index c326e1c789..fa8e2958ff 100644 --- a/lapack-netlib/BLAS/SRC/srot.f +++ b/lapack-netlib/BLAS/SRC/srot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) -* +* * .. Scalar Arguments .. * REAL C,S * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL C,S diff --git a/lapack-netlib/BLAS/SRC/srotg.f b/lapack-netlib/BLAS/SRC/srotg.f index 90ba220ebf..b4484fb343 100644 --- a/lapack-netlib/BLAS/SRC/srotg.f +++ b/lapack-netlib/BLAS/SRC/srotg.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SROTG(SA,SB,C,S) -* +* * .. Scalar Arguments .. * REAL C,S,SA,SB * .. -* +* * *> \par Purpose: * ============= @@ -26,12 +26,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -46,10 +46,10 @@ * ===================================================================== SUBROUTINE SROTG(SA,SB,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL C,S,SA,SB diff --git a/lapack-netlib/BLAS/SRC/srotm.f b/lapack-netlib/BLAS/SRC/srotm.f index f465f4483a..c71f7f0129 100644 --- a/lapack-netlib/BLAS/SRC/srotm.f +++ b/lapack-netlib/BLAS/SRC/srotm.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * REAL SPARAM(5),SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * * ===================================================================== SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/srotmg.f b/lapack-netlib/BLAS/SRC/srotmg.f index 9a41e0a9dc..a5077c0691 100644 --- a/lapack-netlib/BLAS/SRC/srotmg.f +++ b/lapack-netlib/BLAS/SRC/srotmg.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) -* +* * .. Scalar Arguments .. * REAL SD1,SD2,SX1,SY1 * .. * .. Array Arguments .. * REAL SPARAM(5) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * * ===================================================================== SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL SD1,SD2,SX1,SY1 @@ -135,7 +135,7 @@ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) SFLAG = -TWO SPARAM(1) = SFLAG RETURN - END IF + END IF * REGULAR-CASE.. SP1 = SD1*SX1 SQ2 = SP2*SY1 @@ -203,7 +203,7 @@ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) END IF ENDDO END IF - + IF (SD2.NE.ZERO) THEN DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) IF (SFLAG.EQ.ZERO) THEN @@ -223,10 +223,10 @@ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) SD2 = SD2/GAM**2 SH21 = SH21*GAM SH22 = SH22*GAM - END IF + END IF END DO END IF - + END IF IF (SFLAG.LT.ZERO) THEN @@ -236,7 +236,7 @@ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) SPARAM(5) = SH22 ELSE IF (SFLAG.EQ.ZERO) THEN SPARAM(3) = SH21 - SPARAM(4) = SH12 + SPARAM(4) = SH12 ELSE SPARAM(2) = SH11 SPARAM(5) = SH22 @@ -245,7 +245,7 @@ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) SPARAM(1) = SFLAG RETURN END - - - - + + + + diff --git a/lapack-netlib/BLAS/SRC/ssbmv.f b/lapack-netlib/BLAS/SRC/ssbmv.f index 483f80bfd9..b711d8b06f 100644 --- a/lapack-netlib/BLAS/SRC/ssbmv.f +++ b/lapack-netlib/BLAS/SRC/ssbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER INCX,INCY,K,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -157,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -184,10 +184,10 @@ * ===================================================================== SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/sscal.f b/lapack-netlib/BLAS/SRC/sscal.f index b4b086252b..2ffc1a254f 100644 --- a/lapack-netlib/BLAS/SRC/sscal.f +++ b/lapack-netlib/BLAS/SRC/sscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSCAL(N,SA,SX,INCX) -* +* * .. Scalar Arguments .. * REAL SA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL SX(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -53,10 +53,10 @@ * ===================================================================== SUBROUTINE SSCAL(N,SA,SX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL SA diff --git a/lapack-netlib/BLAS/SRC/sspmv.f b/lapack-netlib/BLAS/SRC/sspmv.f index b19f902b72..bc8af3d448 100644 --- a/lapack-netlib/BLAS/SRC/sspmv.f +++ b/lapack-netlib/BLAS/SRC/sspmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/sspr.f b/lapack-netlib/BLAS/SRC/sspr.f index 9350cea0b5..52cb731705 100644 --- a/lapack-netlib/BLAS/SRC/sspr.f +++ b/lapack-netlib/BLAS/SRC/sspr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/sspr2.f b/lapack-netlib/BLAS/SRC/sspr2.f index 50fa67c489..b4c81187c9 100644 --- a/lapack-netlib/BLAS/SRC/sspr2.f +++ b/lapack-netlib/BLAS/SRC/sspr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/sswap.f b/lapack-netlib/BLAS/SRC/sswap.f index ad5a7f5c61..f821a1e70f 100644 --- a/lapack-netlib/BLAS/SRC/sswap.f +++ b/lapack-netlib/BLAS/SRC/sswap.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * REAL SX(*),SY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/ssymm.f b/lapack-netlib/BLAS/SRC/ssymm.f index ac10d0b347..d3a193f764 100644 --- a/lapack-netlib/BLAS/SRC/ssymm.f +++ b/lapack-netlib/BLAS/SRC/ssymm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/ssymv.f b/lapack-netlib/BLAS/SRC/ssymv.f index 2b9ef1775f..a1fa54f10e 100644 --- a/lapack-netlib/BLAS/SRC/ssymv.f +++ b/lapack-netlib/BLAS/SRC/ssymv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -152,10 +152,10 @@ * ===================================================================== SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/ssyr.f b/lapack-netlib/BLAS/SRC/ssyr.f index 18a1a913be..9d73f86867 100644 --- a/lapack-netlib/BLAS/SRC/ssyr.f +++ b/lapack-netlib/BLAS/SRC/ssyr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -132,10 +132,10 @@ * ===================================================================== SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/ssyr2.f b/lapack-netlib/BLAS/SRC/ssyr2.f index 4c90ae8fcd..a2a083adc3 100644 --- a/lapack-netlib/BLAS/SRC/ssyr2.f +++ b/lapack-netlib/BLAS/SRC/ssyr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/ssyr2k.f b/lapack-netlib/BLAS/SRC/ssyr2k.f index 435e9969b0..4a705f79c1 100644 --- a/lapack-netlib/BLAS/SRC/ssyr2k.f +++ b/lapack-netlib/BLAS/SRC/ssyr2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER K,LDA,LDB,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/ssyrk.f b/lapack-netlib/BLAS/SRC/ssyrk.f index c428029d32..ecb1e4f17b 100644 --- a/lapack-netlib/BLAS/SRC/ssyrk.f +++ b/lapack-netlib/BLAS/SRC/ssyrk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * REAL ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -169,10 +169,10 @@ * ===================================================================== SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/stbmv.f b/lapack-netlib/BLAS/SRC/stbmv.f index bd5036c085..4323864ecb 100644 --- a/lapack-netlib/BLAS/SRC/stbmv.f +++ b/lapack-netlib/BLAS/SRC/stbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -146,7 +146,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/stbsv.f b/lapack-netlib/BLAS/SRC/stbsv.f index 4c313479e2..00aaeba67a 100644 --- a/lapack-netlib/BLAS/SRC/stbsv.f +++ b/lapack-netlib/BLAS/SRC/stbsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/stpmv.f b/lapack-netlib/BLAS/SRC/stpmv.f index e66dc4cee8..765e7f9183 100644 --- a/lapack-netlib/BLAS/SRC/stpmv.f +++ b/lapack-netlib/BLAS/SRC/stpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -102,7 +102,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/stpsv.f b/lapack-netlib/BLAS/SRC/stpsv.f index 9c58591c6e..5a29776da8 100644 --- a/lapack-netlib/BLAS/SRC/stpsv.f +++ b/lapack-netlib/BLAS/SRC/stpsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/strmm.f b/lapack-netlib/BLAS/SRC/strmm.f index e713d19518..dd20872188 100644 --- a/lapack-netlib/BLAS/SRC/strmm.f +++ b/lapack-netlib/BLAS/SRC/strmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/strmv.f b/lapack-netlib/BLAS/SRC/strmv.f index 8f3a36f119..ba3d7b6a8d 100644 --- a/lapack-netlib/BLAS/SRC/strmv.f +++ b/lapack-netlib/BLAS/SRC/strmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/strsm.f b/lapack-netlib/BLAS/SRC/strsm.f index dad4bb0573..f2927fe3b7 100644 --- a/lapack-netlib/BLAS/SRC/strsm.f +++ b/lapack-netlib/BLAS/SRC/strsm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * REAL ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -112,7 +112,7 @@ *> \param[in] A *> \verbatim *> A is REAL array of DIMENSION ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' +*> where k is m when SIDE = 'L' or 'l' *> and k is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level3 * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA diff --git a/lapack-netlib/BLAS/SRC/strsv.f b/lapack-netlib/BLAS/SRC/strsv.f index 03262fb043..a31651b9af 100644 --- a/lapack-netlib/BLAS/SRC/strsv.f +++ b/lapack-netlib/BLAS/SRC/strsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_blas_level2 * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/xerbla.f b/lapack-netlib/BLAS/SRC/xerbla.f index eb1c037d27..bbe6cceb2b 100644 --- a/lapack-netlib/BLAS/SRC/xerbla.f +++ b/lapack-netlib/BLAS/SRC/xerbla.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. -* +* * *> \par Purpose: * ============= @@ -48,22 +48,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_blas * * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*(*) SRNAME diff --git a/lapack-netlib/BLAS/SRC/xerbla_array.f b/lapack-netlib/BLAS/SRC/xerbla_array.f index e2145a6cca..df4e627381 100644 --- a/lapack-netlib/BLAS/SRC/xerbla_array.f +++ b/lapack-netlib/BLAS/SRC/xerbla_array.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) -* +* * .. Scalar Arguments .. * INTEGER SRNAME_LEN, INFO * .. * .. Array Arguments .. * CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) * .. -* +* * *> \par Purpose: * ============= @@ -68,22 +68,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_blas * * ===================================================================== SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER SRNAME_LEN, INFO diff --git a/lapack-netlib/BLAS/SRC/zaxpy.f b/lapack-netlib/BLAS/SRC/zaxpy.f index e6f5e1f6db..bca78fb76e 100644 --- a/lapack-netlib/BLAS/SRC/zaxpy.f +++ b/lapack-netlib/BLAS/SRC/zaxpy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ZA * INTEGER INCX,INCY,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -51,10 +51,10 @@ * ===================================================================== SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ZA diff --git a/lapack-netlib/BLAS/SRC/zcopy.f b/lapack-netlib/BLAS/SRC/zcopy.f index baeafd5c3b..830548ab6a 100644 --- a/lapack-netlib/BLAS/SRC/zcopy.f +++ b/lapack-netlib/BLAS/SRC/zcopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -50,10 +50,10 @@ * ===================================================================== SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/zdotc.f b/lapack-netlib/BLAS/SRC/zdotc.f index a425b471d1..70119ec58f 100644 --- a/lapack-netlib/BLAS/SRC/zdotc.f +++ b/lapack-netlib/BLAS/SRC/zdotc.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/zdotu.f b/lapack-netlib/BLAS/SRC/zdotu.f index 8ea711536b..318fae24e0 100644 --- a/lapack-netlib/BLAS/SRC/zdotu.f +++ b/lapack-netlib/BLAS/SRC/zdotu.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -31,12 +31,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/zdrot.f b/lapack-netlib/BLAS/SRC/zdrot.f index f8bdcd79d6..8a4cf652a2 100644 --- a/lapack-netlib/BLAS/SRC/zdrot.f +++ b/lapack-netlib/BLAS/SRC/zdrot.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * DOUBLE PRECISION C, S @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * * ===================================================================== SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S ) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/BLAS/SRC/zdscal.f b/lapack-netlib/BLAS/SRC/zdscal.f index 57a9490237..def90785a8 100644 --- a/lapack-netlib/BLAS/SRC/zdscal.f +++ b/lapack-netlib/BLAS/SRC/zdscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDSCAL(N,DA,ZX,INCX) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE ZDSCAL(N,DA,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DA diff --git a/lapack-netlib/BLAS/SRC/zgbmv.f b/lapack-netlib/BLAS/SRC/zgbmv.f index 130d30f406..f49da22186 100644 --- a/lapack-netlib/BLAS/SRC/zgbmv.f +++ b/lapack-netlib/BLAS/SRC/zgbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,KL,KU,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -160,12 +160,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zgemm.f b/lapack-netlib/BLAS/SRC/zgemm.f index 0f16f72368..a172632102 100644 --- a/lapack-netlib/BLAS/SRC/zgemm.f +++ b/lapack-netlib/BLAS/SRC/zgemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER K,LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zgemv.f b/lapack-netlib/BLAS/SRC/zgemv.f index bbab583553..01e44d467a 100644 --- a/lapack-netlib/BLAS/SRC/zgemv.f +++ b/lapack-netlib/BLAS/SRC/zgemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,LDA,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -158,10 +158,10 @@ * ===================================================================== SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zgerc.f b/lapack-netlib/BLAS/SRC/zgerc.f index accfeafc05..cf8e17d357 100644 --- a/lapack-netlib/BLAS/SRC/zgerc.f +++ b/lapack-netlib/BLAS/SRC/zgerc.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/zgeru.f b/lapack-netlib/BLAS/SRC/zgeru.f index bf23ed7f07..d191740cce 100644 --- a/lapack-netlib/BLAS/SRC/zgeru.f +++ b/lapack-netlib/BLAS/SRC/zgeru.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,LDA,M,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/zhbmv.f b/lapack-netlib/BLAS/SRC/zhbmv.f index 6a668c205f..87422152c2 100644 --- a/lapack-netlib/BLAS/SRC/zhbmv.f +++ b/lapack-netlib/BLAS/SRC/zhbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,K,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -160,12 +160,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zhemm.f b/lapack-netlib/BLAS/SRC/zhemm.f index 77abea143e..45a5eabd74 100644 --- a/lapack-netlib/BLAS/SRC/zhemm.f +++ b/lapack-netlib/BLAS/SRC/zhemm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zhemv.f b/lapack-netlib/BLAS/SRC/zhemv.f index 34216fbfff..37917459ab 100644 --- a/lapack-netlib/BLAS/SRC/zhemv.f +++ b/lapack-netlib/BLAS/SRC/zhemv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -154,10 +154,10 @@ * ===================================================================== SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zher.f b/lapack-netlib/BLAS/SRC/zher.f index 0edc1191bf..f7def76088 100644 --- a/lapack-netlib/BLAS/SRC/zher.f +++ b/lapack-netlib/BLAS/SRC/zher.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/zher2.f b/lapack-netlib/BLAS/SRC/zher2.f index e2a02c3c68..94c132c4fd 100644 --- a/lapack-netlib/BLAS/SRC/zher2.f +++ b/lapack-netlib/BLAS/SRC/zher2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,LDA,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -150,10 +150,10 @@ * ===================================================================== SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/zher2k.f b/lapack-netlib/BLAS/SRC/zher2k.f index 0b91bd2cbb..407e8db536 100644 --- a/lapack-netlib/BLAS/SRC/zher2k.f +++ b/lapack-netlib/BLAS/SRC/zher2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * DOUBLE PRECISION BETA @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/zherk.f b/lapack-netlib/BLAS/SRC/zherk.f index 7e561e812a..d181ca0a8c 100644 --- a/lapack-netlib/BLAS/SRC/zherk.f +++ b/lapack-netlib/BLAS/SRC/zherk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zhpmv.f b/lapack-netlib/BLAS/SRC/zhpmv.f index 23dad36681..0d5d325bf1 100644 --- a/lapack-netlib/BLAS/SRC/zhpmv.f +++ b/lapack-netlib/BLAS/SRC/zhpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zhpr.f b/lapack-netlib/BLAS/SRC/zhpr.f index 42e61196ba..70051c8a56 100644 --- a/lapack-netlib/BLAS/SRC/zhpr.f +++ b/lapack-netlib/BLAS/SRC/zhpr.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA * INTEGER INCX,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -130,10 +130,10 @@ * ===================================================================== SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA diff --git a/lapack-netlib/BLAS/SRC/zhpr2.f b/lapack-netlib/BLAS/SRC/zhpr2.f index 2c6f353bc0..c9fb758531 100644 --- a/lapack-netlib/BLAS/SRC/zhpr2.f +++ b/lapack-netlib/BLAS/SRC/zhpr2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER INCX,INCY,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*),Y(*) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/zrotg.f b/lapack-netlib/BLAS/SRC/zrotg.f index ca03e0684a..e5c406dbac 100644 --- a/lapack-netlib/BLAS/SRC/zrotg.f +++ b/lapack-netlib/BLAS/SRC/zrotg.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZROTG(CA,CB,C,S) -* +* * .. Scalar Arguments .. * COMPLEX*16 CA,CB,S * DOUBLE PRECISION C * .. -* +* * *> \par Purpose: * ============= @@ -27,22 +27,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * * ===================================================================== SUBROUTINE ZROTG(CA,CB,C,S) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 CA,CB,S diff --git a/lapack-netlib/BLAS/SRC/zscal.f b/lapack-netlib/BLAS/SRC/zscal.f index ad28a10a9b..ca038aacbe 100644 --- a/lapack-netlib/BLAS/SRC/zscal.f +++ b/lapack-netlib/BLAS/SRC/zscal.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* +* * .. Scalar Arguments .. * COMPLEX*16 ZA * INTEGER INCX,N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 ZX(*) * .. -* +* * *> \par Purpose: * ============= @@ -30,12 +30,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -52,10 +52,10 @@ * ===================================================================== SUBROUTINE ZSCAL(N,ZA,ZX,INCX) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ZA diff --git a/lapack-netlib/BLAS/SRC/zswap.f b/lapack-netlib/BLAS/SRC/zswap.f index ca2f347211..02a5b97e81 100644 --- a/lapack-netlib/BLAS/SRC/zswap.f +++ b/lapack-netlib/BLAS/SRC/zswap.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* +* * .. Scalar Arguments .. * INTEGER INCX,INCY,N * .. * .. Array Arguments .. * COMPLEX*16 ZX(*),ZY(*) * .. -* +* * *> \par Purpose: * ============= @@ -29,12 +29,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level1 * @@ -50,10 +50,10 @@ * ===================================================================== SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) * -* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS level1 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,INCY,N diff --git a/lapack-netlib/BLAS/SRC/zsymm.f b/lapack-netlib/BLAS/SRC/zsymm.f index b0ff42e657..1dc267a7ac 100644 --- a/lapack-netlib/BLAS/SRC/zsymm.f +++ b/lapack-netlib/BLAS/SRC/zsymm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER LDA,LDB,LDC,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zsyr2k.f b/lapack-netlib/BLAS/SRC/zsyr2k.f index f46ede1236..d358ed00fd 100644 --- a/lapack-netlib/BLAS/SRC/zsyr2k.f +++ b/lapack-netlib/BLAS/SRC/zsyr2k.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER K,LDA,LDB,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -188,10 +188,10 @@ * ===================================================================== SUBROUTINE ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/zsyrk.f b/lapack-netlib/BLAS/SRC/zsyrk.f index c3484f9943..79591b45ef 100644 --- a/lapack-netlib/BLAS/SRC/zsyrk.f +++ b/lapack-netlib/BLAS/SRC/zsyrk.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA,BETA * INTEGER K,LDA,LDC,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),C(LDC,*) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA,BETA diff --git a/lapack-netlib/BLAS/SRC/ztbmv.f b/lapack-netlib/BLAS/SRC/ztbmv.f index 2b5780b1b6..1e03f2bad9 100644 --- a/lapack-netlib/BLAS/SRC/ztbmv.f +++ b/lapack-netlib/BLAS/SRC/ztbmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -146,7 +146,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ztbsv.f b/lapack-netlib/BLAS/SRC/ztbsv.f index ea2721953a..50c4bb42e6 100644 --- a/lapack-netlib/BLAS/SRC/ztbsv.f +++ b/lapack-netlib/BLAS/SRC/ztbsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,K,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,K,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ztpmv.f b/lapack-netlib/BLAS/SRC/ztpmv.f index e277ec1a6e..d9aae42597 100644 --- a/lapack-netlib/BLAS/SRC/ztpmv.f +++ b/lapack-netlib/BLAS/SRC/ztpmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -102,7 +102,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/ztpsv.f b/lapack-netlib/BLAS/SRC/ztpsv.f index 0e75f9facf..5874fdc435 100644 --- a/lapack-netlib/BLAS/SRC/ztpsv.f +++ b/lapack-netlib/BLAS/SRC/ztpsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 AP(*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,N diff --git a/lapack-netlib/BLAS/SRC/ztrmm.f b/lapack-netlib/BLAS/SRC/ztrmm.f index ba7aead68b..229f3322ba 100644 --- a/lapack-netlib/BLAS/SRC/ztrmm.f +++ b/lapack-netlib/BLAS/SRC/ztrmm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/ztrmv.f b/lapack-netlib/BLAS/SRC/ztrmv.f index 8d7974a059..ab9065cf1c 100644 --- a/lapack-netlib/BLAS/SRC/ztrmv.f +++ b/lapack-netlib/BLAS/SRC/ztrmv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> ( 1 + ( n - 1 )*abs( INCX ) ). *> Before entry, the incremented array X must contain the n *> element vector x. On exit, X is overwritten with the -*> tranformed vector x. +*> transformed vector x. *> \endverbatim *> *> \param[in] INCX @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/SRC/ztrsm.f b/lapack-netlib/BLAS/SRC/ztrsm.f index 8e0125467e..cc1af763d0 100644 --- a/lapack-netlib/BLAS/SRC/ztrsm.f +++ b/lapack-netlib/BLAS/SRC/ztrsm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA * INTEGER LDA,LDB,M,N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),B(LDB,*) * .. -* +* * *> \par Purpose: * ============= @@ -112,7 +112,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX*16 array of DIMENSION ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' +*> where k is m when SIDE = 'L' or 'l' *> and k is n when SIDE = 'R' or 'r'. *> Before entry with UPLO = 'U' or 'u', the leading k by k *> upper triangular part of the array A must contain the upper @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level3 * @@ -180,10 +180,10 @@ * ===================================================================== SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * -* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS level3 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA diff --git a/lapack-netlib/BLAS/SRC/ztrsv.f b/lapack-netlib/BLAS/SRC/ztrsv.f index f9fd4f8407..577b5cae30 100644 --- a/lapack-netlib/BLAS/SRC/ztrsv.f +++ b/lapack-netlib/BLAS/SRC/ztrsv.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* +* * .. Scalar Arguments .. * INTEGER INCX,LDA,N * CHARACTER DIAG,TRANS,UPLO @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A(LDA,*),X(*) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_blas_level2 * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) * -* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS level2 routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX,LDA,N diff --git a/lapack-netlib/BLAS/TESTING/CMakeLists.txt b/lapack-netlib/BLAS/TESTING/CMakeLists.txt index b6e5a5c250..f88c9a8ac9 100644 --- a/lapack-netlib/BLAS/TESTING/CMakeLists.txt +++ b/lapack-netlib/BLAS/TESTING/CMakeLists.txt @@ -37,13 +37,13 @@ macro(add_blas_test name src) -DINPUT=${TEST_INPUT} -DINTDIR=${CMAKE_CFG_INTDIR} -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") - else() - add_test(NAME BLAS-${name} COMMAND "${CMAKE_COMMAND}" - -DTEST=$ - -DINTDIR=${CMAKE_CFG_INTDIR} - -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") - endif() -endmacro(add_blas_test) + else() + add_test(NAME BLAS-${name} COMMAND "${CMAKE_COMMAND}" + -DTEST=$ + -DINTDIR=${CMAKE_CFG_INTDIR} + -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") + endif() +endmacro() if(BUILD_SINGLE) add_blas_test(xblat1s sblat1.f) diff --git a/lapack-netlib/BLAS/TESTING/Makeblat1 b/lapack-netlib/BLAS/TESTING/Makeblat1 index 4492d8fe4f..ccd7e3c6e2 100644 --- a/lapack-netlib/BLAS/TESTING/Makeblat1 +++ b/lapack-netlib/BLAS/TESTING/Makeblat1 @@ -1,5 +1,5 @@ include ../../make.inc - + ####################################################################### # This makefile creates the test programs for the BLAS 1 routines. # The test files are grouped as follows: @@ -28,15 +28,12 @@ include ../../make.inc # ####################################################################### -SBLAT1 = sblat1.o - -CBLAT1 = cblat1.o - -DBLAT1 = dblat1.o - +SBLAT1 = sblat1.o +CBLAT1 = cblat1.o +DBLAT1 = dblat1.o ZBLAT1 = zblat1.o -all: single double complex complex16 +all: single double complex complex16 single: ../xblat1s double: ../xblat1d @@ -44,31 +41,27 @@ complex: ../xblat1c complex16: ../xblat1z ../xblat1s: $(SBLAT1) - $(LOADER) $(LOADOPTS) $(SBLAT1) \ - $(BLASLIB) -o ../xblat1s + $(LOADER) $(LOADOPTS) -o $@ $(SBLAT1) $(BLASLIB) + +../xblat1c: $(CBLAT1) + $(LOADER) $(LOADOPTS) -o $@ $(CBLAT1) $(BLASLIB) + +../xblat1d: $(DBLAT1) + $(LOADER) $(LOADOPTS) -o $@ $(DBLAT1) $(BLASLIB) + +../xblat1z: $(ZBLAT1) + $(LOADER) $(LOADOPTS) -o $@ $(ZBLAT1) $(BLASLIB) -../xblat1c: $(CBLAT1) - $(LOADER) $(LOADOPTS) $(CBLAT1) \ - $(BLASLIB) -o ../xblat1c - -../xblat1d: $(DBLAT1) - $(LOADER) $(LOADOPTS) $(DBLAT1) \ - $(BLASLIB) -o ../xblat1d - -../xblat1z: $(ZBLAT1) - $(LOADER) $(LOADOPTS) $(ZBLAT1) \ - $(BLASLIB) -o ../xblat1z - $(SBLAT1): $(FRC) $(CBLAT1): $(FRC) $(DBLAT1): $(FRC) $(ZBLAT1): $(FRC) - + FRC: @FRC=$(FRC) - + clean: rm -f *.o - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/BLAS/TESTING/Makeblat2 b/lapack-netlib/BLAS/TESTING/Makeblat2 index 9308993c24..920607889a 100644 --- a/lapack-netlib/BLAS/TESTING/Makeblat2 +++ b/lapack-netlib/BLAS/TESTING/Makeblat2 @@ -1,5 +1,5 @@ include ../../make.inc - + ####################################################################### # This makefile creates the test programs for the BLAS 2 routines. # The test files are grouped as follows: @@ -28,15 +28,12 @@ include ../../make.inc # ####################################################################### -SBLAT2 = sblat2.o - -CBLAT2 = cblat2.o - -DBLAT2 = dblat2.o - +SBLAT2 = sblat2.o +CBLAT2 = cblat2.o +DBLAT2 = dblat2.o ZBLAT2 = zblat2.o -all: single double complex complex16 +all: single double complex complex16 single: ../xblat2s double: ../xblat2d @@ -44,31 +41,27 @@ complex: ../xblat2c complex16: ../xblat2z ../xblat2s: $(SBLAT2) - $(LOADER) $(LOADOPTS) $(SBLAT2) \ - $(BLASLIB) -o ../xblat2s + $(LOADER) $(LOADOPTS) -o $@ $(SBLAT2) $(BLASLIB) + +../xblat2c: $(CBLAT2) + $(LOADER) $(LOADOPTS) -o $@ $(CBLAT2) $(BLASLIB) + +../xblat2d: $(DBLAT2) + $(LOADER) $(LOADOPTS) -o $@ $(DBLAT2) $(BLASLIB) + +../xblat2z: $(ZBLAT2) + $(LOADER) $(LOADOPTS) -o $@ $(ZBLAT2) $(BLASLIB) -../xblat2c: $(CBLAT2) - $(LOADER) $(LOADOPTS) $(CBLAT2) \ - $(BLASLIB) -o ../xblat2c - -../xblat2d: $(DBLAT2) - $(LOADER) $(LOADOPTS) $(DBLAT2) \ - $(BLASLIB) -o ../xblat2d - -../xblat2z: $(ZBLAT2) - $(LOADER) $(LOADOPTS) $(ZBLAT2) \ - $(BLASLIB) -o ../xblat2z - $(SBLAT2): $(FRC) $(CBLAT2): $(FRC) $(DBLAT2): $(FRC) $(ZBLAT2): $(FRC) - + FRC: @FRC=$(FRC) - + clean: rm -f *.o - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/BLAS/TESTING/Makeblat3 b/lapack-netlib/BLAS/TESTING/Makeblat3 index 02e3b87caf..e454b34858 100644 --- a/lapack-netlib/BLAS/TESTING/Makeblat3 +++ b/lapack-netlib/BLAS/TESTING/Makeblat3 @@ -1,5 +1,5 @@ include ../../make.inc - + ####################################################################### # This makefile creates the test programs for the BLAS 3 routines. # The test files are grouped as follows: @@ -29,14 +29,11 @@ include ../../make.inc ####################################################################### SBLAT3 = sblat3.o - -CBLAT3 = cblat3.o - -DBLAT3 = dblat3.o - +CBLAT3 = cblat3.o +DBLAT3 = dblat3.o ZBLAT3 = zblat3.o -all: single double complex complex16 +all: single double complex complex16 single: ../xblat3s double: ../xblat3d @@ -44,31 +41,27 @@ complex: ../xblat3c complex16: ../xblat3z ../xblat3s: $(SBLAT3) - $(LOADER) $(LOADOPTS) $(SBLAT3) \ - $(BLASLIB) -o ../xblat3s + $(LOADER) $(LOADOPTS) -o $@ $(SBLAT3) $(BLASLIB) + +../xblat3c: $(CBLAT3) + $(LOADER) $(LOADOPTS) -o $@ $(CBLAT3) $(BLASLIB) + +../xblat3d: $(DBLAT3) + $(LOADER) $(LOADOPTS) -o $@ $(DBLAT3) $(BLASLIB) + +../xblat3z: $(ZBLAT3) + $(LOADER) $(LOADOPTS) -o $@ $(ZBLAT3) $(BLASLIB) -../xblat3c: $(CBLAT3) - $(LOADER) $(LOADOPTS) $(CBLAT3) \ - $(BLASLIB) -o ../xblat3c - -../xblat3d: $(DBLAT3) - $(LOADER) $(LOADOPTS) $(DBLAT3) \ - $(BLASLIB) -o ../xblat3d - -../xblat3z: $(ZBLAT3) - $(LOADER) $(LOADOPTS) $(ZBLAT3) \ - $(BLASLIB) -o ../xblat3z - $(SBLAT3): $(FRC) $(CBLAT3): $(FRC) $(DBLAT3): $(FRC) $(ZBLAT3): $(FRC) - + FRC: @FRC=$(FRC) - + clean: rm -f *.o - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/BLAS/TESTING/cblat1.f b/lapack-netlib/BLAS/TESTING/cblat1.f index 8ca67fb199..036dca3e04 100644 --- a/lapack-netlib/BLAS/TESTING/cblat1.f +++ b/lapack-netlib/BLAS/TESTING/cblat1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CBLAT1 -* +* * *> \par Purpose: * ============= @@ -25,10 +25,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -37,7 +37,7 @@ * ===================================================================== PROGRAM CBLAT1 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/cblat2.f b/lapack-netlib/BLAS/TESTING/cblat2.f index 5833ea81ae..8c7bac48ea 100644 --- a/lapack-netlib/BLAS/TESTING/cblat2.f +++ b/lapack-netlib/BLAS/TESTING/cblat2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CBLAT2 -* +* * *> \par Purpose: * ============= @@ -91,10 +91,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -103,7 +103,7 @@ * ===================================================================== PROGRAM CBLAT2 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/cblat3.f b/lapack-netlib/BLAS/TESTING/cblat3.f index 09f2cb9c5c..a65e1364cf 100644 --- a/lapack-netlib/BLAS/TESTING/cblat3.f +++ b/lapack-netlib/BLAS/TESTING/cblat3.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CBLAT3 -* +* * *> \par Purpose: * ============= @@ -73,10 +73,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -85,7 +85,7 @@ * ===================================================================== PROGRAM CBLAT3 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/dblat1.f b/lapack-netlib/BLAS/TESTING/dblat1.f index 30691f9bff..7f606aa392 100644 --- a/lapack-netlib/BLAS/TESTING/dblat1.f +++ b/lapack-netlib/BLAS/TESTING/dblat1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DBLAT1 -* +* * *> \par Purpose: * ============= @@ -25,10 +25,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -37,7 +37,7 @@ * ===================================================================== PROGRAM DBLAT1 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 @@ -345,7 +345,7 @@ SUBROUTINE CHECK2(SFAC) * .. Local Scalars .. DOUBLE PRECISION SA INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY, - $ MX, MY + $ MX, MY * .. Local Arrays .. DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), $ DT8(7,4,4), DX1(7), @@ -589,7 +589,7 @@ SUBROUTINE CHECK2(SFAC) M .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, N 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, O -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / -* +* * .. Executable Statements .. * DO 120 KI = 1, 4 diff --git a/lapack-netlib/BLAS/TESTING/dblat2.f b/lapack-netlib/BLAS/TESTING/dblat2.f index 0fa80afa4d..9bbbe9792b 100644 --- a/lapack-netlib/BLAS/TESTING/dblat2.f +++ b/lapack-netlib/BLAS/TESTING/dblat2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DBLAT2 -* +* * *> \par Purpose: * ============= @@ -90,10 +90,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -102,7 +102,7 @@ * ===================================================================== PROGRAM DBLAT2 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/dblat3.f b/lapack-netlib/BLAS/TESTING/dblat3.f index 8d37c74531..1ebec4ffa6 100644 --- a/lapack-netlib/BLAS/TESTING/dblat3.f +++ b/lapack-netlib/BLAS/TESTING/dblat3.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DBLAT3 -* +* * *> \par Purpose: * ============= @@ -70,10 +70,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -82,7 +82,7 @@ * ===================================================================== PROGRAM DBLAT3 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/sblat1.f b/lapack-netlib/BLAS/TESTING/sblat1.f index 6657c26930..3ea607be47 100644 --- a/lapack-netlib/BLAS/TESTING/sblat1.f +++ b/lapack-netlib/BLAS/TESTING/sblat1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SBLAT1 -* +* * *> \par Purpose: * ============= @@ -25,10 +25,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -37,7 +37,7 @@ * ===================================================================== PROGRAM SBLAT1 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 @@ -345,7 +345,7 @@ SUBROUTINE CHECK2(SFAC) * .. Local Scalars .. REAL SA INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY, - $ MX, MY + $ MX, MY * .. Local Arrays .. REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), $ DT8(7,4,4), DX1(7), diff --git a/lapack-netlib/BLAS/TESTING/sblat2.f b/lapack-netlib/BLAS/TESTING/sblat2.f index 71605ed312..56ead8640d 100644 --- a/lapack-netlib/BLAS/TESTING/sblat2.f +++ b/lapack-netlib/BLAS/TESTING/sblat2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SBLAT2 -* +* * *> \par Purpose: * ============= @@ -90,10 +90,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -102,7 +102,7 @@ * ===================================================================== PROGRAM SBLAT2 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 @@ -2925,7 +2925,7 @@ SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, WRITE( NOUT, FMT = 9998 )I, YT( I ), $ YY( 1 + ( I - 1 )*ABS( INCY ) ) ELSE - WRITE( NOUT, FMT = 9998 )I, + WRITE( NOUT, FMT = 9998 )I, $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) END IF 60 CONTINUE diff --git a/lapack-netlib/BLAS/TESTING/sblat3.f b/lapack-netlib/BLAS/TESTING/sblat3.f index 8792696337..66edac14ea 100644 --- a/lapack-netlib/BLAS/TESTING/sblat3.f +++ b/lapack-netlib/BLAS/TESTING/sblat3.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SBLAT3 -* +* * *> \par Purpose: * ============= @@ -70,10 +70,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -82,7 +82,7 @@ * ===================================================================== PROGRAM SBLAT3 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/zblat1.f b/lapack-netlib/BLAS/TESTING/zblat1.f index d30112c637..4b0bcf8849 100644 --- a/lapack-netlib/BLAS/TESTING/zblat1.f +++ b/lapack-netlib/BLAS/TESTING/zblat1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZBLAT1 -* +* * *> \par Purpose: * ============= @@ -25,10 +25,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -37,7 +37,7 @@ * ===================================================================== PROGRAM ZBLAT1 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/zblat2.f b/lapack-netlib/BLAS/TESTING/zblat2.f index 53129a11e9..4a20ac5675 100644 --- a/lapack-netlib/BLAS/TESTING/zblat2.f +++ b/lapack-netlib/BLAS/TESTING/zblat2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZBLAT2 -* +* * *> \par Purpose: * ============= @@ -91,10 +91,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -103,7 +103,7 @@ * ===================================================================== PROGRAM ZBLAT2 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/TESTING/zblat3.f b/lapack-netlib/BLAS/TESTING/zblat3.f index 59ca241456..0e38334e9a 100644 --- a/lapack-netlib/BLAS/TESTING/zblat3.f +++ b/lapack-netlib/BLAS/TESTING/zblat3.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZBLAT3 -* +* * *> \par Purpose: * ============= @@ -47,7 +47,7 @@ *> ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. *> ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> -*> +*> *> Further Details *> =============== *> @@ -74,10 +74,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -86,7 +86,7 @@ * ===================================================================== PROGRAM ZBLAT3 * -* -- Reference BLAS test routine (version 3.4.1) -- +* -- Reference BLAS test routine (version 3.7.0) -- * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 diff --git a/lapack-netlib/BLAS/blas.pc.in b/lapack-netlib/BLAS/blas.pc.in index 845a25c366..7fd6f1e732 100644 --- a/lapack-netlib/BLAS/blas.pc.in +++ b/lapack-netlib/BLAS/blas.pc.in @@ -1,8 +1,8 @@ prefix=@prefix@ libdir=@libdir@ -Name: blas -Description: Basic Linear Algebra Subprograms F77 reference implementations +Name: BLAS +Description: FORTRAN reference implementation of BLAS Basic Linear Algebra Subprograms Version: @LAPACK_VERSION@ URL: http://www.netlib.org/blas/ Libs: -L${libdir} -lblas diff --git a/lapack-netlib/CBLAS/CMakeLists.txt b/lapack-netlib/CBLAS/CMakeLists.txt index 98b481f055..580864fba8 100644 --- a/lapack-netlib/CBLAS/CMakeLists.txt +++ b/lapack-netlib/CBLAS/CMakeLists.txt @@ -5,22 +5,18 @@ set(LAPACK_INSTALL_EXPORT_NAME cblas-targets) # Create a header file cblas.h for the routines called in my C programs include(FortranCInterface) -FortranCInterface_HEADER( ${CMAKE_CURRENT_SOURCE_DIR}/include/cblas_mangling.h - MACRO_NAMESPACE "F77_" - SYMBOL_NAMESPACE "F77_" ) - -# Old way to detect mangling -#include(FortranMangling) -#FORTRAN_MANGLING(CDEFS) -#set(CDEFS ${CDEFS} CACHE STRING "Fortran Mangling" FORCE) -#MESSAGE(STATUS "=========") - -# -------------------------------------------------- -# Compiler Flags -#ADD_DEFINITIONS( "-D${CDEFS}") - +## Ensure that the fortran compiler and c compiler specified are compatible +FortranCInterface_VERIFY() +FortranCInterface_HEADER(${LAPACK_BINARY_DIR}/include/cblas_mangling.h + MACRO_NAMESPACE "F77_" + SYMBOL_NAMESPACE "F77_") +if(NOT FortranCInterface_GLOBAL_FOUND OR NOT FortranCInterface_MODULE_FOUND) + message(WARNING "Reverting to pre-defined include/lapacke_mangling.h") + configure_file(include/lapacke_mangling_with_flags.h.in + ${LAPACK_BINARY_DIR}/include/lapacke_mangling.h) +endif() -include_directories( include ) +include_directories(include ${LAPACK_BINARY_DIR}/include) add_subdirectory(include) add_subdirectory(src) @@ -32,24 +28,24 @@ endforeach() endmacro() append_subdir_files(CBLAS_INCLUDE "include") -INSTALL( FILES ${CBLAS_INCLUDE} DESTINATION include ) +install(FILES ${CBLAS_INCLUDE} ${LAPACK_BINARY_DIR}/include/cblas_mangling.h DESTINATION include) # -------------------------------------------------- if(BUILD_TESTING) - add_subdirectory(testing) - add_subdirectory(examples) -endif(BUILD_TESTING) + add_subdirectory(testing) + add_subdirectory(examples) +endif() if(NOT BLAS_FOUND) set(ALL_TARGETS ${ALL_TARGETS} blas) -endif(NOT BLAS_FOUND) +endif() # Export cblas targets from the # install tree, if any. set(_cblas_config_install_guard_target "") if(ALL_TARGETS) install(EXPORT cblas-targets - DESTINATION lib/cmake/cblas-${LAPACK_VERSION}) + DESTINATION ${LIBRARY_DIR}/cmake/cblas-${LAPACK_VERSION}) # Choose one of the cblas targets to use as a guard for # cblas-config.cmake to load targets from the install tree. list(GET ALL_TARGETS 0 _cblas_config_install_guard_target) @@ -65,26 +61,25 @@ if(ALL_TARGETS) list(GET ALL_TARGETS 0 _cblas_config_build_guard_target) endif() -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/CMAKE/cblas-config-version.cmake.in +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/cblas-config-version.cmake.in ${LAPACK_BINARY_DIR}/cblas-config-version.cmake @ONLY) -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/CMAKE/cblas-config-build.cmake.in +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/cblas-config-build.cmake.in ${LAPACK_BINARY_DIR}/cblas-config.cmake @ONLY) -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cblas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/cblas.pc) +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cblas.pc.in ${CMAKE_CURRENT_BINARY_DIR}/cblas.pc @ONLY) install(FILES ${CMAKE_CURRENT_BINARY_DIR}/cblas.pc DESTINATION ${PKG_CONFIG_DIR} - ) + ) configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/cblas-config-install.cmake.in ${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/cblas-config.cmake @ONLY) install(FILES ${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/cblas-config.cmake ${LAPACK_BINARY_DIR}/cblas-config-version.cmake - DESTINATION lib/cmake/cblas-${LAPACK_VERSION} + DESTINATION ${LIBRARY_DIR}/cmake/cblas-${LAPACK_VERSION} ) #install(EXPORT cblas-targets -# DESTINATION lib/cmake/cblas-${LAPACK_VERSION}) - +# DESTINATION ${LIBRARY_DIR}/cmake/cblas-${LAPACK_VERSION}) diff --git a/lapack-netlib/CBLAS/Makefile b/lapack-netlib/CBLAS/Makefile index d7ee0c5065..5a398f800f 100644 --- a/lapack-netlib/CBLAS/Makefile +++ b/lapack-netlib/CBLAS/Makefile @@ -1,7 +1,7 @@ include ../make.inc all: - cd include && cp cblas_mangling_with_flags.h cblas_mangling.h + cd include && cp cblas_mangling_with_flags.h.in cblas_mangling.h cd src && $(MAKE) all @@ -22,6 +22,6 @@ cblas_testing: runtst: cd testing && $(MAKE) run - + example: all - cd examples && make all + cd examples && $(MAKE) all diff --git a/lapack-netlib/CBLAS/Makefile.in b/lapack-netlib/CBLAS/Makefile.in deleted file mode 100644 index fe01430445..0000000000 --- a/lapack-netlib/CBLAS/Makefile.in +++ /dev/null @@ -1,49 +0,0 @@ -# -# Makefile.LINUX -# -# -# If you compile, change the name to Makefile.in. -# -# - -#----------------------------------------------------------------------------- -# Shell -#----------------------------------------------------------------------------- - -SHELL = /bin/sh - -#----------------------------------------------------------------------------- -# Platform -#----------------------------------------------------------------------------- - -PLAT = LINUX - -#----------------------------------------------------------------------------- -# Libraries and includes -#----------------------------------------------------------------------------- - -BLLIB = $(home)/lib/librefblas.a -CBLIB = ../lib/libcblas.a - -#----------------------------------------------------------------------------- -# Compilers -#----------------------------------------------------------------------------- - -CC = gcc -FC = gfortran -LOADER = $(FC) - -#----------------------------------------------------------------------------- -# Flags for Compilers -#----------------------------------------------------------------------------- - -CFLAGS = -O3 -DADD_ -FFLAGS = -O3 - -#----------------------------------------------------------------------------- -# Archive programs and flags -#----------------------------------------------------------------------------- - -ARCH = ar -ARCHFLAGS = cr -RANLIB = ranlib diff --git a/lapack-netlib/CBLAS/README b/lapack-netlib/CBLAS/README index 2ad513b557..6c87ed6943 100644 --- a/lapack-netlib/CBLAS/README +++ b/lapack-netlib/CBLAS/README @@ -6,25 +6,25 @@ INSTALLATION BLASLIB is your Legacy BLAS library (by default the Reference BLAS shipped within LAPACK) Then type: - + prompt> make - + which will create the CBLAS library. CREATING THE TESTERS type: - + prompt> make cblas_testing - + This will create the BLAS library if necessary, then compile the CBLAS testings. EXECUTING THE TESTERS type: - + prompt> make runtst - + _______________________________________________________________________________ This package contains C interface to Legacy BLAS. @@ -34,7 +34,7 @@ _______________________________________________________________________________ This release updates an inconsistency between the BLAST document and the interface. According to the document, the enumerated types for - the C interface to the BLAS are not typedef'ed. + the C interface to the BLAS are not typedef'ed. It also updates the Level 2 and 3 testers which check for correct exiting of routines when called with bad arguments. This is done by @@ -56,4 +56,4 @@ _______________________________________________________________________________ Updated by Julie Langou (08/22/2014): Integrate CBLAS package into LAPACK -Improve headers for mangling +Improve headers for mangling diff --git a/lapack-netlib/CBLAS/cblas.pc.in b/lapack-netlib/CBLAS/cblas.pc.in index ee202067e8..4a938fe154 100644 --- a/lapack-netlib/CBLAS/cblas.pc.in +++ b/lapack-netlib/CBLAS/cblas.pc.in @@ -1,9 +1,9 @@ prefix=@prefix@ libdir=@libdir@ -Name: lapacke -Description: C Standard Interface to BLAS Linear Algebra PACKage +Name: CBLAS +Description: C Standard Interface to BLAS Basic Linear Algebra Subprograms Version: @LAPACK_VERSION@ -URL: http://www.netlib.org/lapack/ +URL: http://www.netlib.org/blas/#_cblas Libs: -L${libdir} -lcblas Requires: blas diff --git a/lapack-netlib/CBLAS/cmake/cblas-config-build.cmake.in b/lapack-netlib/CBLAS/cmake/cblas-config-build.cmake.in index 5449c12bfc..3747f041c4 100644 --- a/lapack-netlib/CBLAS/cmake/cblas-config-build.cmake.in +++ b/lapack-netlib/CBLAS/cmake/cblas-config-build.cmake.in @@ -7,8 +7,8 @@ if(NOT TARGET lapacke) include("@LAPACK_BINARY_DIR@/lapack-targets.cmake") endif() -# Report lapacke header search locations. -set(CBLAS_INCLUDE_DIRS "@LAPACK_SOURCE_DIR@/cblas/include") +# Report cblas header search locations from build tree. +set(CBLAS_INCLUDE_DIRS "@LAPACK_BINARY_DIR@/include") -# Report lapacke libraries. +# Report cblas libraries. set(CBLAS_LIBRARIES cblas) diff --git a/lapack-netlib/CBLAS/cmake/cblas-config-install.cmake.in b/lapack-netlib/CBLAS/cmake/cblas-config-install.cmake.in index 3a21ef952e..a5e2183e1a 100644 --- a/lapack-netlib/CBLAS/cmake/cblas-config-install.cmake.in +++ b/lapack-netlib/CBLAS/cmake/cblas-config-install.cmake.in @@ -1,11 +1,11 @@ -# Compute locations from /lib/cmake/lapacke-/.cmake +# Compute locations from /@{LIBRARY_DIR@/cmake/lapacke-/.cmake get_filename_component(_CBLAS_SELF_DIR "${CMAKE_CURRENT_LIST_FILE}" PATH) get_filename_component(_CBLAS_PREFIX "${_CBLAS_SELF_DIR}" PATH) get_filename_component(_CBLAS_PREFIX "${_CBLAS_PREFIX}" PATH) get_filename_component(_CBLAS_PREFIX "${_CBLAS_PREFIX}" PATH) # Load the LAPACK package with which we were built. -set(LAPACK_DIR "${_CBLAS_PREFIX}/lib/cmake/lapack-@LAPACK_VERSION@") +set(LAPACK_DIR "${_CBLAS_PREFIX}/@{LIBRARY_DIR@/cmake/lapack-@LAPACK_VERSION@") find_package(LAPACK NO_MODULE) # Load lapacke targets from the install tree. diff --git a/lapack-netlib/CBLAS/examples/CMakeLists.txt b/lapack-netlib/CBLAS/examples/CMakeLists.txt index 85d8bbe6a8..a4bab6beee 100644 --- a/lapack-netlib/CBLAS/examples/CMakeLists.txt +++ b/lapack-netlib/CBLAS/examples/CMakeLists.txt @@ -1,5 +1,5 @@ -add_executable(xexample1_CBLAS cblas_example1.c ) -add_executable(xexample2_CBLAS cblas_example2.c ) +add_executable(xexample1_CBLAS cblas_example1.c) +add_executable(xexample2_CBLAS cblas_example2.c) target_link_libraries(xexample1_CBLAS cblas ${BLAS_LIBRARIES}) target_link_libraries(xexample2_CBLAS cblas ${BLAS_LIBRARIES}) diff --git a/lapack-netlib/CBLAS/examples/Makefile b/lapack-netlib/CBLAS/examples/Makefile index cd75a6ea95..1d416a8817 100644 --- a/lapack-netlib/CBLAS/examples/Makefile +++ b/lapack-netlib/CBLAS/examples/Makefile @@ -2,13 +2,13 @@ include ../../make.inc all: example1 example2 -example1: - $(CC) -c $(CFLAGS) -I../include cblas_example1.c - $(LOADER) -o cblas_ex1 cblas_example1.o $(CBLASLIB) $(BLASLIB) - -example2: - $(CC) -c $(CFLAGS) -I../include cblas_example2.c - $(LOADER) -o cblas_ex2 cblas_example2.o $(CBLASLIB) $(BLASLIB) - +example1: + $(CC) $(CFLAGS) -I../include -c cblas_example1.c + $(LOADER) $(LOADOPTS) -o cblas_ex1 cblas_example1.o $(CBLASLIB) $(BLASLIB) + +example2: + $(CC) $(CFLAGS) -I../include -c cblas_example2.c + $(LOADER) $(LOADOPTS) -o cblas_ex2 cblas_example2.o $(CBLASLIB) $(BLASLIB) + cleanall: rm -f *.o cblas_ex1 cblas_ex2 diff --git a/lapack-netlib/CBLAS/examples/cblas_example1.c b/lapack-netlib/CBLAS/examples/cblas_example1.c index 0b0cc6c681..c3acd554d4 100644 --- a/lapack-netlib/CBLAS/examples/cblas_example1.c +++ b/lapack-netlib/CBLAS/examples/cblas_example1.c @@ -39,7 +39,7 @@ int main ( ) a[m+3] = 1; /* The elements of the third column */ a[m*2] = 3; - a[m*2+1] = 4; + a[m*2+1] = 4; a[m*2+2] = 5; a[m*2+3] = 6; /* The elements of the fourth column */ @@ -47,7 +47,7 @@ int main ( ) a[m*3+1] = 6; a[m*3+2] = 7; a[m*3+3] = 8; - /* The elemetns of x and y */ + /* The elemetns of x and y */ x[0] = 1; x[1] = 2; x[2] = 1; @@ -56,11 +56,11 @@ int main ( ) y[1] = 0; y[2] = 0; y[3] = 0; - + cblas_dgemv( Layout, transa, m, n, alpha, a, lda, x, incx, beta, y, incy ); /* Print y */ - for( i = 0; i < n; i++ ) + for( i = 0; i < n; i++ ) printf(" y%d = %f\n", i, y[i]); free(a); free(x); diff --git a/lapack-netlib/CBLAS/examples/cblas_example2.c b/lapack-netlib/CBLAS/examples/cblas_example2.c index d3b35f2ebc..d2c28d53f3 100644 --- a/lapack-netlib/CBLAS/examples/cblas_example2.c +++ b/lapack-netlib/CBLAS/examples/cblas_example2.c @@ -10,16 +10,16 @@ int main (int argc, char **argv ) { int rout=-1,info=0,m,n,k,lda,ldb,ldc; - double A[2] = {0.0,0.0}, - B[2] = {0.0,0.0}, - C[2] = {0.0,0.0}, + double A[2] = {0.0,0.0}, + B[2] = {0.0,0.0}, + C[2] = {0.0,0.0}, ALPHA=0.0, BETA=0.0; - + if (argc > 2){ rout = atoi(argv[1]); info = atoi(argv[2]); } - + if (rout == 1) { if (info==0) { printf("Checking if cblas_dgemm fails on parameter 4\n"); @@ -67,6 +67,6 @@ int main (int argc, char **argv ) &ALPHA, A, &lda, B, &ldb, &BETA, C, &ldc ); } } - + return 0; } diff --git a/lapack-netlib/CBLAS/include/CMakeLists.txt b/lapack-netlib/CBLAS/include/CMakeLists.txt index 06093f43f2..299b45c9eb 100644 --- a/lapack-netlib/CBLAS/include/CMakeLists.txt +++ b/lapack-netlib/CBLAS/include/CMakeLists.txt @@ -1,3 +1,3 @@ -SET (CBLAS_INCLUDE cblas.h cblas_f77.h cblas_test.h cblas_mangling.h) +set(CBLAS_INCLUDE cblas.h cblas_f77.h cblas_test.h) file(COPY ${CBLAS_INCLUDE} DESTINATION ${LAPACK_BINARY_DIR}/include) diff --git a/lapack-netlib/CBLAS/include/cblas.h b/lapack-netlib/CBLAS/include/cblas.h index 7523a779e5..9e937964ed 100644 --- a/lapack-netlib/CBLAS/include/cblas.h +++ b/lapack-netlib/CBLAS/include/cblas.h @@ -88,39 +88,39 @@ CBLAS_INDEX cblas_izamax(const int N, const void *X, const int incX); * =========================================================================== */ -/* +/* * Routines with standard 4 prefixes (s, d, c, z) */ -void cblas_sswap(const int N, float *X, const int incX, +void cblas_sswap(const int N, float *X, const int incX, float *Y, const int incY); -void cblas_scopy(const int N, const float *X, const int incX, +void cblas_scopy(const int N, const float *X, const int incX, float *Y, const int incY); void cblas_saxpy(const int N, const float alpha, const float *X, const int incX, float *Y, const int incY); -void cblas_dswap(const int N, double *X, const int incX, +void cblas_dswap(const int N, double *X, const int incX, double *Y, const int incY); -void cblas_dcopy(const int N, const double *X, const int incX, +void cblas_dcopy(const int N, const double *X, const int incX, double *Y, const int incY); void cblas_daxpy(const int N, const double alpha, const double *X, const int incX, double *Y, const int incY); -void cblas_cswap(const int N, void *X, const int incX, +void cblas_cswap(const int N, void *X, const int incX, void *Y, const int incY); -void cblas_ccopy(const int N, const void *X, const int incX, +void cblas_ccopy(const int N, const void *X, const int incX, void *Y, const int incY); void cblas_caxpy(const int N, const void *alpha, const void *X, const int incX, void *Y, const int incY); -void cblas_zswap(const int N, void *X, const int incX, +void cblas_zswap(const int N, void *X, const int incX, void *Y, const int incY); -void cblas_zcopy(const int N, const void *X, const int incX, +void cblas_zcopy(const int N, const void *X, const int incX, void *Y, const int incY); void cblas_zaxpy(const int N, const void *alpha, const void *X, const int incX, void *Y, const int incY); -/* +/* * Routines with S and D prefix only */ void cblas_srotg(float *a, float *b, float *c, float *s); @@ -138,7 +138,7 @@ void cblas_drotm(const int N, double *X, const int incX, double *Y, const int incY, const double *P); -/* +/* * Routines with S D C Z CS and ZD prefixes */ void cblas_sscal(const int N, const float alpha, float *X, const int incX); @@ -154,7 +154,7 @@ void cblas_zdscal(const int N, const double alpha, void *X, const int incX); * =========================================================================== */ -/* +/* * Routines with standard 4 prefixes (S, D, C, Z) */ void cblas_sgemv(const CBLAS_LAYOUT layout, @@ -169,11 +169,11 @@ void cblas_sgbmv(CBLAS_LAYOUT layout, const int incX, const float beta, float *Y, const int incY); void cblas_strmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const float *A, const int lda, + const int N, const float *A, const int lda, float *X, const int incX); void cblas_stbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const int K, const float *A, const int lda, + const int N, const int K, const float *A, const int lda, float *X, const int incX); void cblas_stpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, @@ -202,11 +202,11 @@ void cblas_dgbmv(CBLAS_LAYOUT layout, const int incX, const double beta, double *Y, const int incY); void cblas_dtrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const double *A, const int lda, + const int N, const double *A, const int lda, double *X, const int incX); void cblas_dtbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const int K, const double *A, const int lda, + const int N, const int K, const double *A, const int lda, double *X, const int incX); void cblas_dtpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, @@ -235,11 +235,11 @@ void cblas_cgbmv(CBLAS_LAYOUT layout, const int incX, const void *beta, void *Y, const int incY); void cblas_ctrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const void *A, const int lda, + const int N, const void *A, const int lda, void *X, const int incX); void cblas_ctbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const int K, const void *A, const int lda, + const int N, const int K, const void *A, const int lda, void *X, const int incX); void cblas_ctpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, @@ -268,11 +268,11 @@ void cblas_zgbmv(CBLAS_LAYOUT layout, const int incX, const void *beta, void *Y, const int incY); void cblas_ztrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const void *A, const int lda, + const int N, const void *A, const int lda, void *X, const int incX); void cblas_ztbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - const int N, const int K, const void *A, const int lda, + const int N, const int K, const void *A, const int lda, void *X, const int incX); void cblas_ztpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, @@ -290,7 +290,7 @@ void cblas_ztpsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, const void *Ap, void *X, const int incX); -/* +/* * Routines with S and D prefixes only */ void cblas_ssymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, @@ -352,7 +352,7 @@ void cblas_dspr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int incX, const double *Y, const int incY, double *A); -/* +/* * Routines with C and Z prefixes only */ void cblas_chemv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, @@ -423,7 +423,7 @@ void cblas_zhpr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, * =========================================================================== */ -/* +/* * Routines with standard 4 prefixes (S, D, C, Z) */ void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, @@ -547,7 +547,7 @@ void cblas_ztrsm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, void *B, const int ldb); -/* +/* * Routines with prefixes C and Z only */ void cblas_chemm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, diff --git a/lapack-netlib/CBLAS/include/cblas_f77.h b/lapack-netlib/CBLAS/include/cblas_f77.h index 8aa2c876db..36d4a71180 100644 --- a/lapack-netlib/CBLAS/include/cblas_f77.h +++ b/lapack-netlib/CBLAS/include/cblas_f77.h @@ -89,8 +89,8 @@ /* * Level 2 BLAS */ -#define F77_ssymv F77_GLOBAL(ssymv,SSYMY) -#define F77_ssbmv F77_GLOBAL(ssbmv,SSMBV) +#define F77_ssymv F77_GLOBAL(ssymv,SSYMV) +#define F77_ssbmv F77_GLOBAL(ssbmv,SSBMV) #define F77_sspmv F77_GLOBAL(sspmv,SSPMV) #define F77_sger F77_GLOBAL(sger,SGER) #define F77_ssyr F77_GLOBAL(ssyr,SSYR) @@ -135,7 +135,7 @@ #define F77_dgbmv F77_GLOBAL(dgbmv,DGBMV) #define F77_dtrmv F77_GLOBAL(dtrmv,DTRMV) #define F77_dtbmv F77_GLOBAL(dtbmv,DTBMV) -#define F77_dtpmv F77_GLOBAL(dtpmv,DTRMV) +#define F77_dtpmv F77_GLOBAL(dtpmv,DTPMV) #define F77_dtrsv F77_GLOBAL(dtrsv,DTRSV) #define F77_dtbsv F77_GLOBAL(dtbsv,DTBSV) #define F77_dtpsv F77_GLOBAL(dtpsv,DTPSV) @@ -201,7 +201,7 @@ void F77_xerbla(FCHAR, void *); /* Single Precision */ void F77_srot(FINT, float *, FINT, float *, FINT, const float *, const float *); - void F77_srotg(float *,float *,float *,float *); + void F77_srotg(float *,float *,float *,float *); void F77_srotm( FINT, float *, FINT, float *, FINT, const float *); void F77_srotmg(float *,float *,float *,const float *, float *); void F77_sswap( FINT, float *, FINT, float *, FINT); @@ -217,7 +217,7 @@ void F77_xerbla(FCHAR, void *); /* Double Precision */ void F77_drot(FINT, double *, FINT, double *, FINT, const double *, const double *); - void F77_drotg(double *,double *,double *,double *); + void F77_drotg(double *,double *,double *,double *); void F77_drotm( FINT, double *, FINT, double *, FINT, const double *); void F77_drotmg(double *,double *,double *,const double *, double *); void F77_dswap( FINT, double *, FINT, double *, FINT); @@ -278,8 +278,8 @@ void F77_xerbla(FCHAR, void *); void F77_stpsv( FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT); void F77_sger( FINT, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); void F77_ssyr(FCHAR, FINT, const float *, const float *, FINT, float *, FINT); - void F77_sspr(FCHAR, FINT, const float *, const float *, FINT, float *); - void F77_sspr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *); + void F77_sspr(FCHAR, FINT, const float *, const float *, FINT, float *); + void F77_sspr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *); void F77_ssyr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); /* Double Precision */ @@ -297,8 +297,8 @@ void F77_xerbla(FCHAR, void *); void F77_dtpsv( FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT); void F77_dger( FINT, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); void F77_dsyr(FCHAR, FINT, const double *, const double *, FINT, double *, FINT); - void F77_dspr(FCHAR, FINT, const double *, const double *, FINT, double *); - void F77_dspr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *); + void F77_dspr(FCHAR, FINT, const double *, const double *, FINT, double *); + void F77_dspr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *); void F77_dsyr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); /* Single Complex Precision */ diff --git a/lapack-netlib/CBLAS/include/cblas_mangling_with_flags.h b/lapack-netlib/CBLAS/include/cblas_mangling_with_flags.h.in similarity index 100% rename from lapack-netlib/CBLAS/include/cblas_mangling_with_flags.h rename to lapack-netlib/CBLAS/include/cblas_mangling_with_flags.h.in diff --git a/lapack-netlib/CBLAS/include/cblas_test.h b/lapack-netlib/CBLAS/include/cblas_test.h index 933e13fbb1..f8174ba43c 100644 --- a/lapack-netlib/CBLAS/include/cblas_test.h +++ b/lapack-netlib/CBLAS/include/cblas_test.h @@ -131,7 +131,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_cgemv F77_GLOBAL(ccgemv,CCGEMV) #define F77_cgbmv F77_GLOBAL(ccgbmv,CCGBMV) #define F77_ctrmv F77_GLOBAL(cctrmv,CCTRMV) -#define F77_ctbmv F77_GLOBAL(cctbmv,CCTPMV) +#define F77_ctbmv F77_GLOBAL(cctbmv,CCTBMV) #define F77_ctpmv F77_GLOBAL(cctpmv,CCTPMV) #define F77_ctrsv F77_GLOBAL(cctrsv,CCTRSV) #define F77_ctbsv F77_GLOBAL(cctbsv,CCTBSV) diff --git a/lapack-netlib/CBLAS/src/CMakeLists.txt b/lapack-netlib/CBLAS/src/CMakeLists.txt index 8093a5c685..20f8eb4cba 100644 --- a/lapack-netlib/CBLAS/src/CMakeLists.txt +++ b/lapack-netlib/CBLAS/src/CMakeLists.txt @@ -2,7 +2,7 @@ # # Error handling routines for level 2 & 3 -set (ERRHAND cblas_globals.c cblas_xerbla.c xerbla.c) +set(ERRHAND cblas_globals.c cblas_xerbla.c xerbla.c) # # @@ -10,52 +10,50 @@ set (ERRHAND cblas_globals.c cblas_xerbla.c xerbla.c) # # Level 1 # -# +# # # All object files for single real precision # -set (SLEV1 cblas_srotg.c cblas_srotmg.c cblas_srot.c cblas_srotm.c +set(SLEV1 cblas_srotg.c cblas_srotmg.c cblas_srot.c cblas_srotm.c cblas_sswap.c cblas_sscal.c cblas_scopy.c cblas_saxpy.c cblas_sdot.c cblas_sdsdot.c cblas_snrm2.c cblas_sasum.c - cblas_isamax.c sdotsub.f sdsdotsub.f snrm2sub.f sasumsub.f + cblas_isamax.c sdotsub.f sdsdotsub.f snrm2sub.f sasumsub.f isamaxsub.f) + # # All object files for double real precision # -set (DLEV1 cblas_drotg.c cblas_drotmg.c cblas_drot.c cblas_drotm.c +set(DLEV1 cblas_drotg.c cblas_drotmg.c cblas_drot.c cblas_drotm.c cblas_dswap.c cblas_dscal.c cblas_dcopy.c cblas_daxpy.c - cblas_ddot.c cblas_dsdot.c cblas_dnrm2.c cblas_dasum.c - cblas_idamax.c ddotsub.f dsdotsub.f dnrm2sub.f + cblas_ddot.c cblas_dsdot.c cblas_dnrm2.c cblas_dasum.c + cblas_idamax.c ddotsub.f dsdotsub.f dnrm2sub.f dasumsub.f idamaxsub.f) # # All object files for single complex precision # -set (CLEV1 cblas_cswap.c cblas_cscal.c cblas_csscal.c cblas_ccopy.c +set(CLEV1 cblas_cswap.c cblas_cscal.c cblas_csscal.c cblas_ccopy.c cblas_caxpy.c cblas_cdotu_sub.c cblas_cdotc_sub.c cblas_icamax.c cdotcsub.f cdotusub.f icamaxsub.f) # # All object files for double complex precision # -set (ZLEV1 cblas_zswap.c cblas_zscal.c cblas_zdscal.c cblas_zcopy.c +set(ZLEV1 cblas_zswap.c cblas_zscal.c cblas_zdscal.c cblas_zcopy.c cblas_zaxpy.c cblas_zdotu_sub.c cblas_zdotc_sub.c cblas_dznrm2.c - cblas_dzasum.c cblas_izamax.c zdotcsub.f zdotusub.f - dzasumsub.f dznrm2sub.f izamaxsub.f) - + cblas_dzasum.c cblas_izamax.c zdotcsub.f zdotusub.f + dzasumsub.f dznrm2sub.f izamaxsub.f) # # Common files for single complex precision # -set (SCLEV1 cblas_scasum.c scasumsub.f cblas_scnrm2.c scnrm2sub.f) - +set(SCLEV1 cblas_scasum.c scasumsub.f cblas_scnrm2.c scnrm2sub.f) # # All object files # -set (ALEV1 ${slev1} ${dlev1} ${clev1} ${zlev1} ${sclev1}) - +set(ALEV1 ${slev1} ${dlev1} ${clev1} ${zlev1} ${sclev1}) # # @@ -63,29 +61,28 @@ set (ALEV1 ${slev1} ${dlev1} ${clev1} ${zlev1} ${sclev1}) # # Level 2 # -# +# # # All object files for single real precision # -set (SLEV2 cblas_sgemv.c cblas_sgbmv.c cblas_sger.c cblas_ssbmv.c cblas_sspmv.c +set(SLEV2 cblas_sgemv.c cblas_sgbmv.c cblas_sger.c cblas_ssbmv.c cblas_sspmv.c cblas_sspr.c cblas_sspr2.c cblas_ssymv.c cblas_ssyr.c cblas_ssyr2.c - cblas_stbmv.c cblas_stbsv.c cblas_stpmv.c cblas_stpsv.c cblas_strmv.c + cblas_stbmv.c cblas_stbsv.c cblas_stpmv.c cblas_stpsv.c cblas_strmv.c cblas_strsv.c) - # # All object files for double real precision # -set (DLEV2 cblas_dgemv.c cblas_dgbmv.c cblas_dger.c cblas_dsbmv.c cblas_dspmv.c +set(DLEV2 cblas_dgemv.c cblas_dgbmv.c cblas_dger.c cblas_dsbmv.c cblas_dspmv.c cblas_dspr.c cblas_dspr2.c cblas_dsymv.c cblas_dsyr.c cblas_dsyr2.c - cblas_dtbmv.c cblas_dtbsv.c cblas_dtpmv.c cblas_dtpsv.c cblas_dtrmv.c + cblas_dtbmv.c cblas_dtbsv.c cblas_dtpmv.c cblas_dtpsv.c cblas_dtrmv.c cblas_dtrsv.c) # # All object files for single complex precision # -set (CLEV2 cblas_cgemv.c cblas_cgbmv.c cblas_chemv.c cblas_chbmv.c cblas_chpmv.c +set(CLEV2 cblas_cgemv.c cblas_cgbmv.c cblas_chemv.c cblas_chbmv.c cblas_chpmv.c cblas_ctrmv.c cblas_ctbmv.c cblas_ctpmv.c cblas_ctrsv.c cblas_ctbsv.c cblas_ctpsv.c cblas_cgeru.c cblas_cgerc.c cblas_cher.c cblas_cher2.c cblas_chpr.c cblas_chpr2.c) @@ -93,14 +90,15 @@ set (CLEV2 cblas_cgemv.c cblas_cgbmv.c cblas_chemv.c cblas_chbmv.c cblas_chpmv.c # # All object files for double complex precision # -set (ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c +set(ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c cblas_ztrmv.c cblas_ztbmv.c cblas_ztpmv.c cblas_ztrsv.c cblas_ztbsv.c cblas_ztpsv.c cblas_zgeru.c cblas_zgerc.c cblas_zher.c cblas_zher2.c cblas_zhpr.c cblas_zhpr2.c) + # # All object files # -set (AVEL2 ${slev2} ${dlev2} ${clev2} ${zlev2}) +set(AVEL2 ${slev2} ${dlev2} ${clev2} ${zlev2}) # # @@ -108,61 +106,65 @@ set (AVEL2 ${slev2} ${dlev2} ${clev2} ${zlev2}) # # Level 3 # -# +# # # All object files for single real precision # -set (SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c +set(SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c cblas_strsm.c) + # # All object files for double real precision # -set (DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c +set(DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c cblas_dtrsm.c) + # # All object files for single complex precision # -set (CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c - cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c +set(CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c + cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c cblas_csyr2k.c) + # # All object files for double complex precision # -set (ZLEV3 cblas_zgemm.c cblas_zsymm.c cblas_zhemm.c cblas_zherk.c - cblas_zher2k.c cblas_ztrmm.c cblas_ztrsm.c cblas_zsyrk.c +set(ZLEV3 cblas_zgemm.c cblas_zsymm.c cblas_zhemm.c cblas_zherk.c + cblas_zher2k.c cblas_ztrmm.c cblas_ztrsm.c cblas_zsyrk.c cblas_zsyr2k.c) + # # All object files # -set (ALEV3 ${slev3} ${dlev3} ${clev3} ${zlev3}) +set(ALEV3 ${slev3} ${dlev3} ${clev3} ${zlev3}) # default build all of it set(ALLOBJ ${SCLEV1} ${SLEV1} ${SLEV2} ${SLEV3} ${ERRHAND} ${DLEV1} ${DLEV2} ${DLEV3} - ${CLEV1} ${CLEV2} ${CLEV3} - ${ZLEV1} ${ZLEV2} ${ZLEV3} ) + ${CLEV1} ${CLEV2} ${CLEV3} + ${ZLEV1} ${ZLEV2} ${ZLEV3}) # Single real precision if(CBLAS_SINGLE) - set(ALLOBJ ${SCLEV1} ${SLEV1} ${SLEV2} ${SLEV3} ${ERRHAND}) -endif(CBLAS_SINGLE) + set(ALLOBJ ${SCLEV1} ${SLEV1} ${SLEV2} ${SLEV3} ${ERRHAND}) +endif() # Double real precision if(CBLAS_DOUBLE) - set(ALLOBJ ${DLEV1} ${DLEV2} ${DLEV3} ${ERRHAND}) -endif(CBLAS_DOUBLE) - + set(ALLOBJ ${DLEV1} ${DLEV2} ${DLEV3} ${ERRHAND}) +endif() + # Single complex precision -if (CBLAS_COMPLEX) - set(ALLOBJ ${CLEV1} ${SCLEV1} ${CLEV2} ${CLEV3} ${ERRHAND}) -endif(CBLAS_COMPLEX) +if(CBLAS_COMPLEX) + set(ALLOBJ ${CLEV1} ${SCLEV1} ${CLEV2} ${CLEV3} ${ERRHAND}) +endif() # Double complex precision -if (CBLAS_COMPLEX16) - set(ALLOBJ ${ZLEV1} ${ZLEV2} ${ZLEV3} ${ERRHAND}) -endif(CBLAS_COMPLEX16) +if(CBLAS_COMPLEX16) + set(ALLOBJ ${ZLEV1} ${ZLEV2} ${ZLEV3} ${ERRHAND}) +endif() add_library(cblas ${ALLOBJ}) -target_link_libraries(cblas ${BLAS_LIBRARIES} ) +target_link_libraries(cblas ${BLAS_LIBRARIES}) lapack_install_library(cblas) diff --git a/lapack-netlib/CBLAS/src/Makefile b/lapack-netlib/CBLAS/src/Makefile index d5c73cbb0a..1d1a0db889 100644 --- a/lapack-netlib/CBLAS/src/Makefile +++ b/lapack-netlib/CBLAS/src/Makefile @@ -8,53 +8,55 @@ include ../../make.inc all: cblaslib clean: - rm -f *.o a.out core + rm -f *.o a.out core # Error handling routines for level 2 & 3 errhand = cblas_globals.o cblas_xerbla.o xerbla.o # Object files of all routines -alev = $(alev1) $(alev2) $(alev3) $(errhand) +alev = $(alev1) $(alev2) $(alev3) $(errhand) + # # # CBLAS routines # # Level 1 # -# +# # # All object files for single real precision # -slev1 = cblas_srotg.o cblas_srotmg.o cblas_srot.o cblas_srotm.o \ - cblas_sswap.o cblas_sscal.o cblas_scopy.o cblas_saxpy.o \ - cblas_sdot.o cblas_sdsdot.o cblas_snrm2.o cblas_sasum.o \ - cblas_isamax.o sdotsub.o sdsdotsub.o snrm2sub.o sasumsub.o \ - isamaxsub.o +slev1 = cblas_srotg.o cblas_srotmg.o cblas_srot.o cblas_srotm.o \ + cblas_sswap.o cblas_sscal.o cblas_scopy.o cblas_saxpy.o \ + cblas_sdot.o cblas_sdsdot.o cblas_snrm2.o cblas_sasum.o \ + cblas_isamax.o sdotsub.o sdsdotsub.o snrm2sub.o sasumsub.o \ + isamaxsub.o + # # All object files for double real precision # -dlev1 = cblas_drotg.o cblas_drotmg.o cblas_drot.o cblas_drotm.o \ - cblas_dswap.o cblas_dscal.o cblas_dcopy.o cblas_daxpy.o \ - cblas_ddot.o cblas_dsdot.o cblas_dnrm2.o cblas_dasum.o \ - cblas_idamax.o ddotsub.o dsdotsub.o dnrm2sub.o \ - dasumsub.o idamaxsub.o +dlev1 = cblas_drotg.o cblas_drotmg.o cblas_drot.o cblas_drotm.o \ + cblas_dswap.o cblas_dscal.o cblas_dcopy.o cblas_daxpy.o \ + cblas_ddot.o cblas_dsdot.o cblas_dnrm2.o cblas_dasum.o \ + cblas_idamax.o ddotsub.o dsdotsub.o dnrm2sub.o \ + dasumsub.o idamaxsub.o # # All object files for single complex precision # clev1 = cblas_cswap.o cblas_cscal.o cblas_csscal.o cblas_ccopy.o \ - cblas_caxpy.o cblas_cdotu_sub.o cblas_cdotc_sub.o \ - cblas_icamax.o cdotcsub.o cdotusub.o icamaxsub.o + cblas_caxpy.o cblas_cdotu_sub.o cblas_cdotc_sub.o \ + cblas_icamax.o cdotcsub.o cdotusub.o icamaxsub.o # # All object files for double complex precision # zlev1 = cblas_zswap.o cblas_zscal.o cblas_zdscal.o cblas_zcopy.o \ - cblas_zaxpy.o cblas_zdotu_sub.o cblas_zdotc_sub.o cblas_dznrm2.o \ - cblas_dzasum.o cblas_izamax.o zdotcsub.o zdotusub.o \ - dzasumsub.o dznrm2sub.o izamaxsub.o + cblas_zaxpy.o cblas_zdotu_sub.o cblas_zdotc_sub.o cblas_dznrm2.o \ + cblas_dzasum.o cblas_izamax.o zdotcsub.o zdotusub.o \ + dzasumsub.o dznrm2sub.o izamaxsub.o # # Common files for single / complex precision @@ -66,7 +68,6 @@ sclev1 = cblas_scasum.o scasumsub.o cblas_scnrm2.o scnrm2sub.o # alev1 = $(slev1) $(dlev1) $(clev1) $(zlev1) $(sclev1) - # # Make an archive file # @@ -77,7 +78,7 @@ slib1: $(slev1) $(sclev1) $(RANLIB) $(CBLASLIB) # Double real precision -dlib1: $(dlev1) +dlib1: $(dlev1) $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(dlev1) $(RANLIB) $(CBLASLIB) @@ -92,8 +93,8 @@ zlib1: $(zlev1) $(RANLIB) $(CBLASLIB) # All precisions -all1: $(alev1) - $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev1) +all1: $(alev1) + $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev1) $(RANLIB) $(CBLASLIB) # @@ -102,23 +103,23 @@ all1: $(alev1) # # Level 2 # -# +# # # All object files for single real precision # -slev2 = cblas_sgemv.o cblas_sgbmv.o cblas_sger.o cblas_ssbmv.o cblas_sspmv.o \ +slev2 = cblas_sgemv.o cblas_sgbmv.o cblas_sger.o cblas_ssbmv.o cblas_sspmv.o \ cblas_sspr.o cblas_sspr2.o cblas_ssymv.o cblas_ssyr.o cblas_ssyr2.o \ - cblas_stbmv.o cblas_stbsv.o cblas_stpmv.o cblas_stpsv.o cblas_strmv.o \ - cblas_strsv.o - + cblas_stbmv.o cblas_stbsv.o cblas_stpmv.o cblas_stpsv.o cblas_strmv.o \ + cblas_strsv.o + # # All object files for double real precision # -dlev2 = cblas_dgemv.o cblas_dgbmv.o cblas_dger.o cblas_dsbmv.o cblas_dspmv.o \ +dlev2 = cblas_dgemv.o cblas_dgbmv.o cblas_dger.o cblas_dsbmv.o cblas_dspmv.o \ cblas_dspr.o cblas_dspr2.o cblas_dsymv.o cblas_dsyr.o cblas_dsyr2.o \ - cblas_dtbmv.o cblas_dtbsv.o cblas_dtpmv.o cblas_dtpsv.o cblas_dtrmv.o \ - cblas_dtrsv.o + cblas_dtbmv.o cblas_dtbsv.o cblas_dtpmv.o cblas_dtpsv.o cblas_dtrmv.o \ + cblas_dtrsv.o # # All object files for single complex precision @@ -126,7 +127,7 @@ dlev2 = cblas_dgemv.o cblas_dgbmv.o cblas_dger.o cblas_dsbmv.o cblas_dspmv.o \ clev2 = cblas_cgemv.o cblas_cgbmv.o cblas_chemv.o cblas_chbmv.o cblas_chpmv.o \ cblas_ctrmv.o cblas_ctbmv.o cblas_ctpmv.o cblas_ctrsv.o cblas_ctbsv.o \ cblas_ctpsv.o cblas_cgeru.o cblas_cgerc.o cblas_cher.o cblas_cher2.o \ - cblas_chpr.o cblas_chpr2.o + cblas_chpr.o cblas_chpr2.o # # All object files for double complex precision @@ -134,7 +135,8 @@ clev2 = cblas_cgemv.o cblas_cgbmv.o cblas_chemv.o cblas_chbmv.o cblas_chpmv.o \ zlev2 = cblas_zgemv.o cblas_zgbmv.o cblas_zhemv.o cblas_zhbmv.o cblas_zhpmv.o \ cblas_ztrmv.o cblas_ztbmv.o cblas_ztpmv.o cblas_ztrsv.o cblas_ztbsv.o \ cblas_ztpsv.o cblas_zgeru.o cblas_zgerc.o cblas_zher.o cblas_zher2.o \ - cblas_zhpr.o cblas_zhpr2.o + cblas_zhpr.o cblas_zhpr2.o + # # All object files # @@ -149,7 +151,7 @@ slib2: $(slev2) $(errhand) $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(slev2) $(errhand) $(RANLIB) $(CBLASLIB) -# Double real precision +# Double real precision dlib2: $(dlev2) $(errhand) $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(dlev2) $(errhand) $(RANLIB) $(CBLASLIB) @@ -165,41 +167,44 @@ zlib2: $(zlev2) $(errhand) $(RANLIB) $(CBLASLIB) # All precisions -all2: $(alev2) $(errhand) - $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev2) $(errhand) +all2: $(alev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev2) $(errhand) $(RANLIB) $(CBLASLIB) + # # # CBLAS routines # # Level 3 # -# +# # # All object files for single real precision # -slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o\ +slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o \ cblas_strsm.o - + # # All object files for double real precision # -dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o\ - cblas_dtrsm.o +dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o \ + cblas_dtrsm.o # # All object files for single complex precision # -clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o\ - cblas_cher2k.o cblas_ctrmm.o cblas_ctrsm.o cblas_csyrk.o\ +clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o \ + cblas_cher2k.o cblas_ctrmm.o cblas_ctrsm.o cblas_csyrk.o \ cblas_csyr2k.o + # # All object files for double complex precision # -zlev3 = cblas_zgemm.o cblas_zsymm.o cblas_zhemm.o cblas_zherk.o\ - cblas_zher2k.o cblas_ztrmm.o cblas_ztrsm.o cblas_zsyrk.o\ +zlev3 = cblas_zgemm.o cblas_zsymm.o cblas_zhemm.o cblas_zherk.o \ + cblas_zher2k.o cblas_ztrmm.o cblas_ztrsm.o cblas_zsyrk.o \ cblas_zsyr2k.o + # # All object files # @@ -230,20 +235,20 @@ zlib3: $(zlev3) $(errhand) $(RANLIB) $(CBLASLIB) # All precisions -all3: $(alev3) $(errhand) - $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev3) +all3: $(alev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev3) $(RANLIB) $(CBLASLIB) # All levels and precisions -cblaslib: $(alev) - $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev) +cblaslib: $(alev) + $(ARCH) $(ARCHFLAGS) $(CBLASLIB) $(alev) $(RANLIB) $(CBLASLIB) FRC: @FRC=$(FRC) .c.o: - $(CC) -c $(CFLAGS) -I ../include -o $@ $< - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + $(CC) $(CFLAGS) -I../include -c -o $@ $< + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/CBLAS/src/cblas_caxpy.c b/lapack-netlib/CBLAS/src/cblas_caxpy.c index 7579aa707a..73302faf24 100644 --- a/lapack-netlib/CBLAS/src/cblas_caxpy.c +++ b/lapack-netlib/CBLAS/src/cblas_caxpy.c @@ -13,10 +13,10 @@ void cblas_caxpy( const int N, const void *alpha, const void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_caxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_ccopy.c b/lapack-netlib/CBLAS/src/cblas_ccopy.c index b7bc428473..d8d2367017 100644 --- a/lapack-netlib/CBLAS/src/cblas_ccopy.c +++ b/lapack-netlib/CBLAS/src/cblas_ccopy.c @@ -13,7 +13,7 @@ void cblas_ccopy( const int N, const void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_cdotc_sub.c b/lapack-netlib/CBLAS/src/cblas_cdotc_sub.c index 97ac8decf7..fca11cd05d 100644 --- a/lapack-netlib/CBLAS/src/cblas_cdotc_sub.c +++ b/lapack-netlib/CBLAS/src/cblas_cdotc_sub.c @@ -14,7 +14,7 @@ void cblas_cdotc_sub( const int N, const void *X, const int incX, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_cdotu_sub.c b/lapack-netlib/CBLAS/src/cblas_cdotu_sub.c index 6d73d4b5ee..b92e08e549 100644 --- a/lapack-netlib/CBLAS/src/cblas_cdotu_sub.c +++ b/lapack-netlib/CBLAS/src/cblas_cdotu_sub.c @@ -14,7 +14,7 @@ void cblas_cdotu_sub( const int N, const void *X, const int incX, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_cgbmv.c b/lapack-netlib/CBLAS/src/cblas_cgbmv.c index 1ad497a7bf..6d0fa4f83b 100644 --- a/lapack-netlib/CBLAS/src/cblas_cgbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_cgbmv.c @@ -1,7 +1,7 @@ /* * cblas_cgbmv.c * The program is a C interface of cgbmv - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -49,7 +49,7 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_cgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + F77_cgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -112,7 +112,7 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, tincY = -incY; y++; - + if (N > 0) { i = tincY << 1; @@ -127,9 +127,9 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, } else x = (float *) X; - + } - else + else { cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -140,10 +140,10 @@ void cblas_cgbmv(const CBLAS_LAYOUT layout, F77_TA = C2F_CHAR(&TA); #endif if (TransA == CblasConjTrans) - F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); else - F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); if (TransA == CblasConjTrans) { diff --git a/lapack-netlib/CBLAS/src/cblas_cgemm.c b/lapack-netlib/CBLAS/src/cblas_cgemm.c index d97d033099..a1fad4a027 100644 --- a/lapack-netlib/CBLAS/src/cblas_cgemm.c +++ b/lapack-netlib/CBLAS/src/cblas_cgemm.c @@ -15,12 +15,12 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char TA, TB; + char TA, TB; #ifdef F77_CHAR F77_CHAR F77_TA, F77_TB; #else - #define F77_TA &TA - #define F77_TB &TB + #define F77_TA &TA + #define F77_TB &TB #endif #ifdef F77_INT @@ -45,7 +45,7 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TA='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TB='T'; else if ( TransB == CblasConjTrans ) TB='C'; else if ( TransB == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -77,7 +77,7 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TB='T'; else if ( TransA == CblasConjTrans ) TB='C'; else if ( TransA == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -87,7 +87,7 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TA='T'; else if ( TransB == CblasConjTrans ) TA='C'; else if ( TransB == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -101,7 +101,7 @@ void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, F77_cgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_cgemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cgemv.c b/lapack-netlib/CBLAS/src/cblas_cgemv.c index 5eb70ddab8..57c9241e89 100644 --- a/lapack-netlib/CBLAS/src/cblas_cgemv.c +++ b/lapack-netlib/CBLAS/src/cblas_cgemv.c @@ -1,7 +1,7 @@ /* * cblas_cgemv.c * The program is a C interface of cgemv - * + * * Keita Teranishi 5/20/98 * */ @@ -19,7 +19,7 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -48,7 +48,7 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,13 +58,13 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; - + if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) @@ -83,11 +83,11 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, i = incX << 1 ; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do @@ -103,9 +103,9 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, F77_incX = 1; if(incY > 0) - tincY = incY; + tincY = incY; else - tincY = -incY; + tincY = -incY; y++; @@ -117,14 +117,14 @@ void cblas_cgemv(const CBLAS_LAYOUT layout, do { *y = -(*y); y += i; - } while(y != st); + } while(y != st); y -= n; } stx = x; } else stx = (const float *)X; } - else + else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cgerc.c b/lapack-netlib/CBLAS/src/cblas_cgerc.c index 1c8d77758e..6d718be92c 100644 --- a/lapack-netlib/CBLAS/src/cblas_cgerc.c +++ b/lapack-netlib/CBLAS/src/cblas_cgerc.c @@ -1,7 +1,7 @@ /* * cblas_cgerc.c * The program is a C interface to cgerc. - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_cgerc(const CBLAS_LAYOUT layout, const int M, const int N, #define F77_N N #define F77_incX incX #define F77_incY incy - #define F77_lda lda + #define F77_lda lda #endif int n, i, tincy, incy=incY; @@ -33,9 +33,9 @@ void cblas_cgerc(const CBLAS_LAYOUT layout, const int M, const int N, CBLAS_CallFromC = 1; if (layout == CblasColMajor) { - F77_cgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + F77_cgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (N > 0) @@ -48,11 +48,11 @@ void cblas_cgerc(const CBLAS_LAYOUT layout, const int M, const int N, i = incY << 1; tincy = 2; st= y+n; - } else { + } else { i = incY *(-2); tincy = -2; - st = y-2; - y +=(n-2); + st = y-2; + y +=(n-2); } do { @@ -72,7 +72,7 @@ void cblas_cgerc(const CBLAS_LAYOUT layout, const int M, const int N, } else y = (float *) Y; - F77_cgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + F77_cgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, &F77_lda); if(Y!=y) free(y); diff --git a/lapack-netlib/CBLAS/src/cblas_cgeru.c b/lapack-netlib/CBLAS/src/cblas_cgeru.c index b2a534fc02..bb0671b6ca 100644 --- a/lapack-netlib/CBLAS/src/cblas_cgeru.c +++ b/lapack-netlib/CBLAS/src/cblas_cgeru.c @@ -1,7 +1,7 @@ /* * cblas_cgeru.c * The program is a C interface to cgeru. - * + * * Keita Teranishi 5/20/98 * */ @@ -35,7 +35,7 @@ void cblas_cgeru(const CBLAS_LAYOUT layout, const int M, const int N, else if (layout == CblasRowMajor) { RowMajorStrg = 1; - F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_cgeru","Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_chbmv.c b/lapack-netlib/CBLAS/src/cblas_chbmv.c index e5058f1edb..e2ac98d079 100644 --- a/lapack-netlib/CBLAS/src/cblas_chbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_chbmv.c @@ -1,7 +1,7 @@ /* * cblas_chbmv.c * The program is a C interface to chbmv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -44,7 +44,7 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_chbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + F77_chbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -69,7 +69,7 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(float)); - + tx = x; if( incX > 0 ) { i = incX << 1 ; @@ -98,7 +98,7 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -114,11 +114,11 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, } while(y != st); y -= n; } else - x = (float *) X; + x = (float *) X; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -128,10 +128,10 @@ void cblas_chbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_chbmv(F77_UL, &F77_N, &F77_K, ALPHA, + F77_chbmv(F77_UL, &F77_N, &F77_K, ALPHA, A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_chbmv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_chemm.c b/lapack-netlib/CBLAS/src/cblas_chemm.c index 91fbcbe478..7d500dfcc0 100644 --- a/lapack-netlib/CBLAS/src/cblas_chemm.c +++ b/lapack-netlib/CBLAS/src/cblas_chemm.c @@ -15,12 +15,12 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,7 +43,7 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -66,14 +66,14 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_SD = C2F_CHAR(&SD); #endif - F77_chemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + F77_chemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -83,7 +83,7 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,7 +98,7 @@ void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_chemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_chemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_chemv.c b/lapack-netlib/CBLAS/src/cblas_chemv.c index 878be7af7b..ad6a6d05a7 100644 --- a/lapack-netlib/CBLAS/src/cblas_chemv.c +++ b/lapack-netlib/CBLAS/src/cblas_chemv.c @@ -1,7 +1,7 @@ /* * cblas_chemv.c * The program is a C interface to chemv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_chemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -44,7 +44,7 @@ void cblas_chemv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_chemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_chemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + F77_chemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -69,7 +69,7 @@ void cblas_chemv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(float)); - + tx = x; if( incX > 0 ) { i = incX << 1 ; @@ -98,7 +98,7 @@ void cblas_chemv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -116,10 +116,10 @@ void cblas_chemv(const CBLAS_LAYOUT layout, } else x = (float *) X; - + if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -129,10 +129,10 @@ void cblas_chemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_chemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + F77_chemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_chemv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cher.c b/lapack-netlib/CBLAS/src/cblas_cher.c index 245fe5b112..c783073bc5 100644 --- a/lapack-netlib/CBLAS/src/cblas_cher.c +++ b/lapack-netlib/CBLAS/src/cblas_cher.c @@ -1,7 +1,7 @@ /* * cblas_cher.c * The program is a C interface to cher. - * + * * Keita Teranishi 5/20/98 * */ @@ -33,13 +33,13 @@ void cblas_cher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_cher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -76,11 +76,11 @@ void cblas_cher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, i = incX << 1 ; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do { @@ -100,16 +100,16 @@ void cblas_cher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } else x = (float *) X; F77_cher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); - } else + } else { cblas_xerbla(1, "cblas_cher","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } - if(X!=x) + if(X!=x) free(x); - + CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/lapack-netlib/CBLAS/src/cblas_cher2.c b/lapack-netlib/CBLAS/src/cblas_cher2.c index bdded3e158..4bab665b82 100644 --- a/lapack-netlib/CBLAS/src/cblas_cher2.c +++ b/lapack-netlib/CBLAS/src/cblas_cher2.c @@ -1,7 +1,7 @@ /* * cblas_cher2.c * The program is a C interface to cher2. - * + * * Keita Teranishi 3/23/98 * */ @@ -29,19 +29,19 @@ void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_incY incy #endif int n, i, j, tincx, tincy, incx=incX, incy=incY; - float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, + float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, *yy=(float *)Y, *tx, *ty, *stx, *sty; extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_cher2(F77_UL, &F77_N, alpha, X, &F77_incX, + F77_cher2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (layout == CblasRowMajor) @@ -60,7 +60,7 @@ void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -74,29 +74,29 @@ void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { n = N << 1; x = malloc(n*sizeof(float)); - y = malloc(n*sizeof(float)); + y = malloc(n*sizeof(float)); tx = x; ty = y; if( incX > 0 ) { i = incX << 1 ; tincx = 2; stx= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - stx = x-2; - x +=(n-2); + stx = x-2; + x +=(n-2); } - + if( incY > 0 ) { j = incY << 1; tincy = 2; sty= y+n; - } else { + } else { j = incY *(-2); tincy = -2; - sty = y-2; - y +=(n-2); + sty = y-2; + y +=(n-2); } do @@ -127,14 +127,14 @@ void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, incx = 1; incy = 1; #endif - } else + } else { x = (float *) X; y = (float *) Y; } - F77_cher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + F77_cher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, A, &F77_lda); - } else + } else { cblas_xerbla(1, "cblas_cher2","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cher2k.c b/lapack-netlib/CBLAS/src/cblas_cher2k.c index 2fc770097a..cae8c76104 100644 --- a/lapack-netlib/CBLAS/src/cblas_cher2k.c +++ b/lapack-netlib/CBLAS/src/cblas_cher2k.c @@ -15,12 +15,12 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *B, const int ldb, const float beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -36,7 +36,7 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; - float ALPHA[2]; + float ALPHA[2]; const float *alp=(float *)alpha; CBLAS_CallFromC = 1; @@ -47,7 +47,7 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -75,10 +75,10 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } else if (layout == CblasRowMajor) { RowMajorStrg = 1; - + if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -88,7 +88,7 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='C'; - else + else { cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -103,7 +103,7 @@ void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, ALPHA[0]= *alp; ALPHA[1]= -alp[1]; F77_cher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_cher2k", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cherk.c b/lapack-netlib/CBLAS/src/cblas_cherk.c index 5157d7bb24..16a94db4c2 100644 --- a/lapack-netlib/CBLAS/src/cblas_cherk.c +++ b/lapack-netlib/CBLAS/src/cblas_cherk.c @@ -14,12 +14,12 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const float alpha, const void *A, const int lda, const float beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -41,7 +41,7 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -72,7 +72,7 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -82,7 +82,7 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='C'; - else + else { cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -97,7 +97,7 @@ void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_cherk", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_chpmv.c b/lapack-netlib/CBLAS/src/cblas_chpmv.c index 3b587e3a53..8ec1cec96d 100644 --- a/lapack-netlib/CBLAS/src/cblas_chpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_chpmv.c @@ -1,7 +1,7 @@ /* * cblas_chpmv.c * The program is a C interface of chpmv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; @@ -37,12 +37,12 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, extern int RowMajorStrg; RowMajorStrg = 0; - CBLAS_CallFromC = 1; + CBLAS_CallFromC = 1; if (layout == CblasColMajor) - { + { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_chpmv(F77_UL, &F77_N, alpha, AP, X, + F77_chpmv(F77_UL, &F77_N, alpha, AP, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -67,7 +67,7 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(float)); - + tx = x; if( incX > 0 ) { i = incX << 1; @@ -96,7 +96,7 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -117,7 +117,7 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo ); CBLAS_CallFromC = 0; @@ -128,17 +128,17 @@ void cblas_chpmv(const CBLAS_LAYOUT layout, F77_UL = C2F_CHAR(&UL); #endif - F77_chpmv(F77_UL, &F77_N, ALPHA, + F77_chpmv(F77_UL, &F77_N, ALPHA, AP, x, &F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_chpmv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } - if ( layout == CblasRowMajor ) + if ( layout == CblasRowMajor ) { RowMajorStrg = 1; if(X!=x) diff --git a/lapack-netlib/CBLAS/src/cblas_chpr.c b/lapack-netlib/CBLAS/src/cblas_chpr.c index 1797a8fd0a..82a108d1c0 100644 --- a/lapack-netlib/CBLAS/src/cblas_chpr.c +++ b/lapack-netlib/CBLAS/src/cblas_chpr.c @@ -1,7 +1,7 @@ /* * cblas_chpr.c * The program is a C interface to chpr. - * + * * Keita Teranishi 3/23/98 * */ @@ -32,13 +32,13 @@ void cblas_chpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_chpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -75,11 +75,11 @@ void cblas_chpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, i = incX << 1; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do { @@ -100,7 +100,7 @@ void cblas_chpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_chpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); - } else + } else { cblas_xerbla(1, "cblas_chpr","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_chpr2.c b/lapack-netlib/CBLAS/src/cblas_chpr2.c index c73168c74b..5277f878cd 100644 --- a/lapack-netlib/CBLAS/src/cblas_chpr2.c +++ b/lapack-netlib/CBLAS/src/cblas_chpr2.c @@ -1,7 +1,7 @@ /* * cblas_chpr2.c * The program is a C interface to chpr2. - * + * * Keita Teranishi 5/20/98 * */ @@ -10,7 +10,7 @@ #include "cblas.h" #include "cblas_f77.h" void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, - const int N,const void *alpha, const void *X, + const int N,const void *alpha, const void *X, const int incX,const void *Y, const int incY, void *Ap) { @@ -35,13 +35,13 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -86,7 +86,7 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, stx = x-2; x +=(n-2); } - + if( incY > 0 ) { j = incY << 1; tincy = 2; @@ -97,7 +97,7 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, sty = y-2; y +=(n-2); } - + do { *x = *xx; @@ -114,10 +114,10 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, yy += j; } while (y != sty); - + x=tx; y=ty; - + #ifdef F77_INT F77_incX = 1; F77_incY = 1; @@ -126,13 +126,13 @@ void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, incy = 1; #endif - } else + } else { x = (float *) X; y = (void *) Y; } F77_chpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); - } else + } else { cblas_xerbla(1, "cblas_chpr2","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_cscal.c b/lapack-netlib/CBLAS/src/cblas_cscal.c index 780d3124e5..904881f1d3 100644 --- a/lapack-netlib/CBLAS/src/cblas_cscal.c +++ b/lapack-netlib/CBLAS/src/cblas_cscal.c @@ -8,12 +8,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_cscal( const int N, const void *alpha, void *X, +void cblas_cscal( const int N, const void *alpha, void *X, const int incX) { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_csscal.c b/lapack-netlib/CBLAS/src/cblas_csscal.c index 39983fe071..117ed40517 100644 --- a/lapack-netlib/CBLAS/src/cblas_csscal.c +++ b/lapack-netlib/CBLAS/src/cblas_csscal.c @@ -13,7 +13,7 @@ void cblas_csscal( const int N, const float alpha, void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_cswap.c b/lapack-netlib/CBLAS/src/cblas_cswap.c index 1272820727..738d35cf19 100644 --- a/lapack-netlib/CBLAS/src/cblas_cswap.c +++ b/lapack-netlib/CBLAS/src/cblas_cswap.c @@ -13,7 +13,7 @@ void cblas_cswap( const int N, void *X, const int incX, void *Y, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_csymm.c b/lapack-netlib/CBLAS/src/cblas_csymm.c index 888b3253eb..d60ebb8461 100644 --- a/lapack-netlib/CBLAS/src/cblas_csymm.c +++ b/lapack-netlib/CBLAS/src/cblas_csymm.c @@ -15,12 +15,12 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,7 +43,7 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -83,7 +83,7 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,9 +98,9 @@ void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_csymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_csymm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_csyr2k.c b/lapack-netlib/CBLAS/src/cblas_csyr2k.c index f99caab616..4bbd417a82 100644 --- a/lapack-netlib/CBLAS/src/cblas_csyr2k.c +++ b/lapack-netlib/CBLAS/src/cblas_csyr2k.c @@ -15,12 +15,12 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -44,7 +44,7 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -86,7 +86,7 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -100,7 +100,7 @@ void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #endif F77_csyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_csyr2k", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_csyrk.c b/lapack-netlib/CBLAS/src/cblas_csyrk.c index 94809cec00..26b745bdac 100644 --- a/lapack-netlib/CBLAS/src/cblas_csyrk.c +++ b/lapack-netlib/CBLAS/src/cblas_csyrk.c @@ -14,12 +14,12 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *alpha, const void *A, const int lda, const void *beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -42,7 +42,7 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -84,7 +84,7 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_csyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_csyrk", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctbmv.c b/lapack-netlib/CBLAS/src/cblas_ctbmv.c index f584bf6acb..949e074331 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctbmv.c @@ -1,7 +1,7 @@ /* * cblas_ctbmv.c * The program is a C interface to ctbmv. - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0, *x=(float *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctbmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -112,7 +112,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctbsv.c b/lapack-netlib/CBLAS/src/cblas_ctbsv.c index 97778f4c27..12696e112a 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctbsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctbsv.c @@ -1,7 +1,7 @@ /* * cblas_ctbsv.c * The program is a C interface to ctbsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -20,7 +20,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0,*x=(float *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -99,9 +99,9 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); - + x++; st=x+n; @@ -116,7 +116,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -126,7 +126,7 @@ void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctpmv.c b/lapack-netlib/CBLAS/src/cblas_ctpmv.c index 6f12c96a38..3f73172b03 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctpmv.c @@ -1,7 +1,7 @@ /* * cblas_ctpmv.c * The program is a C interface to ctpmv. - * + * * Keita Teranishi 5/20/98 * */ @@ -19,7 +19,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -27,7 +27,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_N N #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0,*x=(float *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -38,7 +38,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -108,7 +108,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -118,7 +118,7 @@ void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctpsv.c b/lapack-netlib/CBLAS/src/cblas_ctpsv.c index 808827e9ac..4791e20f9c 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctpsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctpsv.c @@ -1,7 +1,7 @@ /* * cblas_ctpsv.c * The program is a C interface to ctpsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -19,7 +19,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -27,7 +27,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_N N #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0, *x=(float*)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -38,7 +38,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -95,9 +95,9 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); - + x++; st=x+n; @@ -112,7 +112,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctrmm.c b/lapack-netlib/CBLAS/src/cblas_ctrmm.c index 0407a68239..7a7ab36242 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctrmm.c +++ b/lapack-netlib/CBLAS/src/cblas_ctrmm.c @@ -15,12 +15,12 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *alpha, const void *A, const int lda, void *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -43,7 +43,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight ) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper ) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -63,7 +63,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans ) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else cblas_xerbla(5, "cblas_ctrmm", + else cblas_xerbla(5, "cblas_ctrmm", "Illegal Diag setting, %d\n", Diag); #ifdef F77_CHAR @@ -89,7 +89,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight ) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper ) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -110,7 +110,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans ) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -120,7 +120,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ctrmm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -136,7 +136,7 @@ void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, #endif F77_ctrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_ctrmm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctrmv.c b/lapack-netlib/CBLAS/src/cblas_ctrmv.c index cc87f754e8..447f7081cc 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctrmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctrmv.c @@ -1,7 +1,7 @@ /* * cblas_ctrmv.c * The program is a C interface to ctrmv. - * + * * Keita Teranishi 3/23/98 * */ @@ -21,7 +21,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0,*x=(float *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -111,7 +111,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -121,7 +121,7 @@ void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctrsm.c b/lapack-netlib/CBLAS/src/cblas_ctrsm.c index 51218832c5..a95b28d68a 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctrsm.c +++ b/lapack-netlib/CBLAS/src/cblas_ctrsm.c @@ -44,7 +44,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -65,7 +65,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -75,7 +75,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -98,7 +98,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -108,7 +108,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -119,7 +119,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -129,7 +129,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -147,7 +147,7 @@ void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_ctrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_ctrsm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ctrsv.c b/lapack-netlib/CBLAS/src/cblas_ctrsv.c index fb3a8fc2da..cd10f778a7 100644 --- a/lapack-netlib/CBLAS/src/cblas_ctrsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ctrsv.c @@ -1,7 +1,7 @@ /* * cblas_ctrsv.c * The program is a C interface to ctrsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -20,7 +20,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -29,7 +29,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; float *st=0,*x=(float *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -40,7 +40,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -50,7 +50,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -79,7 +79,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,10 +98,10 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); x++; - st=x+n; + st=x+n; i = tincX << 1; do { @@ -112,7 +112,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dasum.c b/lapack-netlib/CBLAS/src/cblas_dasum.c index 1a3667f2d7..dbd224a91f 100644 --- a/lapack-netlib/CBLAS/src/cblas_dasum.c +++ b/lapack-netlib/CBLAS/src/cblas_dasum.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -double cblas_dasum( const int N, const double *X, const int incX) +double cblas_dasum( const int N, const double *X, const int incX) { double asum; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_daxpy.c b/lapack-netlib/CBLAS/src/cblas_daxpy.c index 3678137fb7..fdbf982f87 100644 --- a/lapack-netlib/CBLAS/src/cblas_daxpy.c +++ b/lapack-netlib/CBLAS/src/cblas_daxpy.c @@ -13,10 +13,10 @@ void cblas_daxpy( const int N, const double alpha, const double *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_daxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_dcopy.c b/lapack-netlib/CBLAS/src/cblas_dcopy.c index 422a55e517..b3bb82b6e2 100644 --- a/lapack-netlib/CBLAS/src/cblas_dcopy.c +++ b/lapack-netlib/CBLAS/src/cblas_dcopy.c @@ -13,7 +13,7 @@ void cblas_dcopy( const int N, const double *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_ddot.c b/lapack-netlib/CBLAS/src/cblas_ddot.c index d773434031..650bc76e74 100644 --- a/lapack-netlib/CBLAS/src/cblas_ddot.c +++ b/lapack-netlib/CBLAS/src/cblas_ddot.c @@ -15,11 +15,11 @@ double cblas_ddot( const int N, const double *X, double dot; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_ddot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); return dot; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_dgbmv.c b/lapack-netlib/CBLAS/src/cblas_dgbmv.c index 1cc305415c..11119025b0 100644 --- a/lapack-netlib/CBLAS/src/cblas_dgbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dgbmv.c @@ -19,7 +19,7 @@ void cblas_dgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -43,7 +43,7 @@ void cblas_dgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_dgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_dgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + F77_dgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -62,7 +62,7 @@ void cblas_dgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -72,7 +72,7 @@ void cblas_dgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_dgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + F77_dgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_dgbmv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_dgemm.c b/lapack-netlib/CBLAS/src/cblas_dgemm.c index e37f4092db..5f525dde7b 100644 --- a/lapack-netlib/CBLAS/src/cblas_dgemm.c +++ b/lapack-netlib/CBLAS/src/cblas_dgemm.c @@ -15,12 +15,12 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, const int lda, const double *B, const int ldb, const double beta, double *C, const int ldc) { - char TA, TB; + char TA, TB; #ifdef F77_CHAR F77_CHAR F77_TA, F77_TB; #else - #define F77_TA &TA - #define F77_TB &TB + #define F77_TA &TA + #define F77_TB &TB #endif #ifdef F77_INT @@ -45,7 +45,7 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TA='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TB='T'; else if ( TransB == CblasConjTrans ) TB='C'; else if ( TransB == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(3, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -77,7 +77,7 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TB='T'; else if ( TransA == CblasConjTrans ) TB='C'; else if ( TransA == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -87,7 +87,7 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TA='T'; else if ( TransB == CblasConjTrans ) TA='C'; else if ( TransB == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -101,7 +101,7 @@ void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, F77_dgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_dgemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dgemv.c b/lapack-netlib/CBLAS/src/cblas_dgemv.c index 65968aceb9..a3f060aeb3 100644 --- a/lapack-netlib/CBLAS/src/cblas_dgemv.c +++ b/lapack-netlib/CBLAS/src/cblas_dgemv.c @@ -18,7 +18,7 @@ void cblas_dgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -39,7 +39,7 @@ void cblas_dgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_dgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_dgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + F77_dgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -58,7 +58,7 @@ void cblas_dgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dger.c b/lapack-netlib/CBLAS/src/cblas_dger.c index 3b89f67f7a..d536537749 100644 --- a/lapack-netlib/CBLAS/src/cblas_dger.c +++ b/lapack-netlib/CBLAS/src/cblas_dger.c @@ -30,13 +30,13 @@ void cblas_dger(const CBLAS_LAYOUT layout, const int M, const int N, CBLAS_CallFromC = 1; if (layout == CblasColMajor) { - F77_dger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + F77_dger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; - F77_dger( &F77_N, &F77_M ,&alpha, Y, &F77_incY, X, &F77_incX, A, + F77_dger( &F77_N, &F77_M ,&alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } diff --git a/lapack-netlib/CBLAS/src/cblas_dnrm2.c b/lapack-netlib/CBLAS/src/cblas_dnrm2.c index fe46ad4849..99f8368d24 100644 --- a/lapack-netlib/CBLAS/src/cblas_dnrm2.c +++ b/lapack-netlib/CBLAS/src/cblas_dnrm2.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -double cblas_dnrm2( const int N, const double *X, const int incX) +double cblas_dnrm2( const int N, const double *X, const int incX) { double nrm2; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_drot.c b/lapack-netlib/CBLAS/src/cblas_drot.c index 51dc4ad5ef..ec1887ab05 100644 --- a/lapack-netlib/CBLAS/src/cblas_drot.c +++ b/lapack-netlib/CBLAS/src/cblas_drot.c @@ -14,9 +14,9 @@ void cblas_drot(const int N, double *X, const int incX, #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; #else - #define F77_N N - #define F77_incX incX - #define F77_incY incY + #define F77_N N + #define F77_incX incX + #define F77_incY incY #endif F77_drot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); return; diff --git a/lapack-netlib/CBLAS/src/cblas_drotg.c b/lapack-netlib/CBLAS/src/cblas_drotg.c index 0cbbd8bc0b..a433f4844f 100644 --- a/lapack-netlib/CBLAS/src/cblas_drotg.c +++ b/lapack-netlib/CBLAS/src/cblas_drotg.c @@ -10,5 +10,5 @@ #include "cblas_f77.h" void cblas_drotg( double *a, double *b, double *c, double *s) { - F77_drotg(a,b,c,s); + F77_drotg(a,b,c,s); } diff --git a/lapack-netlib/CBLAS/src/cblas_drotm.c b/lapack-netlib/CBLAS/src/cblas_drotm.c index ebe20ad627..26ee53332d 100644 --- a/lapack-netlib/CBLAS/src/cblas_drotm.c +++ b/lapack-netlib/CBLAS/src/cblas_drotm.c @@ -1,6 +1,6 @@ #include "cblas.h" #include "cblas_f77.h" -void cblas_drotm( const int N, double *X, const int incX, double *Y, +void cblas_drotm( const int N, double *X, const int incX, double *Y, const int incY, const double *P) { #ifdef F77_INT @@ -11,4 +11,4 @@ void cblas_drotm( const int N, double *X, const int incX, double *Y, #define F77_incY incY #endif F77_drotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_drotmg.c b/lapack-netlib/CBLAS/src/cblas_drotmg.c index 13a2208e5f..ad33ba4fd2 100644 --- a/lapack-netlib/CBLAS/src/cblas_drotmg.c +++ b/lapack-netlib/CBLAS/src/cblas_drotmg.c @@ -8,7 +8,7 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_drotmg( double *d1, double *d2, double *b1, +void cblas_drotmg( double *d1, double *d2, double *b1, const double b2, double *p) { F77_drotmg(d1,d2,b1,&b2,p); diff --git a/lapack-netlib/CBLAS/src/cblas_dsbmv.c b/lapack-netlib/CBLAS/src/cblas_dsbmv.c index 78f114226c..84c7c1a547 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dsbmv.c @@ -19,7 +19,7 @@ void cblas_dsbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -39,7 +39,7 @@ void cblas_dsbmv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_dsbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -57,7 +57,7 @@ void cblas_dsbmv(const CBLAS_LAYOUT layout, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -67,7 +67,7 @@ void cblas_dsbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_dsbmv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_dscal.c b/lapack-netlib/CBLAS/src/cblas_dscal.c index bd04de77d6..cef902af25 100644 --- a/lapack-netlib/CBLAS/src/cblas_dscal.c +++ b/lapack-netlib/CBLAS/src/cblas_dscal.c @@ -8,12 +8,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_dscal( const int N, const double alpha, double *X, +void cblas_dscal( const int N, const double alpha, double *X, const int incX) { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_dsdot.c b/lapack-netlib/CBLAS/src/cblas_dsdot.c index 52cd877a20..ef776e4bec 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsdot.c +++ b/lapack-netlib/CBLAS/src/cblas_dsdot.c @@ -15,11 +15,11 @@ double cblas_dsdot( const int N, const float *X, double dot; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_dsdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); return dot; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_dspmv.c b/lapack-netlib/CBLAS/src/cblas_dspmv.c index 7512866413..e0e9a3209e 100644 --- a/lapack-netlib/CBLAS/src/cblas_dspmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dspmv.c @@ -6,7 +6,7 @@ * 4/6/1998 * */ - + #include "cblas.h" #include "cblas_f77.h" @@ -20,7 +20,7 @@ void cblas_dspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; @@ -38,7 +38,7 @@ void cblas_dspmv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_dspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dspmv(F77_UL, &F77_N, &alpha, AP, X, + F77_dspmv(F77_UL, &F77_N, &alpha, AP, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -56,7 +56,7 @@ void cblas_dspmv(const CBLAS_LAYOUT layout, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -66,7 +66,7 @@ void cblas_dspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dspmv(F77_UL, &F77_N, &alpha, + F77_dspmv(F77_UL, &F77_N, &alpha, AP, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_dspmv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_dspr.c b/lapack-netlib/CBLAS/src/cblas_dspr.c index fa1c4fbb29..cb286a86a8 100644 --- a/lapack-netlib/CBLAS/src/cblas_dspr.c +++ b/lapack-netlib/CBLAS/src/cblas_dspr.c @@ -34,7 +34,7 @@ void cblas_dspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -47,12 +47,12 @@ void cblas_dspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -61,8 +61,8 @@ void cblas_dspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + #endif + F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); } else cblas_xerbla(1, "cblas_dspr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dspr2.c b/lapack-netlib/CBLAS/src/cblas_dspr2.c index 36eeaf97f8..c4560642dc 100644 --- a/lapack-netlib/CBLAS/src/cblas_dspr2.c +++ b/lapack-netlib/CBLAS/src/cblas_dspr2.c @@ -34,7 +34,7 @@ void cblas_dspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -47,12 +47,12 @@ void cblas_dspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -61,8 +61,8 @@ void cblas_dspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + #endif + F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); } else cblas_xerbla(1, "cblas_dspr2", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dswap.c b/lapack-netlib/CBLAS/src/cblas_dswap.c index 9ae5bb93c0..bf78fcf9b5 100644 --- a/lapack-netlib/CBLAS/src/cblas_dswap.c +++ b/lapack-netlib/CBLAS/src/cblas_dswap.c @@ -13,7 +13,7 @@ void cblas_dswap( const int N, double *X, const int incX, double *Y, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_dsymm.c b/lapack-netlib/CBLAS/src/cblas_dsymm.c index 03f65a8930..457a95fc0f 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsymm.c +++ b/lapack-netlib/CBLAS/src/cblas_dsymm.c @@ -15,12 +15,12 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const double *B, const int ldb, const double beta, double *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,7 +43,7 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -83,7 +83,7 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,9 +98,9 @@ void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_dsymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); - } - else cblas_xerbla(1, "cblas_dsymm","Illegal layout setting, %d\n", layout); + } + else cblas_xerbla(1, "cblas_dsymm","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_dsymv.c b/lapack-netlib/CBLAS/src/cblas_dsymv.c index 3bda0a178a..e31c774988 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsymv.c +++ b/lapack-netlib/CBLAS/src/cblas_dsymv.c @@ -19,7 +19,7 @@ void cblas_dsymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -38,7 +38,7 @@ void cblas_dsymv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_dsymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dsymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + F77_dsymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -56,7 +56,7 @@ void cblas_dsymv(const CBLAS_LAYOUT layout, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -66,7 +66,7 @@ void cblas_dsymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_dsymv(F77_UL, &F77_N, &alpha, + F77_dsymv(F77_UL, &F77_N, &alpha, A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_dsymv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_dsyr.c b/lapack-netlib/CBLAS/src/cblas_dsyr.c index aa1e43c48b..bc4a1e836b 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsyr.c +++ b/lapack-netlib/CBLAS/src/cblas_dsyr.c @@ -35,7 +35,7 @@ void cblas_dsyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -48,12 +48,12 @@ void cblas_dsyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -62,10 +62,10 @@ void cblas_dsyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + #endif + F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_dsyr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_dsyr2.c b/lapack-netlib/CBLAS/src/cblas_dsyr2.c index 601e66984e..4607c7a430 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsyr2.c +++ b/lapack-netlib/CBLAS/src/cblas_dsyr2.c @@ -38,7 +38,7 @@ void cblas_dsyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -49,15 +49,15 @@ void cblas_dsyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -66,9 +66,9 @@ void cblas_dsyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, - &F77_lda); + #endif + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); } else cblas_xerbla(1, "cblas_dsyr2", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dsyr2k.c b/lapack-netlib/CBLAS/src/cblas_dsyr2k.c index bf214deb7d..9e92120174 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsyr2k.c +++ b/lapack-netlib/CBLAS/src/cblas_dsyr2k.c @@ -15,12 +15,12 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const double *B, const int ldb, const double beta, double *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -44,7 +44,7 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -86,7 +86,7 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -99,9 +99,9 @@ void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_TR = C2F_CHAR(&TR); #endif - F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, + F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_dsyr2k","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dsyrk.c b/lapack-netlib/CBLAS/src/cblas_dsyrk.c index 2d2dfe6acb..d98b4705d8 100644 --- a/lapack-netlib/CBLAS/src/cblas_dsyrk.c +++ b/lapack-netlib/CBLAS/src/cblas_dsyrk.c @@ -14,12 +14,12 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const double alpha, const double *A, const int lda, const double beta, double *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -42,7 +42,7 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -84,7 +84,7 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_dsyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_dsyrk","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtbmv.c b/lapack-netlib/CBLAS/src/cblas_dtbmv.c index 08caef4729..6438651ad4 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtbmv.c @@ -20,7 +20,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtbmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtbsv.c b/lapack-netlib/CBLAS/src/cblas_dtbsv.c index 275889c834..eac77055b5 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtbsv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtbsv.c @@ -20,7 +20,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtpmv.c b/lapack-netlib/CBLAS/src/cblas_dtpmv.c index d18f7f35d0..6946d9846f 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtpmv.c @@ -19,7 +19,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -36,7 +36,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -46,7 +46,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -85,7 +85,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -95,7 +95,7 @@ void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtpsv.c b/lapack-netlib/CBLAS/src/cblas_dtpsv.c index ef30807e9a..b29476767a 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtpsv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtpsv.c @@ -19,7 +19,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -36,7 +36,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -46,7 +46,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -85,7 +85,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -95,7 +95,7 @@ void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtrmm.c b/lapack-netlib/CBLAS/src/cblas_dtrmm.c index 76bba298bc..6ee79e42d2 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtrmm.c +++ b/lapack-netlib/CBLAS/src/cblas_dtrmm.c @@ -15,12 +15,12 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const double alpha, const double *A, const int lda, double *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -43,7 +43,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -63,7 +63,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -94,7 +94,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -104,7 +104,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -115,7 +115,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -125,7 +125,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -140,7 +140,7 @@ void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_DI = C2F_CHAR(&DI); #endif F77_dtrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_dtrmm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtrmv.c b/lapack-netlib/CBLAS/src/cblas_dtrmv.c index 1a6dc5901a..18c492142d 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtrmv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtrmv.c @@ -6,7 +6,7 @@ * 4/6/1998 * */ - + #include "cblas.h" #include "cblas_f77.h" void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, @@ -23,7 +23,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -41,7 +41,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -91,7 +91,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -101,7 +101,7 @@ void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtrsm.c b/lapack-netlib/CBLAS/src/cblas_dtrsm.c index 21f94476be..47396020dd 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtrsm.c +++ b/lapack-netlib/CBLAS/src/cblas_dtrsm.c @@ -16,12 +16,12 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, double *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -44,7 +44,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if ( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if ( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower) UL='L'; - else + else { cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -64,7 +64,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if ( TransA == CblasTrans ) TA='T'; else if ( TransA == CblasConjTrans) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if ( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit) DI='N'; - else + else { cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -91,13 +91,13 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); - } + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if ( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -107,7 +107,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if ( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower) UL='U'; - else + else { cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -118,7 +118,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if ( TransA == CblasTrans ) TA='T'; else if ( TransA == CblasConjTrans) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -128,7 +128,7 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if ( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit) DI='N'; - else + else { cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -143,9 +143,9 @@ void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_DI = C2F_CHAR(&DI); #endif - F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, + F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_dtrsm","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dtrsv.c b/lapack-netlib/CBLAS/src/cblas_dtrsv.c index 21c791fd43..c0a51c10be 100644 --- a/lapack-netlib/CBLAS/src/cblas_dtrsv.c +++ b/lapack-netlib/CBLAS/src/cblas_dtrsv.c @@ -21,7 +21,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_dzasum.c b/lapack-netlib/CBLAS/src/cblas_dzasum.c index b32f573e5f..a120e00fef 100644 --- a/lapack-netlib/CBLAS/src/cblas_dzasum.c +++ b/lapack-netlib/CBLAS/src/cblas_dzasum.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -double cblas_dzasum( const int N, const void *X, const int incX) +double cblas_dzasum( const int N, const void *X, const int incX) { double asum; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_dznrm2.c b/lapack-netlib/CBLAS/src/cblas_dznrm2.c index dfa2bfc837..e44db340d6 100644 --- a/lapack-netlib/CBLAS/src/cblas_dznrm2.c +++ b/lapack-netlib/CBLAS/src/cblas_dznrm2.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -double cblas_dznrm2( const int N, const void *X, const int incX) +double cblas_dznrm2( const int N, const void *X, const int incX) { double nrm2; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_icamax.c b/lapack-netlib/CBLAS/src/cblas_icamax.c index 52f1db619e..0fe5625d94 100644 --- a/lapack-netlib/CBLAS/src/cblas_icamax.c +++ b/lapack-netlib/CBLAS/src/cblas_icamax.c @@ -14,7 +14,7 @@ CBLAS_INDEX cblas_icamax( const int N, const void *X, const int incX) CBLAS_INDEX iamax; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_idamax.c b/lapack-netlib/CBLAS/src/cblas_idamax.c index 07008ef465..e0c4cd883c 100644 --- a/lapack-netlib/CBLAS/src/cblas_idamax.c +++ b/lapack-netlib/CBLAS/src/cblas_idamax.c @@ -14,7 +14,7 @@ CBLAS_INDEX cblas_idamax( const int N, const double *X, const int incX) CBLAS_INDEX iamax; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_isamax.c b/lapack-netlib/CBLAS/src/cblas_isamax.c index 507eb9235a..e2f3fd86ca 100644 --- a/lapack-netlib/CBLAS/src/cblas_isamax.c +++ b/lapack-netlib/CBLAS/src/cblas_isamax.c @@ -14,7 +14,7 @@ CBLAS_INDEX cblas_isamax( const int N, const float *X, const int incX) CBLAS_INDEX iamax; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_izamax.c b/lapack-netlib/CBLAS/src/cblas_izamax.c index 3623749826..4370d942a4 100644 --- a/lapack-netlib/CBLAS/src/cblas_izamax.c +++ b/lapack-netlib/CBLAS/src/cblas_izamax.c @@ -14,7 +14,7 @@ CBLAS_INDEX cblas_izamax( const int N, const void *X, const int incX) CBLAS_INDEX iamax; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_sasum.c b/lapack-netlib/CBLAS/src/cblas_sasum.c index 7d4c32cf9e..042939af48 100644 --- a/lapack-netlib/CBLAS/src/cblas_sasum.c +++ b/lapack-netlib/CBLAS/src/cblas_sasum.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -float cblas_sasum( const int N, const float *X, const int incX) +float cblas_sasum( const int N, const float *X, const int incX) { float asum; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_saxpy.c b/lapack-netlib/CBLAS/src/cblas_saxpy.c index 2eee8e06e4..baf17a5475 100644 --- a/lapack-netlib/CBLAS/src/cblas_saxpy.c +++ b/lapack-netlib/CBLAS/src/cblas_saxpy.c @@ -14,10 +14,10 @@ void cblas_saxpy( const int N, const float alpha, const float *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_saxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_scasum.c b/lapack-netlib/CBLAS/src/cblas_scasum.c index e1fa53090a..1f5b7d4035 100644 --- a/lapack-netlib/CBLAS/src/cblas_scasum.c +++ b/lapack-netlib/CBLAS/src/cblas_scasum.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -float cblas_scasum( const int N, const void *X, const int incX) +float cblas_scasum( const int N, const void *X, const int incX) { float asum; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_scnrm2.c b/lapack-netlib/CBLAS/src/cblas_scnrm2.c index fa48454ed5..c05b338cdb 100644 --- a/lapack-netlib/CBLAS/src/cblas_scnrm2.c +++ b/lapack-netlib/CBLAS/src/cblas_scnrm2.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -float cblas_scnrm2( const int N, const void *X, const int incX) +float cblas_scnrm2( const int N, const void *X, const int incX) { float nrm2; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_scopy.c b/lapack-netlib/CBLAS/src/cblas_scopy.c index 7796959f33..1424391f6d 100644 --- a/lapack-netlib/CBLAS/src/cblas_scopy.c +++ b/lapack-netlib/CBLAS/src/cblas_scopy.c @@ -13,7 +13,7 @@ void cblas_scopy( const int N, const float *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_sdot.c b/lapack-netlib/CBLAS/src/cblas_sdot.c index baf859272b..218914af84 100644 --- a/lapack-netlib/CBLAS/src/cblas_sdot.c +++ b/lapack-netlib/CBLAS/src/cblas_sdot.c @@ -15,11 +15,11 @@ float cblas_sdot( const int N, const float *X, float dot; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_sdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); return dot; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_sdsdot.c b/lapack-netlib/CBLAS/src/cblas_sdsdot.c index b824849b99..65741aff4d 100644 --- a/lapack-netlib/CBLAS/src/cblas_sdsdot.c +++ b/lapack-netlib/CBLAS/src/cblas_sdsdot.c @@ -15,11 +15,11 @@ float cblas_sdsdot( const int N, const float alpha, const float *X, float dot; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_sdsdot_sub( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, &dot); return dot; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_sgbmv.c b/lapack-netlib/CBLAS/src/cblas_sgbmv.c index 30f9311fae..0557c10b4b 100644 --- a/lapack-netlib/CBLAS/src/cblas_sgbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_sgbmv.c @@ -20,7 +20,7 @@ void cblas_sgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -44,7 +44,7 @@ void cblas_sgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_sgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_sgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + F77_sgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -63,7 +63,7 @@ void cblas_sgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_sgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_sgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + F77_sgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, A ,&F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_sgbmv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_sgemm.c b/lapack-netlib/CBLAS/src/cblas_sgemm.c index c7f7673c47..c4a49a2db2 100644 --- a/lapack-netlib/CBLAS/src/cblas_sgemm.c +++ b/lapack-netlib/CBLAS/src/cblas_sgemm.c @@ -15,12 +15,12 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, const int lda, const float *B, const int ldb, const float beta, float *C, const int ldc) { - char TA, TB; + char TA, TB; #ifdef F77_CHAR F77_CHAR F77_TA, F77_TB; #else - #define F77_TA &TA - #define F77_TB &TB + #define F77_TA &TA + #define F77_TB &TB #endif #ifdef F77_INT @@ -34,7 +34,7 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, #define F77_ldb ldb #define F77_ldc ldc #endif - + extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; @@ -44,9 +44,9 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TA='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { - cblas_xerbla(2, "cblas_sgemm", + cblas_xerbla(2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -56,9 +56,9 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TB='T'; else if ( TransB == CblasConjTrans ) TB='C'; else if ( TransB == CblasNoTrans ) TB='N'; - else + else { - cblas_xerbla(3, "cblas_sgemm", + cblas_xerbla(3, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -77,9 +77,9 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TB='T'; else if ( TransA == CblasConjTrans ) TB='C'; else if ( TransA == CblasNoTrans ) TB='N'; - else + else { - cblas_xerbla(2, "cblas_sgemm", + cblas_xerbla(2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -88,9 +88,9 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TA='T'; else if ( TransB == CblasConjTrans ) TA='C'; else if ( TransB == CblasNoTrans ) TA='N'; - else + else { - cblas_xerbla(2, "cblas_sgemm", + cblas_xerbla(2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -102,7 +102,7 @@ void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, #endif F77_sgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); - } else + } else cblas_xerbla(1, "cblas_sgemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_sgemv.c b/lapack-netlib/CBLAS/src/cblas_sgemv.c index 64a7c1e91f..b2c2969b72 100644 --- a/lapack-netlib/CBLAS/src/cblas_sgemv.c +++ b/lapack-netlib/CBLAS/src/cblas_sgemv.c @@ -4,7 +4,7 @@ * This program is a C interface to sgemv. * Written by Keita Teranishi * 4/6/1998 - * + * */ #include "cblas.h" #include "cblas_f77.h" @@ -18,7 +18,7 @@ void cblas_sgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -40,7 +40,7 @@ void cblas_sgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_sgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_sgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_sgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + F77_sgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -58,7 +58,7 @@ void cblas_sgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(2, "cblas_sgemv", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_sger.c b/lapack-netlib/CBLAS/src/cblas_sger.c index 40f09f9227..4726c861d6 100644 --- a/lapack-netlib/CBLAS/src/cblas_sger.c +++ b/lapack-netlib/CBLAS/src/cblas_sger.c @@ -36,7 +36,7 @@ void cblas_sger(const CBLAS_LAYOUT layout, const int M, const int N, else if (layout == CblasRowMajor) { RowMajorStrg = 1; - F77_sger( &F77_N, &F77_M, &alpha, Y, &F77_incY, X, &F77_incX, A, + F77_sger( &F77_N, &F77_M, &alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_sger", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_snrm2.c b/lapack-netlib/CBLAS/src/cblas_snrm2.c index 18161b4fa7..6b015a0ce6 100644 --- a/lapack-netlib/CBLAS/src/cblas_snrm2.c +++ b/lapack-netlib/CBLAS/src/cblas_snrm2.c @@ -9,12 +9,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -float cblas_snrm2( const int N, const float *X, const int incX) +float cblas_snrm2( const int N, const float *X, const int incX) { float nrm2; #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_srot.c b/lapack-netlib/CBLAS/src/cblas_srot.c index cbd1c8c90a..6619abd943 100644 --- a/lapack-netlib/CBLAS/src/cblas_srot.c +++ b/lapack-netlib/CBLAS/src/cblas_srot.c @@ -8,7 +8,7 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_srot( const int N, float *X, const int incX, float *Y, +void cblas_srot( const int N, float *X, const int incX, float *Y, const int incY, const float c, const float s) { #ifdef F77_INT @@ -19,4 +19,4 @@ void cblas_srot( const int N, float *X, const int incX, float *Y, #define F77_incY incY #endif F77_srot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_srotg.c b/lapack-netlib/CBLAS/src/cblas_srotg.c index f6460048d0..4584a29c9a 100644 --- a/lapack-netlib/CBLAS/src/cblas_srotg.c +++ b/lapack-netlib/CBLAS/src/cblas_srotg.c @@ -10,5 +10,5 @@ #include "cblas_f77.h" void cblas_srotg( float *a, float *b, float *c, float *s) { - F77_srotg(a,b,c,s); + F77_srotg(a,b,c,s); } diff --git a/lapack-netlib/CBLAS/src/cblas_srotm.c b/lapack-netlib/CBLAS/src/cblas_srotm.c index 4967464544..52fae4d9af 100644 --- a/lapack-netlib/CBLAS/src/cblas_srotm.c +++ b/lapack-netlib/CBLAS/src/cblas_srotm.c @@ -8,7 +8,7 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_srotm( const int N, float *X, const int incX, float *Y, +void cblas_srotm( const int N, float *X, const int incX, float *Y, const int incY, const float *P) { #ifdef F77_INT @@ -19,4 +19,4 @@ void cblas_srotm( const int N, float *X, const int incX, float *Y, #define F77_incY incY #endif F77_srotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_srotmg.c b/lapack-netlib/CBLAS/src/cblas_srotmg.c index 04f978b405..1d84054a02 100644 --- a/lapack-netlib/CBLAS/src/cblas_srotmg.c +++ b/lapack-netlib/CBLAS/src/cblas_srotmg.c @@ -8,7 +8,7 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_srotmg( float *d1, float *d2, float *b1, +void cblas_srotmg( float *d1, float *d2, float *b1, const float b2, float *p) { F77_srotmg(d1,d2,b1,&b2,p); diff --git a/lapack-netlib/CBLAS/src/cblas_ssbmv.c b/lapack-netlib/CBLAS/src/cblas_ssbmv.c index 055d94e954..9a035cd920 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ssbmv.c @@ -17,7 +17,7 @@ void cblas_ssbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT @@ -36,10 +36,10 @@ void cblas_ssbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, CBLAS_CallFromC = 1; if (layout == CblasColMajor) { - + if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_ssbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_sscal.c b/lapack-netlib/CBLAS/src/cblas_sscal.c index 1f09abe7a4..6c047766d8 100644 --- a/lapack-netlib/CBLAS/src/cblas_sscal.c +++ b/lapack-netlib/CBLAS/src/cblas_sscal.c @@ -8,12 +8,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_sscal( const int N, const float alpha, float *X, +void cblas_sscal( const int N, const float alpha, float *X, const int incX) { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_sspmv.c b/lapack-netlib/CBLAS/src/cblas_sspmv.c index 93ef069796..3fddd38a42 100644 --- a/lapack-netlib/CBLAS/src/cblas_sspmv.c +++ b/lapack-netlib/CBLAS/src/cblas_sspmv.c @@ -18,7 +18,7 @@ void cblas_sspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; @@ -36,7 +36,7 @@ void cblas_sspmv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -46,7 +46,7 @@ void cblas_sspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_sspmv(F77_UL, &F77_N, &alpha, AP, X, + F77_sspmv(F77_UL, &F77_N, &alpha, AP, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -54,7 +54,7 @@ void cblas_sspmv(const CBLAS_LAYOUT layout, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -64,7 +64,7 @@ void cblas_sspmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_sspmv(F77_UL, &F77_N, &alpha, + F77_sspmv(F77_UL, &F77_N, &alpha, AP, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_sspmv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_sspr.c b/lapack-netlib/CBLAS/src/cblas_sspr.c index 0464dcd6b5..00ac6f99a1 100644 --- a/lapack-netlib/CBLAS/src/cblas_sspr.c +++ b/lapack-netlib/CBLAS/src/cblas_sspr.c @@ -36,7 +36,7 @@ void cblas_sspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -49,12 +49,12 @@ void cblas_sspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -63,8 +63,8 @@ void cblas_sspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + #endif + F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); } else cblas_xerbla(1, "cblas_sspr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_sspr2.c b/lapack-netlib/CBLAS/src/cblas_sspr2.c index 0bf5cc612c..1d9be4f5f5 100644 --- a/lapack-netlib/CBLAS/src/cblas_sspr2.c +++ b/lapack-netlib/CBLAS/src/cblas_sspr2.c @@ -36,7 +36,7 @@ void cblas_sspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -49,12 +49,12 @@ void cblas_sspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -63,8 +63,8 @@ void cblas_sspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + #endif + F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); } else cblas_xerbla(1, "cblas_sspr2", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_sswap.c b/lapack-netlib/CBLAS/src/cblas_sswap.c index b74d8469c3..3759a0f5ca 100644 --- a/lapack-netlib/CBLAS/src/cblas_sswap.c +++ b/lapack-netlib/CBLAS/src/cblas_sswap.c @@ -13,7 +13,7 @@ void cblas_sswap( const int N, float *X, const int incX, float *Y, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_ssymm.c b/lapack-netlib/CBLAS/src/cblas_ssymm.c index 1b0bd966be..d194320984 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssymm.c +++ b/lapack-netlib/CBLAS/src/cblas_ssymm.c @@ -15,12 +15,12 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const float *B, const int ldb, const float beta, float *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,9 +43,9 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { - cblas_xerbla(2, "cblas_ssymm", + cblas_xerbla(2, "cblas_ssymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -54,9 +54,9 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { - cblas_xerbla(3, "cblas_ssymm", + cblas_xerbla(3, "cblas_ssymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -74,9 +74,9 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { - cblas_xerbla(2, "cblas_ssymm", + cblas_xerbla(2, "cblas_ssymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -85,9 +85,9 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { - cblas_xerbla(3, "cblas_ssymm", + cblas_xerbla(3, "cblas_ssymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -105,4 +105,4 @@ void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_ssymv.c b/lapack-netlib/CBLAS/src/cblas_ssymv.c index 84b9eecbdf..c0dc682d87 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssymv.c +++ b/lapack-netlib/CBLAS/src/cblas_ssymv.c @@ -19,7 +19,7 @@ void cblas_ssymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -38,7 +38,7 @@ void cblas_ssymv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_ssymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_ssymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + F77_ssymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -56,7 +56,7 @@ void cblas_ssymv(const CBLAS_LAYOUT layout, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -66,7 +66,7 @@ void cblas_ssymv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_ssymv(F77_UL, &F77_N, &alpha, + F77_ssymv(F77_UL, &F77_N, &alpha, A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); } else cblas_xerbla(1, "cblas_ssymv", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_ssyr.c b/lapack-netlib/CBLAS/src/cblas_ssyr.c index d197fdcdfe..cc66f85c8f 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssyr.c +++ b/lapack-netlib/CBLAS/src/cblas_ssyr.c @@ -34,7 +34,7 @@ void cblas_ssyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -47,12 +47,12 @@ void cblas_ssyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -61,10 +61,10 @@ void cblas_ssyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + #endif + F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_ssyr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_ssyr2.c b/lapack-netlib/CBLAS/src/cblas_ssyr2.c index a0fc86b030..0d314eb8d1 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssyr2.c +++ b/lapack-netlib/CBLAS/src/cblas_ssyr2.c @@ -38,7 +38,7 @@ void cblas_ssyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -49,15 +49,15 @@ void cblas_ssyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -66,9 +66,9 @@ void cblas_ssyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); - #endif - F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, - &F77_lda); + #endif + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); } else cblas_xerbla(1, "cblas_ssyr2", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ssyr2k.c b/lapack-netlib/CBLAS/src/cblas_ssyr2k.c index d4371103df..e5e9575314 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssyr2k.c +++ b/lapack-netlib/CBLAS/src/cblas_ssyr2k.c @@ -15,12 +15,12 @@ void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const float *B, const int ldb, const float beta, float *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -44,9 +44,9 @@ void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { - cblas_xerbla(2, "cblas_ssyr2k", + cblas_xerbla(2, "cblas_ssyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -56,9 +56,9 @@ void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { - cblas_xerbla(3, "cblas_ssyr2k", + cblas_xerbla(3, "cblas_ssyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -77,9 +77,9 @@ void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { - cblas_xerbla(3, "cblas_ssyr2k", + cblas_xerbla(3, "cblas_ssyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -88,9 +88,9 @@ void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { - cblas_xerbla(3, "cblas_ssyr2k", + cblas_xerbla(3, "cblas_ssyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ssyrk.c b/lapack-netlib/CBLAS/src/cblas_ssyrk.c index 02960da80f..81f9799ccf 100644 --- a/lapack-netlib/CBLAS/src/cblas_ssyrk.c +++ b/lapack-netlib/CBLAS/src/cblas_ssyrk.c @@ -14,12 +14,12 @@ void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const float alpha, const float *A, const int lda, const float beta, float *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -42,9 +42,9 @@ void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { - cblas_xerbla(2, "cblas_ssyrk", + cblas_xerbla(2, "cblas_ssyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -54,9 +54,9 @@ void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { - cblas_xerbla(3, "cblas_ssyrk", + cblas_xerbla(3, "cblas_ssyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -75,9 +75,9 @@ void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { - cblas_xerbla(3, "cblas_ssyrk", + cblas_xerbla(3, "cblas_ssyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -86,9 +86,9 @@ void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { - cblas_xerbla(3, "cblas_ssyrk", + cblas_xerbla(3, "cblas_ssyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_stbmv.c b/lapack-netlib/CBLAS/src/cblas_stbmv.c index 80c18a2687..bdaaf515d5 100644 --- a/lapack-netlib/CBLAS/src/cblas_stbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_stbmv.c @@ -1,5 +1,5 @@ /* - * cblas_stbmv.c + * cblas_stbmv.c * This program is a C interface to stbmv. * Written by Keita Teranishi * 3/3/1998 @@ -20,7 +20,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stbmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_stbsv.c b/lapack-netlib/CBLAS/src/cblas_stbsv.c index 5585022138..6317188c2e 100644 --- a/lapack-netlib/CBLAS/src/cblas_stbsv.c +++ b/lapack-netlib/CBLAS/src/cblas_stbsv.c @@ -20,7 +20,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_stpmv.c b/lapack-netlib/CBLAS/src/cblas_stpmv.c index b8dfe896bd..90a0ab7dbd 100644 --- a/lapack-netlib/CBLAS/src/cblas_stpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_stpmv.c @@ -20,7 +20,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -37,7 +37,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -47,7 +47,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -75,7 +75,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -86,7 +86,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -96,7 +96,7 @@ void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_stpsv.c b/lapack-netlib/CBLAS/src/cblas_stpsv.c index 2073a2c746..21b5be6775 100644 --- a/lapack-netlib/CBLAS/src/cblas_stpsv.c +++ b/lapack-netlib/CBLAS/src/cblas_stpsv.c @@ -19,7 +19,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -36,7 +36,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -46,7 +46,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -85,7 +85,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -95,7 +95,7 @@ void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_strmm.c b/lapack-netlib/CBLAS/src/cblas_strmm.c index 6ed4a1282d..e42acfcc8d 100644 --- a/lapack-netlib/CBLAS/src/cblas_strmm.c +++ b/lapack-netlib/CBLAS/src/cblas_strmm.c @@ -15,12 +15,12 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const float alpha, const float *A, const int lda, float *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -43,7 +43,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_strmm","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -63,7 +63,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_strmm","Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_strmm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -94,7 +94,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -104,7 +104,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_strmm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -115,7 +115,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_strmm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -125,7 +125,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_strmm","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -140,7 +140,7 @@ void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, #endif F77_strmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_strmm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_strmv.c b/lapack-netlib/CBLAS/src/cblas_strmv.c index 652659dbbf..90e3cd6f8f 100644 --- a/lapack-netlib/CBLAS/src/cblas_strmv.c +++ b/lapack-netlib/CBLAS/src/cblas_strmv.c @@ -22,7 +22,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -40,7 +40,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -50,7 +50,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -79,7 +79,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -90,7 +90,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -100,7 +100,7 @@ void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_strsm.c b/lapack-netlib/CBLAS/src/cblas_strsm.c index 1f03a58d93..8276a97280 100644 --- a/lapack-netlib/CBLAS/src/cblas_strsm.c +++ b/lapack-netlib/CBLAS/src/cblas_strsm.c @@ -16,12 +16,12 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, float *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -44,7 +44,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -63,7 +63,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -72,7 +72,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -92,7 +92,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -101,7 +101,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -111,7 +111,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -120,7 +120,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -135,7 +135,7 @@ void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, #endif F77_strsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_strsm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_strsv.c b/lapack-netlib/CBLAS/src/cblas_strsv.c index 6a2768b77c..dcf606dd65 100644 --- a/lapack-netlib/CBLAS/src/cblas_strsv.c +++ b/lapack-netlib/CBLAS/src/cblas_strsv.c @@ -21,7 +21,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -39,7 +39,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -49,7 +49,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -78,7 +78,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -89,7 +89,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; - else + else { cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_xerbla.c b/lapack-netlib/CBLAS/src/cblas_xerbla.c index 3a2bfe6e3b..00ca9ccfe5 100644 --- a/lapack-netlib/CBLAS/src/cblas_xerbla.c +++ b/lapack-netlib/CBLAS/src/cblas_xerbla.c @@ -62,7 +62,7 @@ void cblas_xerbla(int info, const char *rout, const char *form, ...) fprintf(stderr, "Parameter %d to routine %s was incorrect\n", info, rout); vfprintf(stderr, form, argptr); va_end(argptr); - if (info && !info) + if (info && !info) F77_xerbla(empty, &info); /* Force link of our F77 error handler */ exit(-1); } diff --git a/lapack-netlib/CBLAS/src/cblas_zaxpy.c b/lapack-netlib/CBLAS/src/cblas_zaxpy.c index f63c4c39bc..a874ad7169 100644 --- a/lapack-netlib/CBLAS/src/cblas_zaxpy.c +++ b/lapack-netlib/CBLAS/src/cblas_zaxpy.c @@ -13,10 +13,10 @@ void cblas_zaxpy( const int N, const void *alpha, const void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY #endif F77_zaxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_zcopy.c b/lapack-netlib/CBLAS/src/cblas_zcopy.c index a16be28e7e..78ee45131f 100644 --- a/lapack-netlib/CBLAS/src/cblas_zcopy.c +++ b/lapack-netlib/CBLAS/src/cblas_zcopy.c @@ -13,7 +13,7 @@ void cblas_zcopy( const int N, const void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_zdotc_sub.c b/lapack-netlib/CBLAS/src/cblas_zdotc_sub.c index 76beaeed4f..d88a5d0327 100644 --- a/lapack-netlib/CBLAS/src/cblas_zdotc_sub.c +++ b/lapack-netlib/CBLAS/src/cblas_zdotc_sub.c @@ -14,7 +14,7 @@ void cblas_zdotc_sub( const int N, const void *X, const int incX, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_zdotu_sub.c b/lapack-netlib/CBLAS/src/cblas_zdotu_sub.c index 48a14bf3d4..1d05c08261 100644 --- a/lapack-netlib/CBLAS/src/cblas_zdotu_sub.c +++ b/lapack-netlib/CBLAS/src/cblas_zdotu_sub.c @@ -14,7 +14,7 @@ void cblas_zdotu_sub( const int N, const void *X, const int incX, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_zdscal.c b/lapack-netlib/CBLAS/src/cblas_zdscal.c index 788365befa..bd65c48a12 100644 --- a/lapack-netlib/CBLAS/src/cblas_zdscal.c +++ b/lapack-netlib/CBLAS/src/cblas_zdscal.c @@ -13,7 +13,7 @@ void cblas_zdscal( const int N, const double alpha, void *X, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_zgbmv.c b/lapack-netlib/CBLAS/src/cblas_zgbmv.c index f4dd485c1f..757ea226e5 100644 --- a/lapack-netlib/CBLAS/src/cblas_zgbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_zgbmv.c @@ -1,7 +1,7 @@ /* * cblas_zgbmv.c * The program is a C interface of zgbmv - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -49,7 +49,7 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_zgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + F77_zgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -112,7 +112,7 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, tincY = -incY; y++; - + if (N > 0) { i = tincY << 1; @@ -127,9 +127,9 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, } else x = (double *) X; - + } - else + else { cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -140,10 +140,10 @@ void cblas_zgbmv(const CBLAS_LAYOUT layout, F77_TA = C2F_CHAR(&TA); #endif if (TransA == CblasConjTrans) - F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); else - F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); if (TransA == CblasConjTrans) { diff --git a/lapack-netlib/CBLAS/src/cblas_zgemm.c b/lapack-netlib/CBLAS/src/cblas_zgemm.c index 7d4c310777..7d2dcd446d 100644 --- a/lapack-netlib/CBLAS/src/cblas_zgemm.c +++ b/lapack-netlib/CBLAS/src/cblas_zgemm.c @@ -15,12 +15,12 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char TA, TB; + char TA, TB; #ifdef F77_CHAR F77_CHAR F77_TA, F77_TB; #else - #define F77_TA &TA - #define F77_TB &TB + #define F77_TA &TA + #define F77_TB &TB #endif #ifdef F77_INT @@ -45,7 +45,7 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TA='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TB='T'; else if ( TransB == CblasConjTrans ) TB='C'; else if ( TransB == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(3, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -77,7 +77,7 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransA == CblasTrans) TB='T'; else if ( TransA == CblasConjTrans ) TB='C'; else if ( TransA == CblasNoTrans ) TB='N'; - else + else { cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -87,7 +87,7 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, if(TransB == CblasTrans) TA='T'; else if ( TransB == CblasConjTrans ) TA='C'; else if ( TransB == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(2, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; @@ -101,7 +101,7 @@ void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, F77_zgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zgemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zgemv.c b/lapack-netlib/CBLAS/src/cblas_zgemv.c index e727380b04..3516b27eff 100644 --- a/lapack-netlib/CBLAS/src/cblas_zgemv.c +++ b/lapack-netlib/CBLAS/src/cblas_zgemv.c @@ -1,7 +1,7 @@ /* * cblas_zgemv.c * The program is a C interface of zgemv - * + * * Keita Teranishi 5/20/98 * */ @@ -19,7 +19,7 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_TA; #else - #define F77_TA &TA + #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -47,7 +47,7 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -57,13 +57,13 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif - F77_zgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + F77_zgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; - + if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) @@ -82,11 +82,11 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, i = incX << 1 ; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do @@ -106,9 +106,9 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, #endif if(incY > 0) - tincY = incY; + tincY = incY; else - tincY = -incY; + tincY = -incY; y++; @@ -120,13 +120,13 @@ void cblas_zgemv(const CBLAS_LAYOUT layout, do { *y = -(*y); y += i; - } while(y != st); + } while(y != st); y -= n; } } else x = (double *) X; } - else + else { cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zgerc.c b/lapack-netlib/CBLAS/src/cblas_zgerc.c index 7a4b4b024d..1a59db91fe 100644 --- a/lapack-netlib/CBLAS/src/cblas_zgerc.c +++ b/lapack-netlib/CBLAS/src/cblas_zgerc.c @@ -1,7 +1,7 @@ /* * cblas_zgerc.c * The program is a C interface to zgerc. - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_zgerc(const CBLAS_LAYOUT layout, const int M, const int N, #define F77_N N #define F77_incX incX #define F77_incY incy - #define F77_lda lda + #define F77_lda lda #endif int n, i, tincy, incy=incY; @@ -33,9 +33,9 @@ void cblas_zgerc(const CBLAS_LAYOUT layout, const int M, const int N, CBLAS_CallFromC = 1; if (layout == CblasColMajor) { - F77_zgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + F77_zgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); - } else if (layout == CblasRowMajor) + } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (N > 0) @@ -48,11 +48,11 @@ void cblas_zgerc(const CBLAS_LAYOUT layout, const int M, const int N, i = incY << 1; tincy = 2; st= y+n; - } else { + } else { i = incY *(-2); tincy = -2; - st = y-2; - y +=(n-2); + st = y-2; + y +=(n-2); } do { @@ -72,7 +72,7 @@ void cblas_zgerc(const CBLAS_LAYOUT layout, const int M, const int N, } else y = (double *) Y; - F77_zgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + F77_zgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, &F77_lda); if(Y!=y) free(y); diff --git a/lapack-netlib/CBLAS/src/cblas_zgeru.c b/lapack-netlib/CBLAS/src/cblas_zgeru.c index 217acc0a3a..4f37ee99b4 100644 --- a/lapack-netlib/CBLAS/src/cblas_zgeru.c +++ b/lapack-netlib/CBLAS/src/cblas_zgeru.c @@ -1,7 +1,7 @@ /* * cblas_zgeru.c * The program is a C interface to zgeru. - * + * * Keita Teranishi 5/20/98 * */ @@ -34,7 +34,7 @@ void cblas_zgeru(const CBLAS_LAYOUT layout, const int M, const int N, else if (layout == CblasRowMajor) { RowMajorStrg = 1; - F77_zgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + F77_zgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_zgeru", "Illegal layout setting, %d\n", layout); diff --git a/lapack-netlib/CBLAS/src/cblas_zhbmv.c b/lapack-netlib/CBLAS/src/cblas_zhbmv.c index 31c978016b..ed97b7ba15 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_zhbmv.c @@ -1,7 +1,7 @@ /* * cblas_zhbmv.c * The program is a C interface to zhbmv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -44,7 +44,7 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_zhbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + F77_zhbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -69,7 +69,7 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(double)); - + tx = x; if( incX > 0 ) { i = incX << 1 ; @@ -98,7 +98,7 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -114,11 +114,11 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, } while(y != st); y -= n; } else - x = (double *) X; + x = (double *) X; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -128,10 +128,10 @@ void cblas_zhbmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_zhbmv(F77_UL, &F77_N, &F77_K, ALPHA, + F77_zhbmv(F77_UL, &F77_N, &F77_K, ALPHA, A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_zhbmv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zhemm.c b/lapack-netlib/CBLAS/src/cblas_zhemm.c index 43ed0ff8c6..fc53036b99 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhemm.c +++ b/lapack-netlib/CBLAS/src/cblas_zhemm.c @@ -15,12 +15,12 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,7 +43,7 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -66,14 +66,14 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_SD = C2F_CHAR(&SD); #endif - F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -83,7 +83,7 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,9 +98,9 @@ void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_zhemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zhemm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_zhemv.c b/lapack-netlib/CBLAS/src/cblas_zhemv.c index 436049e0e4..83c15b19f7 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhemv.c +++ b/lapack-netlib/CBLAS/src/cblas_zhemv.c @@ -1,7 +1,7 @@ /* * cblas_zhemv.c * The program is a C interface to zhemv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; @@ -44,7 +44,7 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_zhemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + F77_zhemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -69,7 +69,7 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(double)); - + tx = x; if( incX > 0 ) { i = incX << 1 ; @@ -98,7 +98,7 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -116,10 +116,10 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, } else x = (double *) X; - + if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -129,10 +129,10 @@ void cblas_zhemv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_zhemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + F77_zhemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_zhemv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zher.c b/lapack-netlib/CBLAS/src/cblas_zher.c index 9ca09b09ca..068d722538 100644 --- a/lapack-netlib/CBLAS/src/cblas_zher.c +++ b/lapack-netlib/CBLAS/src/cblas_zher.c @@ -1,7 +1,7 @@ /* * cblas_zher.c * The program is a C interface to zher. - * + * * Keita Teranishi 5/20/98 * */ @@ -33,13 +33,13 @@ void cblas_zher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_zher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -76,11 +76,11 @@ void cblas_zher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, i = incX << 1 ; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do { @@ -101,9 +101,9 @@ void cblas_zher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else x = (double *) X; F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_zher", "Illegal layout setting, %d\n", layout); - if(X!=x) + if(X!=x) free(x); - + CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/lapack-netlib/CBLAS/src/cblas_zher2.c b/lapack-netlib/CBLAS/src/cblas_zher2.c index d575e9b2c3..debfaf7b31 100644 --- a/lapack-netlib/CBLAS/src/cblas_zher2.c +++ b/lapack-netlib/CBLAS/src/cblas_zher2.c @@ -1,7 +1,7 @@ /* * cblas_zher2.c * The program is a C interface to zher2. - * + * * Keita Teranishi 3/23/98 * */ @@ -29,19 +29,19 @@ void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_incY incy #endif int n, i, j, tincx, tincy, incx=incX, incy=incY; - double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, + double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, *yy=(double *)Y, *tx, *ty, *stx, *sty; extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_zher2(F77_UL, &F77_N, alpha, X, &F77_incX, + F77_zher2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (layout == CblasRowMajor) @@ -60,7 +60,7 @@ void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -74,29 +74,29 @@ void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { n = N << 1; x = malloc(n*sizeof(double)); - y = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); tx = x; ty = y; if( incX > 0 ) { i = incX << 1 ; tincx = 2; stx= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - stx = x-2; - x +=(n-2); + stx = x-2; + x +=(n-2); } - + if( incY > 0 ) { j = incY << 1; tincy = 2; sty= y+n; - } else { + } else { j = incY *(-2); tincy = -2; - sty = y-2; - y +=(n-2); + sty = y-2; + y +=(n-2); } do @@ -127,15 +127,15 @@ void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, incx = 1; incy = 1; #endif - } else + } else { x = (double *) X; y = (double *) Y; } - F77_zher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + F77_zher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, A, &F77_lda); - } - else + } + else { cblas_xerbla(1, "cblas_zher2", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zher2k.c b/lapack-netlib/CBLAS/src/cblas_zher2k.c index 482f868691..ccbd6b086b 100644 --- a/lapack-netlib/CBLAS/src/cblas_zher2k.c +++ b/lapack-netlib/CBLAS/src/cblas_zher2k.c @@ -15,12 +15,12 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *B, const int ldb, const double beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -36,7 +36,7 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; - double ALPHA[2]; + double ALPHA[2]; const double *alp=(double *)alpha; CBLAS_CallFromC = 1; @@ -47,7 +47,7 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -58,7 +58,7 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -75,10 +75,10 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } else if (layout == CblasRowMajor) { RowMajorStrg = 1; - + if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -88,7 +88,7 @@ void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='C'; - else + else { cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zherk.c b/lapack-netlib/CBLAS/src/cblas_zherk.c index 5a4171f211..b0bfa81d34 100644 --- a/lapack-netlib/CBLAS/src/cblas_zherk.c +++ b/lapack-netlib/CBLAS/src/cblas_zherk.c @@ -14,12 +14,12 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const double alpha, const void *A, const int lda, const double beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -41,7 +41,7 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -72,7 +72,7 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -82,7 +82,7 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='C'; - else + else { cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -97,7 +97,7 @@ void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_zherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zherk", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zhpmv.c b/lapack-netlib/CBLAS/src/cblas_zhpmv.c index b113ea09e9..35019d575c 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_zhpmv.c @@ -1,7 +1,7 @@ /* * cblas_zhpmv.c * The program is a C interface of zhpmv - * + * * Keita Teranishi 5/18/98 * */ @@ -19,7 +19,7 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_CHAR F77_UL; #else - #define F77_UL &UL + #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; @@ -37,12 +37,12 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, extern int RowMajorStrg; RowMajorStrg = 0; - CBLAS_CallFromC = 1; + CBLAS_CallFromC = 1; if (layout == CblasColMajor) - { + { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif - F77_zhpmv(F77_UL, &F77_N, alpha, AP, X, + F77_zhpmv(F77_UL, &F77_N, alpha, AP, X, &F77_incX, beta, Y, &F77_incY); } else if (layout == CblasRowMajor) @@ -67,7 +67,7 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, { n = N << 1; x = malloc(n*sizeof(double)); - + tx = x; if( incX > 0 ) { i = incX << 1; @@ -96,7 +96,7 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, #else incx = 1; #endif - + if(incY > 0) tincY = incY; else @@ -117,7 +117,7 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n", Uplo ); CBLAS_CallFromC = 0; @@ -128,17 +128,17 @@ void cblas_zhpmv(const CBLAS_LAYOUT layout, F77_UL = C2F_CHAR(&UL); #endif - F77_zhpmv(F77_UL, &F77_N, ALPHA, + F77_zhpmv(F77_UL, &F77_N, ALPHA, AP, x, &F77_incX, BETA, Y, &F77_incY); } - else + else { cblas_xerbla(1, "cblas_zhpmv","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } - if ( layout == CblasRowMajor ) + if ( layout == CblasRowMajor ) { RowMajorStrg = 1; if(X!=x) diff --git a/lapack-netlib/CBLAS/src/cblas_zhpr.c b/lapack-netlib/CBLAS/src/cblas_zhpr.c index 4037b7bff5..9b00781c5e 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhpr.c +++ b/lapack-netlib/CBLAS/src/cblas_zhpr.c @@ -1,7 +1,7 @@ /* * cblas_zhpr.c * The program is a C interface to zhpr. - * + * * Keita Teranishi 3/23/98 * */ @@ -32,13 +32,13 @@ void cblas_zhpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -56,7 +56,7 @@ void cblas_zhpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -75,11 +75,11 @@ void cblas_zhpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, i = incX << 1; tincx = 2; st= x+n; - } else { + } else { i = incX *(-2); tincx = -2; - st = x-2; - x +=(n-2); + st = x-2; + x +=(n-2); } do { @@ -100,7 +100,7 @@ void cblas_zhpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_zhpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); - } else + } else { cblas_xerbla(1, "cblas_zhpr","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zhpr2.c b/lapack-netlib/CBLAS/src/cblas_zhpr2.c index a4349d3eaa..b7c6ca51ee 100644 --- a/lapack-netlib/CBLAS/src/cblas_zhpr2.c +++ b/lapack-netlib/CBLAS/src/cblas_zhpr2.c @@ -1,7 +1,7 @@ /* * cblas_zhpr2.c * The program is a C interface to zhpr2. - * + * * Keita Teranishi 5/20/98 * */ @@ -10,7 +10,7 @@ #include "cblas.h" #include "cblas_f77.h" void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, - const int N,const void *alpha, const void *X, + const int N,const void *alpha, const void *X, const int incX,const void *Y, const int incY, void *Ap) { @@ -35,13 +35,13 @@ void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; - + CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -73,14 +73,14 @@ void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { n = N << 1; x = malloc(n*sizeof(double)); - y = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); stx = x + n; sty = y + n; if( incX > 0 ) i = incX << 1; else i = incX *(-2); - + if( incY > 0 ) j = incY << 1; else @@ -108,32 +108,32 @@ void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_incX = 1; else F77_incX = -1; - + if(incY > 0 ) F77_incY = 1; else F77_incY = -1; - + #else if(incX > 0 ) incx = 1; else incx = -1; - + if(incY > 0 ) incy = 1; else incy = -1; #endif - } else + } else { x = (double *) X; y = (void *) Y; } F77_zhpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); - } - else + } + else { cblas_xerbla(1, "cblas_zhpr2","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zscal.c b/lapack-netlib/CBLAS/src/cblas_zscal.c index 37b319f38f..622e9ba160 100644 --- a/lapack-netlib/CBLAS/src/cblas_zscal.c +++ b/lapack-netlib/CBLAS/src/cblas_zscal.c @@ -8,12 +8,12 @@ */ #include "cblas.h" #include "cblas_f77.h" -void cblas_zscal( const int N, const void *alpha, void *X, +void cblas_zscal( const int N, const void *alpha, void *X, const int incX) { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; -#else +#else #define F77_N N #define F77_incX incX #endif diff --git a/lapack-netlib/CBLAS/src/cblas_zswap.c b/lapack-netlib/CBLAS/src/cblas_zswap.c index dfde2cbd01..4895acf48b 100644 --- a/lapack-netlib/CBLAS/src/cblas_zswap.c +++ b/lapack-netlib/CBLAS/src/cblas_zswap.c @@ -13,7 +13,7 @@ void cblas_zswap( const int N, void *X, const int incX, void *Y, { #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; -#else +#else #define F77_N N #define F77_incX incX #define F77_incY incY diff --git a/lapack-netlib/CBLAS/src/cblas_zsymm.c b/lapack-netlib/CBLAS/src/cblas_zsymm.c index fcedd04813..16904966f3 100644 --- a/lapack-netlib/CBLAS/src/cblas_zsymm.c +++ b/lapack-netlib/CBLAS/src/cblas_zsymm.c @@ -15,12 +15,12 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char SD, UL; + char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else - #define F77_SD &SD - #define F77_UL &UL + #define F77_SD &SD + #define F77_UL &UL #endif #ifdef F77_INT @@ -43,7 +43,7 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -83,7 +83,7 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,9 +98,9 @@ void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_zsymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zsymm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; -} +} diff --git a/lapack-netlib/CBLAS/src/cblas_zsyr2k.c b/lapack-netlib/CBLAS/src/cblas_zsyr2k.c index b118188408..20bb25b5da 100644 --- a/lapack-netlib/CBLAS/src/cblas_zsyr2k.c +++ b/lapack-netlib/CBLAS/src/cblas_zsyr2k.c @@ -15,12 +15,12 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *B, const int ldb, const void *beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -44,7 +44,7 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -55,7 +55,7 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -86,7 +86,7 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -100,7 +100,7 @@ void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #endif F77_zsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zsyr2k", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_zsyrk.c b/lapack-netlib/CBLAS/src/cblas_zsyrk.c index d247f8dfaf..55e350d846 100644 --- a/lapack-netlib/CBLAS/src/cblas_zsyrk.c +++ b/lapack-netlib/CBLAS/src/cblas_zsyrk.c @@ -14,12 +14,12 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const void *alpha, const void *A, const int lda, const void *beta, void *C, const int ldc) { - char UL, TR; + char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TR, F77_UL; #else - #define F77_TR &TR - #define F77_UL &UL + #define F77_TR &TR + #define F77_UL &UL #endif #ifdef F77_INT @@ -42,7 +42,7 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(2, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -53,7 +53,7 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; - else + else { cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -74,7 +74,7 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -84,7 +84,7 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; - else + else { cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; @@ -99,7 +99,7 @@ void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_zsyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, beta, C, &F77_ldc); - } + } else cblas_xerbla(1, "cblas_zsyrk", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztbmv.c b/lapack-netlib/CBLAS/src/cblas_ztbmv.c index 84928ae2d2..58db9839fb 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztbmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztbmv.c @@ -1,7 +1,7 @@ /* * cblas_ztbmv.c * The program is a C interface to ztbmv. - * + * * Keita Teranishi 5/20/98 * */ @@ -20,7 +20,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0, *x=(double *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztbmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -112,7 +112,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztbsv.c b/lapack-netlib/CBLAS/src/cblas_ztbsv.c index 455cb454ce..2f18cdde3b 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztbsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztbsv.c @@ -1,7 +1,7 @@ /* * cblas_ztbsv.c * The program is a C interface to ztbsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -20,7 +20,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0,*x=(double *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -99,9 +99,9 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); - + x++; st=x+n; @@ -116,7 +116,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -126,7 +126,7 @@ void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztpmv.c b/lapack-netlib/CBLAS/src/cblas_ztpmv.c index db099d7cc4..e11ac69242 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztpmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztpmv.c @@ -1,7 +1,7 @@ /* * cblas_ztpmv.c * The program is a C interface to ztpmv. - * + * * Keita Teranishi 5/20/98 * */ @@ -19,7 +19,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -27,7 +27,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_N N #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0,*x=(double *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -38,7 +38,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -108,7 +108,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -118,7 +118,7 @@ void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztpsv.c b/lapack-netlib/CBLAS/src/cblas_ztpsv.c index a2df95c85f..7c16668dc6 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztpsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztpsv.c @@ -1,7 +1,7 @@ /* * cblas_ztpsv.c * The program is a C interface to ztpsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -19,7 +19,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX; @@ -27,7 +27,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_N N #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0, *x=(double*)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -38,7 +38,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -48,7 +48,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -57,7 +57,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -76,7 +76,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -95,9 +95,9 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); - + x++; st=x+n; @@ -112,7 +112,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztrmm.c b/lapack-netlib/CBLAS/src/cblas_ztrmm.c index 4fd86552e8..573d6b7f5a 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztrmm.c +++ b/lapack-netlib/CBLAS/src/cblas_ztrmm.c @@ -15,12 +15,12 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, const void *alpha, const void *A, const int lda, void *B, const int ldb) { - char UL, TA, SD, DI; + char UL, TA, SD, DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; #else - #define F77_TA &TA - #define F77_UL &UL + #define F77_TA &TA + #define F77_UL &UL #define F77_SD &SD #define F77_DI &DI #endif @@ -43,7 +43,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, { if( Side == CblasRight ) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -52,7 +52,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, } if( Uplo == CblasUpper ) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -63,7 +63,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans ) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -73,7 +73,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -94,7 +94,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, RowMajorStrg = 1; if( Side == CblasRight ) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -104,7 +104,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper ) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -115,7 +115,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans ) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -125,7 +125,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -141,7 +141,7 @@ void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, #endif F77_ztrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_ztrmm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztrmv.c b/lapack-netlib/CBLAS/src/cblas_ztrmv.c index 57fd235722..462e6d8786 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztrmv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztrmv.c @@ -1,7 +1,7 @@ /* * cblas_ztrmv.c * The program is a C interface to ztrmv. - * + * * Keita Teranishi 5/20/98 * */ @@ -21,7 +21,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -30,7 +30,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0,*x=(double *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -41,7 +41,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -51,7 +51,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -60,7 +60,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -80,7 +80,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -112,7 +112,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztrsm.c b/lapack-netlib/CBLAS/src/cblas_ztrsm.c index 85ad879672..89ceb067bb 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztrsm.c +++ b/lapack-netlib/CBLAS/src/cblas_ztrsm.c @@ -44,7 +44,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; - else + else { cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -54,7 +54,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; - else + else { cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -65,7 +65,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -75,7 +75,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -98,7 +98,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; - else + else { cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; @@ -108,7 +108,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; - else + else { cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -119,7 +119,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( TransA == CblasTrans) TA ='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; - else + else { cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -129,7 +129,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, if( Diag == CblasUnit ) DI='U'; else if ( Diag == CblasNonUnit ) DI='N'; - else + else { cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -147,7 +147,7 @@ void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, F77_ztrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); - } + } else cblas_xerbla(1, "cblas_ztrsm", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/lapack-netlib/CBLAS/src/cblas_ztrsv.c b/lapack-netlib/CBLAS/src/cblas_ztrsv.c index e685208cb0..e7d47e812d 100644 --- a/lapack-netlib/CBLAS/src/cblas_ztrsv.c +++ b/lapack-netlib/CBLAS/src/cblas_ztrsv.c @@ -1,7 +1,7 @@ /* * cblas_ztrsv.c * The program is a C interface to ztrsv. - * + * * Keita Teranishi 3/23/98 * */ @@ -20,7 +20,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #else #define F77_TA &TA #define F77_UL &UL - #define F77_DI &DI + #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; @@ -29,7 +29,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #define F77_lda lda #define F77_incX incX #endif - int n, i=0, tincX; + int n, i=0, tincX; double *st=0,*x=(double *)X; extern int CBLAS_CallFromC; extern int RowMajorStrg; @@ -40,7 +40,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; - else + else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -50,7 +50,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; - else + else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -59,7 +59,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; @@ -79,7 +79,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; - else + else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; @@ -98,10 +98,10 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, tincX = incX; else tincX = -incX; - + n = N*2*(tincX); x++; - st=x+n; + st=x+n; i = tincX << 1; do { @@ -112,7 +112,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, x -= n; } } - else + else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; @@ -122,7 +122,7 @@ void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; - else + else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; diff --git a/lapack-netlib/CBLAS/src/dsdotsub.f b/lapack-netlib/CBLAS/src/dsdotsub.f index e7e872c9eb..ef53b881a2 100644 --- a/lapack-netlib/CBLAS/src/dsdotsub.f +++ b/lapack-netlib/CBLAS/src/dsdotsub.f @@ -12,4 +12,4 @@ subroutine dsdotsub(n,x,incx,y,incy,dot) c dot=dsdot(n,x,incx,y,incy) return - end + end diff --git a/lapack-netlib/CBLAS/src/sdotsub.f b/lapack-netlib/CBLAS/src/sdotsub.f index e1af3c97b1..33fa89a9f1 100644 --- a/lapack-netlib/CBLAS/src/sdotsub.f +++ b/lapack-netlib/CBLAS/src/sdotsub.f @@ -12,4 +12,4 @@ subroutine sdotsub(n,x,incx,y,incy,dot) c dot=sdot(n,x,incx,y,incy) return - end + end diff --git a/lapack-netlib/CBLAS/testing/CMakeLists.txt b/lapack-netlib/CBLAS/testing/CMakeLists.txt index c7eb87e224..fe9a51e164 100644 --- a/lapack-netlib/CBLAS/testing/CMakeLists.txt +++ b/lapack-netlib/CBLAS/testing/CMakeLists.txt @@ -4,49 +4,46 @@ ####################################################################### macro(add_cblas_test output input target) - set(TEST_INPUT "${LAPACK_SOURCE_DIR}/cblas/testing/${input}") - set(TEST_OUTPUT "${LAPACK_BINARY_DIR}/cblas/testing/${output}") + set(TEST_INPUT "${CMAKE_CURRENT_SOURCE_DIR}/${input}") + set(TEST_OUTPUT "${CMAKE_CURRENT_BINARY_DIR}/${output}") set(testName "${target}") if(EXISTS "${TEST_INPUT}") add_test(NAME CBLAS-${testName} COMMAND "${CMAKE_COMMAND}" -DTEST=$ -DINPUT=${TEST_INPUT} - -DOUTPUT=${TEST_OUTPUT} + -DOUTPUT=${TEST_OUTPUT} -DINTDIR=${CMAKE_CFG_INTDIR} -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") - else() - string(REPLACE "." "_" input_name ${input}) - add_test(NAME CBLAS-${testName} COMMAND "${CMAKE_COMMAND}" - -DTEST=$ - -DOUTPUT=${TEST_OUTPUT} - -DINTDIR=${CMAKE_CFG_INTDIR} - -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") - endif() -endmacro(add_cblas_test) + else() + add_test(NAME CBLAS-${testName} COMMAND "${CMAKE_COMMAND}" + -DTEST=$ + -DOUTPUT=${TEST_OUTPUT} + -DINTDIR=${CMAKE_CFG_INTDIR} + -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") + endif() +endmacro() # Object files for single real precision -SET( STESTL1O c_sblas1.c) - -SET( STESTL2O c_sblas2.c c_s2chke.c auxiliary.c c_xerbla.c) -SET( STESTL2O c_sblas2.c c_s2chke.c auxiliary.c c_xerbla.c) -SET( STESTL3O c_sblas3.c c_s3chke.c auxiliary.c c_xerbla.c) +set(STESTL1O c_sblas1.c) +set(STESTL2O c_sblas2.c c_s2chke.c auxiliary.c c_xerbla.c) +set(STESTL3O c_sblas3.c c_s3chke.c auxiliary.c c_xerbla.c) # Object files for double real precision -SET( DTESTL1O c_dblas1.c) -SET( DTESTL2O c_dblas2.c c_d2chke.c auxiliary.c c_xerbla.c) -SET( DTESTL3O c_dblas3.c c_d3chke.c auxiliary.c c_xerbla.c) +set(DTESTL1O c_dblas1.c) +set(DTESTL2O c_dblas2.c c_d2chke.c auxiliary.c c_xerbla.c) +set(DTESTL3O c_dblas3.c c_d3chke.c auxiliary.c c_xerbla.c) # Object files for single complex precision -SET( CTESTL1O c_cblat1.f c_cblas1.c) -SET( CTESTL2O c_cblas2.c c_c2chke.c auxiliary.c c_xerbla.c) -SET( CTESTL3O c_cblas3.c c_c3chke.c auxiliary.c c_xerbla.c) +set(CTESTL1O c_cblat1.f c_cblas1.c) +set(CTESTL2O c_cblas2.c c_c2chke.c auxiliary.c c_xerbla.c) +set(CTESTL3O c_cblas3.c c_c3chke.c auxiliary.c c_xerbla.c) # Object files for double complex precision -SET( ZTESTL1O c_zblas1.c) -SET( ZTESTL2O c_zblas2.c c_z2chke.c auxiliary.c c_xerbla.c) -SET( ZTESTL3O c_zblas3.c c_z3chke.c auxiliary.c c_xerbla.c) +set(ZTESTL1O c_zblas1.c) +set(ZTESTL2O c_zblas2.c c_z2chke.c auxiliary.c c_xerbla.c) +set(ZTESTL3O c_zblas3.c c_z3chke.c auxiliary.c c_xerbla.c) @@ -54,61 +51,54 @@ if(BUILD_SINGLE) add_executable(xscblat1 c_sblat1.f ${STESTL1O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xscblat2 c_sblat2.f ${STESTL2O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xscblat3 c_sblat3.f ${STESTL3O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) - + target_link_libraries(xscblat1 cblas ${BLAS_LIBRARIES}) target_link_libraries(xscblat2 cblas ${BLAS_LIBRARIES}) target_link_libraries(xscblat3 cblas ${BLAS_LIBRARIES}) - + add_cblas_test(stest1.out "" xscblat1) add_cblas_test(stest2.out sin2 xscblat2) add_cblas_test(stest3.out sin3 xscblat3) - endif() if(BUILD_DOUBLE) - add_executable(xdcblat1 c_dblat1.f ${DTESTL1O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xdcblat2 c_dblat2.f ${DTESTL2O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xdcblat3 c_dblat3.f ${DTESTL3O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) - + target_link_libraries(xdcblat1 cblas ${BLAS_LIBRARIES}) target_link_libraries(xdcblat2 cblas ${BLAS_LIBRARIES}) target_link_libraries(xdcblat3 cblas ${BLAS_LIBRARIES}) - + add_cblas_test(dtest1.out "" xdcblat1) add_cblas_test(dtest2.out din2 xdcblat2) add_cblas_test(dtest3.out din3 xdcblat3) - endif() if(BUILD_COMPLEX) - add_executable(xccblat1 c_cblat1.f ${CTESTL1O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xccblat2 c_cblat2.f ${CTESTL2O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xccblat3 c_cblat3.f ${CTESTL3O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) - + target_link_libraries(xccblat1 cblas ${BLAS_LIBRARIES}) target_link_libraries(xccblat2 cblas ${BLAS_LIBRARIES}) target_link_libraries(xccblat3 cblas ${BLAS_LIBRARIES}) - + add_cblas_test(ctest1.out "" xccblat1) add_cblas_test(ctest2.out cin2 xccblat2) add_cblas_test(ctest3.out cin3 xccblat3) - endif() if(BUILD_COMPLEX16) - add_executable(xzcblat1 c_zblat1.f ${ZTESTL1O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xzcblat2 c_zblat2.f ${ZTESTL2O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) add_executable(xzcblat3 c_zblat3.f ${ZTESTL3O} ${LAPACK_BINARY_DIR}/include/cblas_test.h) - + target_link_libraries(xzcblat1 cblas ${BLAS_LIBRARIES}) target_link_libraries(xzcblat2 cblas ${BLAS_LIBRARIES}) target_link_libraries(xzcblat3 cblas ${BLAS_LIBRARIES}) - + add_cblas_test(ztest1.out "" xzcblat1) add_cblas_test(ztest2.out zin2 xzcblat2) add_cblas_test(ztest3.out zin3 xzcblat3) - endif() diff --git a/lapack-netlib/CBLAS/testing/Makefile b/lapack-netlib/CBLAS/testing/Makefile index 2ad1ad1d99..a5a078372b 100644 --- a/lapack-netlib/CBLAS/testing/Makefile +++ b/lapack-netlib/CBLAS/testing/Makefile @@ -1,51 +1,43 @@ # -# The Makefile compiles c wrappers and testers for CBLAS. +# The Makefile compiles c wrappers and testers for CBLAS. # include ../../make.inc # Archive files necessary to compile -LIB = $(CBLASLIB) $(BLASLIB) +LIB = $(CBLASLIB) $(BLASLIB) # Object files for single real precision stestl1o = c_sblas1.o - stestl2o = c_sblas2.o c_s2chke.o auxiliary.o c_xerbla.o - stestl3o = c_sblas3.o c_s3chke.o auxiliary.o c_xerbla.o # Object files for double real precision dtestl1o = c_dblas1.o - dtestl2o = c_dblas2.o c_d2chke.o auxiliary.o c_xerbla.o - dtestl3o = c_dblas3.o c_d3chke.o auxiliary.o c_xerbla.o # Object files for single complex precision ctestl1o = c_cblas1.o - ctestl2o = c_cblas2.o c_c2chke.o auxiliary.o c_xerbla.o - ctestl3o = c_cblas3.o c_c3chke.o auxiliary.o c_xerbla.o # Object files for double complex precision -ztestl1o = c_zblas1.o - +ztestl1o = c_zblas1.o ztestl2o = c_zblas2.o c_z2chke.o auxiliary.o c_xerbla.o - ztestl3o = c_zblas3.o c_z3chke.o auxiliary.o c_xerbla.o -all: all1 all2 all3 -all1: stest1 dtest1 ctest1 ztest1 +all: all1 all2 all3 +all1: stest1 dtest1 ctest1 ztest1 all2: stest2 dtest2 ctest2 ztest2 all3: stest3 dtest3 ctest3 ztest3 clean: - rm -f core *.o a.out x* + rm -f core *.o *.out x* cleanobj: - rm -f core *.o a.out + rm -f core *.o a.out cleanexe: - rm -f x* + rm -f x* stest1: xscblat1 dtest1: xdcblat1 @@ -68,46 +60,46 @@ ztest3: xzcblat3 # Single real xscblat1: $(stestl1o) c_sblat1.o - $(LOADER) $(LOADOPTS) -o xscblat1 c_sblat1.o $(stestl1o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_sblat1.o $(stestl1o) $(LIB) xscblat2: $(stestl2o) c_sblat2.o - $(LOADER) $(LOADOPTS) -o xscblat2 c_sblat2.o $(stestl2o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_sblat2.o $(stestl2o) $(LIB) xscblat3: $(stestl3o) c_sblat3.o - $(LOADER) $(LOADOPTS) -o xscblat3 c_sblat3.o $(stestl3o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_sblat3.o $(stestl3o) $(LIB) # Double real xdcblat1: $(dtestl1o) c_dblat1.o - $(LOADER) $(LOADOPTS) -o xdcblat1 c_dblat1.o $(dtestl1o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_dblat1.o $(dtestl1o) $(LIB) xdcblat2: $(dtestl2o) c_dblat2.o - $(LOADER) $(LOADOPTS) -o xdcblat2 c_dblat2.o $(dtestl2o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_dblat2.o $(dtestl2o) $(LIB) xdcblat3: $(dtestl3o) c_dblat3.o - $(LOADER) $(LOADOPTS) -o xdcblat3 c_dblat3.o $(dtestl3o) $(LIB) - + $(LOADER) $(LOADOPTS) -o $@ c_dblat3.o $(dtestl3o) $(LIB) + # Single complex xccblat1: $(ctestl1o) c_cblat1.o - $(LOADER) $(LOADOPTS) -o xccblat1 c_cblat1.o $(ctestl1o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_cblat1.o $(ctestl1o) $(LIB) xccblat2: $(ctestl2o) c_cblat2.o - $(LOADER) $(LOADOPTS) -o xccblat2 c_cblat2.o $(ctestl2o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_cblat2.o $(ctestl2o) $(LIB) xccblat3: $(ctestl3o) c_cblat3.o - $(LOADER) $(LOADOPTS) -o xccblat3 c_cblat3.o $(ctestl3o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_cblat3.o $(ctestl3o) $(LIB) -# Double complex +# Double complex xzcblat1: $(ztestl1o) c_zblat1.o - $(LOADER) $(LOADOPTS) -o xzcblat1 c_zblat1.o $(ztestl1o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_zblat1.o $(ztestl1o) $(LIB) xzcblat2: $(ztestl2o) c_zblat2.o - $(LOADER) $(LOADOPTS) -o xzcblat2 c_zblat2.o $(ztestl2o) $(LIB) + $(LOADER) $(LOADOPTS) -o $@ c_zblat2.o $(ztestl2o) $(LIB) xzcblat3: $(ztestl3o) c_zblat3.o - $(LOADER) $(LOADOPTS) -o xzcblat3 c_zblat3.o $(ztestl3o) $(LIB) - + $(LOADER) $(LOADOPTS) -o $@ c_zblat3.o $(ztestl3o) $(LIB) + # RUN TESTS run: @echo "--> TESTING CBLAS 1 - SINGLE PRECISION <--" @./xscblat1 > stest1.out @echo "--> TESTING CBLAS 1 - DOUBLE PRECISION <--" - @./xdcblat1 > dtest1.out + @./xdcblat1 > dtest1.out @echo "--> TESTING CBLAS 1 - COMPLEX PRECISION <--" - @./xccblat1 > ctest1.out + @./xccblat1 > ctest1.out @echo "--> TESTING CBLAS 1 - DOUBLE COMPLEX PRECISION <--" - @./xzcblat1 > ztest1.out + @./xzcblat1 > ztest1.out @echo "--> TESTING CBLAS 2 - SINGLE PRECISION <--" @./xscblat2 < sin2 > stest2.out @echo "--> TESTING CBLAS 2 - DOUBLE PRECISION <--" @@ -115,7 +107,7 @@ run: @echo "--> TESTING CBLAS 2 - COMPLEX PRECISION <--" @./xccblat2 < cin2 > ctest2.out @echo "--> TESTING CBLAS 2 - DOUBLE COMPLEX PRECISION <--" - @./xzcblat2 < zin2 > ztest2.out + @./xzcblat2 < zin2 > ztest2.out @echo "--> TESTING CBLAS 3 - SINGLE PRECISION <--" @./xscblat3 < sin3 > stest3.out @echo "--> TESTING CBLAS 3 - DOUBLE PRECISION <--" @@ -123,12 +115,12 @@ run: @echo "--> TESTING CBLAS 3 - COMPLEX PRECISION <--" @./xccblat3 < cin3 > ctest3.out @echo "--> TESTING CBLAS 3 - DOUBLE COMPLEX PRECISION <--" - @./xzcblat3 < zin3 > ztest3.out - + @./xzcblat3 < zin3 > ztest3.out + .SUFFIXES: .o .f .c .c.o: - $(CC) -c $(CFLAGS) -I ../include -o $@ $< - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + $(CC) $(CFLAGS) -I../include -c -o $@ $< + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/CBLAS/testing/c_c2chke.c b/lapack-netlib/CBLAS/testing/c_c2chke.c index 18422831a4..28b771980b 100644 --- a/lapack-netlib/CBLAS/testing/c_c2chke.c +++ b/lapack-netlib/CBLAS/testing/c_c2chke.c @@ -26,11 +26,11 @@ void chkxer(void) { void F77_c2chke(char *rout) { char *sf = ( rout ) ; - float A[2] = {0.0,0.0}, - X[2] = {0.0,0.0}, - Y[2] = {0.0,0.0}, + float A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, ALPHA[2] = {0.0,0.0}, - BETA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, RALPHA = 0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -48,588 +48,588 @@ void F77_c2chke(char *rout) { if (strncmp( sf,"cblas_cgemv",11)==0) { cblas_rout = "cblas_cgemv"; cblas_info = 1; - cblas_cgemv(INVALID, CblasNoTrans, 0, 0, + cblas_cgemv(INVALID, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, INVALID, 0, 0, + cblas_cgemv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + cblas_cgemv(CblasColMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, CblasNoTrans, 2, 0, + cblas_cgemv(CblasColMajor, CblasNoTrans, 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, INVALID, 0, 0, + cblas_cgemv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + cblas_cgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 2, + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_cgbmv",11)==0) { cblas_rout = "cblas_cgbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_cgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + cblas_cgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + cblas_cgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = FALSE; - cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + cblas_cgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_chemv",11)==0) { cblas_rout = "cblas_chemv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_chemv(INVALID, CblasUpper, 0, + cblas_chemv(INVALID, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_chemv(CblasColMajor, INVALID, 0, + cblas_chemv(CblasColMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_chemv(CblasColMajor, CblasUpper, INVALID, + cblas_chemv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_chemv(CblasColMajor, CblasUpper, 2, + cblas_chemv(CblasColMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_chemv(CblasColMajor, CblasUpper, 0, + cblas_chemv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_chemv(CblasColMajor, CblasUpper, 0, + cblas_chemv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_chemv(CblasRowMajor, INVALID, 0, + cblas_chemv(CblasRowMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_chemv(CblasRowMajor, CblasUpper, INVALID, + cblas_chemv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_chemv(CblasRowMajor, CblasUpper, 2, + cblas_chemv(CblasRowMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_chemv(CblasRowMajor, CblasUpper, 0, + cblas_chemv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_chemv(CblasRowMajor, CblasUpper, 0, + cblas_chemv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_chbmv",11)==0) { cblas_rout = "cblas_chbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_chbmv(INVALID, CblasUpper, 0, 0, + cblas_chbmv(INVALID, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, INVALID, 0, 0, + cblas_chbmv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, CblasUpper, INVALID, 0, + cblas_chbmv(CblasColMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, CblasUpper, 0, INVALID, + cblas_chbmv(CblasColMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, CblasUpper, 0, 1, + cblas_chbmv(CblasColMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, INVALID, 0, 0, + cblas_chbmv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, CblasUpper, INVALID, 0, + cblas_chbmv(CblasRowMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, CblasUpper, 0, INVALID, + cblas_chbmv(CblasRowMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, CblasUpper, 0, 1, + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_chpmv",11)==0) { cblas_rout = "cblas_chpmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_chpmv(INVALID, CblasUpper, 0, + cblas_chpmv(INVALID, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_chpmv(CblasColMajor, INVALID, 0, + cblas_chpmv(CblasColMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_chpmv(CblasColMajor, CblasUpper, INVALID, + cblas_chpmv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_chpmv(CblasColMajor, CblasUpper, 0, + cblas_chpmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_chpmv(CblasColMajor, CblasUpper, 0, + cblas_chpmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_chpmv(CblasRowMajor, INVALID, 0, + cblas_chpmv(CblasRowMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_chpmv(CblasRowMajor, CblasUpper, INVALID, + cblas_chpmv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_chpmv(CblasRowMajor, CblasUpper, 0, + cblas_chpmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_chpmv(CblasRowMajor, CblasUpper, 0, + cblas_chpmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctrmv",11)==0) { cblas_rout = "cblas_ctrmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctrmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctrmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctrmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, CblasUpper, INVALID, + cblas_ctrmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctrmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctrmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctbmv",11)==0) { cblas_rout = "cblas_ctbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctbmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctbmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctbmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, INVALID, + cblas_ctbmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctbmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctpmv",11)==0) { cblas_rout = "cblas_ctpmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctpmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctpmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctpmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctpmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctpmv(CblasColMajor, CblasUpper, INVALID, + cblas_ctpmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctpmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctpmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctpmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctpmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctrsv",11)==0) { cblas_rout = "cblas_ctrsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctrsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctrsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctrsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, CblasUpper, INVALID, + cblas_ctrsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctrsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctrsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctbsv",11)==0) { cblas_rout = "cblas_ctbsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctbsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctbsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctbsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, INVALID, + cblas_ctbsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctbsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ctpsv",11)==0) { cblas_rout = "cblas_ctpsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ctpsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ctpsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ctpsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ctpsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ctpsv(CblasColMajor, CblasUpper, INVALID, + cblas_ctpsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ctpsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ctpsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ctpsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ctpsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_cgeru",10)==0) { @@ -818,7 +818,7 @@ void F77_c2chke(char *rout) { cblas_info = 6; RowMajorStrg = FALSE; cblas_chpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); chkxer(); - } + } if (cblas_ok == TRUE) printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else diff --git a/lapack-netlib/CBLAS/testing/c_c3chke.c b/lapack-netlib/CBLAS/testing/c_c3chke.c index 67622435a9..1be0c3fd10 100644 --- a/lapack-netlib/CBLAS/testing/c_c3chke.c +++ b/lapack-netlib/CBLAS/testing/c_c3chke.c @@ -30,7 +30,7 @@ void F77_c3chke(char * rout) { B[4] = {0.0,0.0,0.0,0.0}, C[4] = {0.0,0.0,0.0,0.0}, ALPHA[2] = {0.0,0.0}, - BETA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, RALPHA = 0.0, RBETA = 0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -49,15 +49,15 @@ void F77_c3chke(char * rout) { cblas_rout = "cblas_cgemm" ; cblas_info = 1; - cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_cgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + cblas_cgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_cgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + cblas_cgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; @@ -272,7 +272,7 @@ void F77_c3chke(char * rout) { cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - + } else if (strncmp( sf,"cblas_chemm" ,11)==0) { cblas_rout = "cblas_chemm" ; @@ -1696,7 +1696,7 @@ void F77_c3chke(char * rout) { cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - + } if (cblas_ok == 1 ) diff --git a/lapack-netlib/CBLAS/testing/c_cblas1.c b/lapack-netlib/CBLAS/testing/c_cblas1.c index 31b9d47b2e..81a5b843b5 100644 --- a/lapack-netlib/CBLAS/testing/c_cblas1.c +++ b/lapack-netlib/CBLAS/testing/c_cblas1.c @@ -15,21 +15,21 @@ void F77_caxpy(const int *N, const void *alpha, void *X, return; } -void F77_ccopy(const int *N, void *X, const int *incX, +void F77_ccopy(const int *N, void *X, const int *incX, void *Y, const int *incY) { cblas_ccopy(*N, X, *incX, Y, *incY); return; } -void F77_cdotc(const int *N, void *X, const int *incX, +void F77_cdotc(const int *N, void *X, const int *incX, void *Y, const int *incY, void *dotc) { cblas_cdotc_sub(*N, X, *incX, Y, *incY, dotc); return; } -void F77_cdotu(const int *N, void *X, const int *incX, +void F77_cdotu(const int *N, void *X, const int *incX, void *Y, const int *incY,void *dotu) { cblas_cdotu_sub(*N, X, *incX, Y, *incY, dotu); diff --git a/lapack-netlib/CBLAS/testing/c_cblas2.c b/lapack-netlib/CBLAS/testing/c_cblas2.c index 6ba0276994..bb7e644854 100644 --- a/lapack-netlib/CBLAS/testing/c_cblas2.c +++ b/lapack-netlib/CBLAS/testing/c_cblas2.c @@ -8,9 +8,9 @@ #include "cblas.h" #include "cblas_test.h" -void F77_cgemv(int *layout, char *transp, int *m, int *n, +void F77_cgemv(int *layout, char *transp, int *m, int *n, const void *alpha, - CBLAS_TEST_COMPLEX *a, int *lda, const void *x, int *incx, + CBLAS_TEST_COMPLEX *a, int *lda, const void *x, int *incx, const void *beta, void *y, int *incy) { CBLAS_TEST_COMPLEX *A; @@ -38,9 +38,9 @@ void F77_cgemv(int *layout, char *transp, int *m, int *n, *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); } -void F77_cgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, - CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, - CBLAS_TEST_COMPLEX *x, int *incx, +void F77_cgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy) { CBLAS_TEST_COMPLEX *A; @@ -85,8 +85,8 @@ void F77_cgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, *incx, beta, y, *incy ); } -void F77_cgeru(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, - CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, +void F77_cgeru(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, CBLAS_TEST_COMPLEX *a, int *lda){ CBLAS_TEST_COMPLEX *A; @@ -114,8 +114,8 @@ void F77_cgeru(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, cblas_cgeru( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); } -void F77_cgerc(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, - CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, +void F77_cgerc(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, CBLAS_TEST_COMPLEX *a, int *lda) { CBLAS_TEST_COMPLEX *A; int i,j,LDA; @@ -165,7 +165,7 @@ void F77_chemv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, free(A); } else if (*layout == TEST_COL_MJR) - cblas_chemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, + cblas_chemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); else cblas_chemv( UNDEFINED, uplo, *n, alpha, a, *lda, x, *incx, @@ -173,7 +173,7 @@ void F77_chemv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, } void F77_chbmv(int *layout, char *uplow, int *n, int *k, - CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy){ @@ -186,7 +186,7 @@ int i,irow,j,jcol,LDA; if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_chbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, + cblas_chbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, *incx, beta, y, *incy ); else { LDA = *k+2; @@ -237,7 +237,7 @@ int i,irow,j,jcol,LDA; } void F77_chpmv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, - CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, int *incx, + CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy){ CBLAS_TEST_COMPLEX *A, *AP; @@ -247,7 +247,7 @@ void F77_chpmv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, get_uplo_type(uplow,&uplo); if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_chpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, + cblas_chpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, beta, y, *incy); else { LDA = *n; @@ -344,7 +344,7 @@ void F77_ctbmv(int *layout, char *uplow, char *transp, char *diagn, } } } - cblas_ctbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, + cblas_ctbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); free(A); } @@ -371,7 +371,7 @@ void F77_ctbsv(int *layout, char *uplow, char *transp, char *diagn, if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_ctbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, + cblas_ctbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, *incx); else { LDA = *k+2; @@ -408,7 +408,7 @@ void F77_ctbsv(int *layout, char *uplow, char *transp, char *diagn, } } } - cblas_ctbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, + cblas_ctbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); free(A); } @@ -674,7 +674,7 @@ void F77_chpr2(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_chpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, + cblas_chpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, *incy, ap ); else { LDA = *n; @@ -752,7 +752,7 @@ void F77_cher(int *layout, char *uplow, int *n, float *alpha, LDA = *n+1; A=(CBLAS_TEST_COMPLEX*)malloc((*n)*LDA*sizeof( CBLAS_TEST_COMPLEX )); - for( i=0; i<*n; i++ ) + for( i=0; i<*n; i++ ) for( j=0; j<*n; j++ ) { A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; @@ -786,7 +786,7 @@ void F77_cher2(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, LDA = *n+1; A= ( CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); - for( i=0; i<*n; i++ ) + for( i=0; i<*n; i++ ) for( j=0; j<*n; j++ ) { A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; diff --git a/lapack-netlib/CBLAS/testing/c_cblas3.c b/lapack-netlib/CBLAS/testing/c_cblas3.c index 5e4b8b384a..e0e41230f4 100644 --- a/lapack-netlib/CBLAS/testing/c_cblas3.c +++ b/lapack-netlib/CBLAS/testing/c_cblas3.c @@ -11,9 +11,9 @@ #define TEST_ROW_MJR 1 #define UNDEFINED -1 -void F77_cgemm(int *layout, char *transpa, char *transpb, int *m, int *n, +void F77_cgemm(int *layout, char *transpa, char *transpb, int *m, int *n, int *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, - CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) { CBLAS_TEST_COMPLEX *A, *B, *C; @@ -133,7 +133,7 @@ void F77_chemm(int *layout, char *rtlf, char *uplow, int *m, int *n, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_chemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + cblas_chemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -145,10 +145,10 @@ void F77_chemm(int *layout, char *rtlf, char *uplow, int *m, int *n, free(C); } else if (*layout == TEST_COL_MJR) - cblas_chemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_chemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_chemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_chemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_csymm(int *layout, char *rtlf, char *uplow, int *m, int *n, @@ -189,7 +189,7 @@ void F77_csymm(int *layout, char *rtlf, char *uplow, int *m, int *n, for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) C[i*LDC+j]=c[j*(*ldc)+i]; - cblas_csymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + cblas_csymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) @@ -199,15 +199,15 @@ void F77_csymm(int *layout, char *rtlf, char *uplow, int *m, int *n, free(C); } else if (*layout == TEST_COL_MJR) - cblas_csymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_csymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_csymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_csymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_cherk(int *layout, char *uplow, char *transp, int *n, int *k, - float *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + float *alpha, CBLAS_TEST_COMPLEX *a, int *lda, float *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) { int i,j,LDA,LDC; @@ -244,7 +244,7 @@ void F77_cherk(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_cherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + cblas_cherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -255,15 +255,15 @@ void F77_cherk(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_cherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + cblas_cherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, c, *ldc ); else - cblas_cherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + cblas_cherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, c, *ldc ); } void F77_csyrk(int *layout, char *uplow, char *transp, int *n, int *k, - CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) { int i,j,LDA,LDC; @@ -300,7 +300,7 @@ void F77_csyrk(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_csyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, + cblas_csyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -311,10 +311,10 @@ void F77_csyrk(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_csyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, + cblas_csyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, c, *ldc ); else - cblas_csyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, + cblas_csyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, c, *ldc ); } void F77_cher2k(int *layout, char *uplow, char *transp, int *n, int *k, @@ -363,7 +363,7 @@ void F77_cher2k(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_cher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + cblas_cher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, B, LDB, *beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -375,10 +375,10 @@ void F77_cher2k(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_cher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + cblas_cher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, *beta, c, *ldc ); else - cblas_cher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + cblas_cher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } void F77_csyr2k(int *layout, char *uplow, char *transp, int *n, int *k, @@ -427,7 +427,7 @@ void F77_csyr2k(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_csyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + cblas_csyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -439,14 +439,14 @@ void F77_csyr2k(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_csyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + cblas_csyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_csyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + cblas_csyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_ctrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, - int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, + int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) { int i,j,LDA,LDB; CBLAS_TEST_COMPLEX *A, *B; @@ -486,7 +486,7 @@ void F77_ctrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, B[i*LDB+j].real=b[j*(*ldb)+i].real; B[i*LDB+j].imag=b[j*(*ldb)+i].imag; } - cblas_ctrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, A, LDA, B, LDB ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -497,15 +497,15 @@ void F77_ctrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, free(B); } else if (*layout == TEST_COL_MJR) - cblas_ctrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); else - cblas_ctrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); } void F77_ctrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, - int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, + int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) { int i,j,LDA,LDB; CBLAS_TEST_COMPLEX *A, *B; @@ -545,7 +545,7 @@ void F77_ctrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, B[i*LDB+j].real=b[j*(*ldb)+i].real; B[i*LDB+j].imag=b[j*(*ldb)+i].imag; } - cblas_ctrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, A, LDA, B, LDB ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -556,9 +556,9 @@ void F77_ctrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, free(B); } else if (*layout == TEST_COL_MJR) - cblas_ctrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); else - cblas_ctrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + cblas_ctrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); } diff --git a/lapack-netlib/CBLAS/testing/c_cblat2.f b/lapack-netlib/CBLAS/testing/c_cblat2.f index 545ba4b9fc..d934ebb49d 100644 --- a/lapack-netlib/CBLAS/testing/c_cblat2.f +++ b/lapack-netlib/CBLAS/testing/c_cblat2.f @@ -348,13 +348,13 @@ PROGRAM CBLAT2 160 IF (CORDER) THEN CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, $ 0 ) END IF IF (RORDER) THEN CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, $ 1 ) END IF GO TO 200 @@ -581,7 +581,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, CTRANS = ' CblasNoTrans' ELSE IF (TRANS.EQ.'T')THEN CTRANS = ' CblasTrans' - ELSE + ELSE CTRANS = 'CblasConjTrans' END IF TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' @@ -684,7 +684,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * See what data changed inside subroutines. * -* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN +* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN ISAME( 1 ) = TRANS.EQ.TRANSS ISAME( 2 ) = MS.EQ.M ISAME( 3 ) = NS.EQ.N @@ -925,7 +925,7 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, UPLO = ICH( IC: IC ) IF (UPLO.EQ.'U')THEN CUPLO = ' CblasUpper' - ELSE + ELSE CUPLO = ' CblasLower' END IF * @@ -1284,7 +1284,7 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, UPLO = ICHU( ICU: ICU ) IF (UPLO.EQ.'U')THEN CUPLO = ' CblasUpper' - ELSE + ELSE CUPLO = ' CblasLower' END IF * @@ -1294,7 +1294,7 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, CTRANS = ' CblasNoTrans' ELSE IF (TRANS.EQ.'T')THEN CTRANS = ' CblasTrans' - ELSE + ELSE CTRANS = 'CblasConjTrans' END IF * diff --git a/lapack-netlib/CBLAS/testing/c_cblat3.f b/lapack-netlib/CBLAS/testing/c_cblat3.f index b03d47916c..94144b8750 100644 --- a/lapack-netlib/CBLAS/testing/c_cblat3.f +++ b/lapack-netlib/CBLAS/testing/c_cblat3.f @@ -424,7 +424,7 @@ PROGRAM CBLAT3 END SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, $ IORDER ) * * Tests CGEMM. @@ -600,7 +600,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CCGEMM( IORDER, TRANSA, TRANSB, M, N, - $ K, ALPHA, AA, LDA, BB, LDB, + $ K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. @@ -688,7 +688,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) * 130 CONTINUE @@ -724,24 +724,24 @@ SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, CHARACTER*1 TRANSA, TRANSB CHARACTER*12 SNAME CHARACTER*14 CRC, CTA,CTB - + IF (TRANSA.EQ.'N')THEN CTA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CTA = ' CblasTrans' - ELSE + ELSE CTA = 'CblasConjTrans' END IF IF (TRANSB.EQ.'N')THEN CTB = ' CblasNoTrans' ELSE IF (TRANSB.EQ.'T')THEN CTB = ' CblasTrans' - ELSE + ELSE CTB = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB @@ -754,7 +754,7 @@ SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, * SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, $ IORDER ) * * Tests CHEMM and CSYMM. @@ -910,9 +910,9 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * Call the subroutine. * IF( TRACE ) - $ CALL CPRCN2(NTRA, NC, SNAME, IORDER, - $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, - $ BETA, LDC) + $ CALL CPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) IF( REWI ) $ REWIND NTRA IF( CONJ )THEN @@ -1015,7 +1015,7 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME CALL CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC) + $ LDB, BETA, LDC) * 120 CONTINUE RETURN @@ -1050,20 +1050,20 @@ SUBROUTINE CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, CHARACTER*1 SIDE, UPLO CHARACTER*12 SNAME CHARACTER*14 CRC, CS,CU - + IF (SIDE.EQ.'L')THEN CS = ' CblasLeft' - ELSE + ELSE CS = ' CblasRight' END IF IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU @@ -1365,8 +1365,9 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - CALL CPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, - $ M, N, ALPHA, LDA, LDB) + IF( TRACE ) + $ CALL CPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) * 160 CONTINUE RETURN @@ -1401,22 +1402,22 @@ SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, CHARACTER*1 SIDE, UPLO, TRANSA, DIAG CHARACTER*12 SNAME CHARACTER*14 CRC, CS, CU, CA, CD - + IF (SIDE.EQ.'L')THEN CS = ' CblasLeft' - ELSE + ELSE CS = ' CblasRight' END IF IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (DIAG.EQ.'N')THEN @@ -1426,7 +1427,7 @@ SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU @@ -1787,22 +1788,22 @@ SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA @@ -1821,29 +1822,29 @@ SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) - 9994 FORMAT( 10X, 2( I3, ',' ), + 9994 FORMAT( 10X, 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) END * @@ -2040,7 +2041,7 @@ SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CCSYR2K( IORDER, UPLO, TRANS, N, K, - $ ALPHA, AA, LDA, BB, LDB, BETA, + $ ALPHA, AA, LDA, BB, LDB, BETA, $ CC, LDC ) END IF * @@ -2240,22 +2241,22 @@ SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA @@ -2275,22 +2276,22 @@ SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA diff --git a/lapack-netlib/CBLAS/testing/c_d2chke.c b/lapack-netlib/CBLAS/testing/c_d2chke.c index 46a242fc15..d989811d28 100644 --- a/lapack-netlib/CBLAS/testing/c_d2chke.c +++ b/lapack-netlib/CBLAS/testing/c_d2chke.c @@ -26,9 +26,9 @@ void chkxer(void) { void F77_d2chke(char *rout) { char *sf = ( rout ) ; - double A[2] = {0.0,0.0}, - X[2] = {0.0,0.0}, - Y[2] = {0.0,0.0}, + double A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, ALPHA=0.0, BETA=0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -46,588 +46,588 @@ void F77_d2chke(char *rout) { if (strncmp( sf,"cblas_dgemv",11)==0) { cblas_rout = "cblas_dgemv"; cblas_info = 1; - cblas_dgemv(INVALID, CblasNoTrans, 0, 0, + cblas_dgemv(INVALID, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, INVALID, 0, 0, + cblas_dgemv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + cblas_dgemv(CblasColMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, CblasNoTrans, 2, 0, + cblas_dgemv(CblasColMajor, CblasNoTrans, 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, INVALID, 0, 0, + cblas_dgemv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + cblas_dgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 2, + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dgbmv",11)==0) { cblas_rout = "cblas_dgbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + cblas_dgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + cblas_dgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = FALSE; - cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + cblas_dgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dsymv",11)==0) { cblas_rout = "cblas_dsymv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dsymv(INVALID, CblasUpper, 0, + cblas_dsymv(INVALID, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dsymv(CblasColMajor, INVALID, 0, + cblas_dsymv(CblasColMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dsymv(CblasColMajor, CblasUpper, INVALID, + cblas_dsymv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_dsymv(CblasColMajor, CblasUpper, 2, + cblas_dsymv(CblasColMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_dsymv(CblasColMajor, CblasUpper, 0, + cblas_dsymv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_dsymv(CblasColMajor, CblasUpper, 0, + cblas_dsymv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dsymv(CblasRowMajor, INVALID, 0, + cblas_dsymv(CblasRowMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dsymv(CblasRowMajor, CblasUpper, INVALID, + cblas_dsymv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_dsymv(CblasRowMajor, CblasUpper, 2, + cblas_dsymv(CblasRowMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_dsymv(CblasRowMajor, CblasUpper, 0, + cblas_dsymv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_dsymv(CblasRowMajor, CblasUpper, 0, + cblas_dsymv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dsbmv",11)==0) { cblas_rout = "cblas_dsbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dsbmv(INVALID, CblasUpper, 0, 0, + cblas_dsbmv(INVALID, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, INVALID, 0, 0, + cblas_dsbmv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, CblasUpper, INVALID, 0, + cblas_dsbmv(CblasColMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, CblasUpper, 0, INVALID, + cblas_dsbmv(CblasColMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, CblasUpper, 0, 1, + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, INVALID, 0, 0, + cblas_dsbmv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, CblasUpper, INVALID, 0, + cblas_dsbmv(CblasRowMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, CblasUpper, 0, INVALID, + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 1, + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dspmv",11)==0) { cblas_rout = "cblas_dspmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dspmv(INVALID, CblasUpper, 0, + cblas_dspmv(INVALID, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dspmv(CblasColMajor, INVALID, 0, + cblas_dspmv(CblasColMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dspmv(CblasColMajor, CblasUpper, INVALID, + cblas_dspmv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_dspmv(CblasColMajor, CblasUpper, 0, + cblas_dspmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_dspmv(CblasColMajor, CblasUpper, 0, + cblas_dspmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dspmv(CblasRowMajor, INVALID, 0, + cblas_dspmv(CblasRowMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dspmv(CblasRowMajor, CblasUpper, INVALID, + cblas_dspmv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_dspmv(CblasRowMajor, CblasUpper, 0, + cblas_dspmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_dspmv(CblasRowMajor, CblasUpper, 0, + cblas_dspmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtrmv",11)==0) { cblas_rout = "cblas_dtrmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtrmv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtrmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtrmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, CblasUpper, INVALID, + cblas_dtrmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtrmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtrmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtbmv",11)==0) { cblas_rout = "cblas_dtbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtbmv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtbmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtbmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, INVALID, + cblas_dtbmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtbmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtpmv",11)==0) { cblas_rout = "cblas_dtpmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtpmv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtpmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtpmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtpmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtpmv(CblasColMajor, CblasUpper, INVALID, + cblas_dtpmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtpmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtpmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtpmv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtpmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtrsv",11)==0) { cblas_rout = "cblas_dtrsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtrsv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtrsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtrsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, CblasUpper, INVALID, + cblas_dtrsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtrsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtrsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtbsv",11)==0) { cblas_rout = "cblas_dtbsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtbsv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtbsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtbsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, INVALID, + cblas_dtbsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtbsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dtpsv",11)==0) { cblas_rout = "cblas_dtpsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_dtpsv(INVALID, CblasUpper, CblasNoTrans, + cblas_dtpsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_dtpsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_dtpsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_dtpsv(CblasColMajor, CblasUpper, INVALID, + cblas_dtpsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_dtpsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_dtpsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_dtpsv(CblasRowMajor, CblasUpper, INVALID, + cblas_dtpsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_dger",10)==0) { @@ -781,7 +781,7 @@ void F77_d2chke(char *rout) { cblas_info = 6; RowMajorStrg = FALSE; cblas_dspr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A ); chkxer(); - } + } if (cblas_ok == TRUE) printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else diff --git a/lapack-netlib/CBLAS/testing/c_d3chke.c b/lapack-netlib/CBLAS/testing/c_d3chke.c index fae38d485f..e41901e79c 100644 --- a/lapack-netlib/CBLAS/testing/c_d3chke.c +++ b/lapack-netlib/CBLAS/testing/c_d3chke.c @@ -26,9 +26,9 @@ void chkxer(void) { void F77_d3chke(char *rout) { char *sf = ( rout ) ; - double A[2] = {0.0,0.0}, - B[2] = {0.0,0.0}, - C[2] = {0.0,0.0}, + double A[2] = {0.0,0.0}, + B[2] = {0.0,0.0}, + C[2] = {0.0,0.0}, ALPHA=0.0, BETA=0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -39,7 +39,7 @@ void F77_d3chke(char *rout) { cblas_xerbla(cblas_info,cblas_rout,""); F77_xerbla(cblas_rout,&cblas_info); } - + cblas_ok = TRUE ; cblas_lerr = PASSED ; @@ -47,15 +47,15 @@ void F77_d3chke(char *rout) { cblas_rout = "cblas_dgemm" ; cblas_info = 1; - cblas_dgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + cblas_dgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_dgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + cblas_dgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_dgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + cblas_dgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; diff --git a/lapack-netlib/CBLAS/testing/c_dblas1.c b/lapack-netlib/CBLAS/testing/c_dblas1.c index 616c498954..deb7851257 100644 --- a/lapack-netlib/CBLAS/testing/c_dblas1.c +++ b/lapack-netlib/CBLAS/testing/c_dblas1.c @@ -20,7 +20,7 @@ void F77_daxpy(const int *N, const double *alpha, const double *X, return; } -void F77_dcopy(const int *N, double *X, const int *incX, +void F77_dcopy(const int *N, double *X, const int *incX, double *Y, const int *incY) { cblas_dcopy(*N, X, *incX, Y, *incY); diff --git a/lapack-netlib/CBLAS/testing/c_dblas2.c b/lapack-netlib/CBLAS/testing/c_dblas2.c index eeaf88e6b0..835ba19f34 100644 --- a/lapack-netlib/CBLAS/testing/c_dblas2.c +++ b/lapack-netlib/CBLAS/testing/c_dblas2.c @@ -8,8 +8,8 @@ #include "cblas.h" #include "cblas_test.h" -void F77_dgemv(int *layout, char *transp, int *m, int *n, double *alpha, - double *a, int *lda, double *x, int *incx, double *beta, +void F77_dgemv(int *layout, char *transp, int *m, int *n, double *alpha, + double *a, int *lda, double *x, int *incx, double *beta, double *y, int *incy ) { double *A; @@ -23,7 +23,7 @@ void F77_dgemv(int *layout, char *transp, int *m, int *n, double *alpha, for( i=0; i<*m; i++ ) for( j=0; j<*n; j++ ) A[ LDA*i+j ]=a[ (*lda)*j+i ]; - cblas_dgemv( CblasRowMajor, trans, + cblas_dgemv( CblasRowMajor, trans, *m, *n, *alpha, A, LDA, x, *incx, *beta, y, *incy ); free(A); } @@ -68,9 +68,9 @@ void F77_dtrmv(int *layout, char *uplow, char *transp, char *diagn, CBLAS_UPLO uplo; CBLAS_DIAG diag; - get_transpose_type(transp,&trans); - get_uplo_type(uplow,&uplo); - get_diag_type(diagn,&diag); + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); if (*layout == TEST_ROW_MJR) { LDA = *n+1; @@ -88,7 +88,7 @@ void F77_dtrmv(int *layout, char *uplow, char *transp, char *diagn, } } -void F77_dtrsv(int *layout, char *uplow, char *transp, char *diagn, +void F77_dtrsv(int *layout, char *uplow, char *transp, char *diagn, int *n, double *a, int *lda, double *x, int *incx ) { double *A; int i,j,LDA; @@ -112,7 +112,7 @@ void F77_dtrsv(int *layout, char *uplow, char *transp, char *diagn, else cblas_dtrsv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx ); } -void F77_dsymv(int *layout, char *uplow, int *n, double *alpha, double *a, +void F77_dsymv(int *layout, char *uplow, int *n, double *alpha, double *a, int *lda, double *x, int *incx, double *beta, double *y, int *incy) { double *A; @@ -136,7 +136,7 @@ void F77_dsymv(int *layout, char *uplow, int *n, double *alpha, double *a, *beta, y, *incy ); } -void F77_dsyr(int *layout, char *uplow, int *n, double *alpha, double *x, +void F77_dsyr(int *layout, char *uplow, int *n, double *alpha, double *x, int *incx, double *a, int *lda) { double *A; int i,j,LDA; @@ -160,7 +160,7 @@ void F77_dsyr(int *layout, char *uplow, int *n, double *alpha, double *x, cblas_dsyr(CblasColMajor, uplo, *n, *alpha, x, *incx, a, *lda); } -void F77_dsyr2(int *layout, char *uplow, int *n, double *alpha, double *x, +void F77_dsyr2(int *layout, char *uplow, int *n, double *alpha, double *x, int *incx, double *y, int *incy, double *a, int *lda) { double *A; int i,j,LDA; @@ -185,7 +185,7 @@ void F77_dsyr2(int *layout, char *uplow, int *n, double *alpha, double *x, } void F77_dgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, - double *alpha, double *a, int *lda, double *x, int *incx, + double *alpha, double *a, int *lda, double *x, int *incx, double *beta, double *y, int *incy ) { double *A; @@ -213,7 +213,7 @@ void F77_dgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, for( j=jcol; j<(*n+*kl); j++ ) A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; } - cblas_dgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, *alpha, + cblas_dgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, *alpha, A, LDA, x, *incx, *beta, y, *incy ); free(A); } @@ -230,9 +230,9 @@ void F77_dtbmv(int *layout, char *uplow, char *transp, char *diagn, CBLAS_UPLO uplo; CBLAS_DIAG diag; - get_transpose_type(transp,&trans); - get_uplo_type(uplow,&uplo); - get_diag_type(diagn,&diag); + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); if (*layout == TEST_ROW_MJR) { LDA = *k+1; @@ -276,9 +276,9 @@ void F77_dtbsv(int *layout, char *uplow, char *transp, char *diagn, CBLAS_UPLO uplo; CBLAS_DIAG diag; - get_transpose_type(transp,&trans); - get_uplo_type(uplow,&uplo); - get_diag_type(diagn,&diag); + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); if (*layout == TEST_ROW_MJR) { LDA = *k+1; @@ -315,7 +315,7 @@ void F77_dtbsv(int *layout, char *uplow, char *transp, char *diagn, } void F77_dsbmv(int *layout, char *uplow, int *n, int *k, double *alpha, - double *a, int *lda, double *x, int *incx, double *beta, + double *a, int *lda, double *x, int *incx, double *beta, double *y, int *incy) { double *A; int i,j,irow,jcol,LDA; @@ -387,13 +387,13 @@ void F77_dspmv(int *layout, char *uplow, int *n, double *alpha, double *ap, for( j=0; j= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; - + /* We increment *info by 1 since the CBLAS interface adds one more * argument to all level 2 and 3 routines. */ diff --git a/lapack-netlib/CBLAS/testing/c_z2chke.c b/lapack-netlib/CBLAS/testing/c_z2chke.c index 09aaa68a0a..d51c7c2674 100644 --- a/lapack-netlib/CBLAS/testing/c_z2chke.c +++ b/lapack-netlib/CBLAS/testing/c_z2chke.c @@ -26,11 +26,11 @@ void chkxer(void) { void F77_z2chke(char *rout) { char *sf = ( rout ) ; - double A[2] = {0.0,0.0}, - X[2] = {0.0,0.0}, - Y[2] = {0.0,0.0}, + double A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, ALPHA[2] = {0.0,0.0}, - BETA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, RALPHA = 0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -48,588 +48,588 @@ void F77_z2chke(char *rout) { if (strncmp( sf,"cblas_zgemv",11)==0) { cblas_rout = "cblas_zgemv"; cblas_info = 1; - cblas_zgemv(INVALID, CblasNoTrans, 0, 0, + cblas_zgemv(INVALID, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, INVALID, 0, 0, + cblas_zgemv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + cblas_zgemv(CblasColMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, CblasNoTrans, 2, 0, + cblas_zgemv(CblasColMajor, CblasNoTrans, 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, INVALID, 0, 0, + cblas_zgemv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + cblas_zgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 2, + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_zgbmv",11)==0) { cblas_rout = "cblas_zgbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_zgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + cblas_zgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + cblas_zgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = FALSE; - cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + cblas_zgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_zhemv",11)==0) { cblas_rout = "cblas_zhemv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_zhemv(INVALID, CblasUpper, 0, + cblas_zhemv(INVALID, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_zhemv(CblasColMajor, INVALID, 0, + cblas_zhemv(CblasColMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_zhemv(CblasColMajor, CblasUpper, INVALID, + cblas_zhemv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_zhemv(CblasColMajor, CblasUpper, 2, + cblas_zhemv(CblasColMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_zhemv(CblasColMajor, CblasUpper, 0, + cblas_zhemv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_zhemv(CblasColMajor, CblasUpper, 0, + cblas_zhemv(CblasColMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_zhemv(CblasRowMajor, INVALID, 0, + cblas_zhemv(CblasRowMajor, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_zhemv(CblasRowMajor, CblasUpper, INVALID, + cblas_zhemv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_zhemv(CblasRowMajor, CblasUpper, 2, + cblas_zhemv(CblasRowMajor, CblasUpper, 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_zhemv(CblasRowMajor, CblasUpper, 0, + cblas_zhemv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_zhemv(CblasRowMajor, CblasUpper, 0, + cblas_zhemv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_zhbmv",11)==0) { cblas_rout = "cblas_zhbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_zhbmv(INVALID, CblasUpper, 0, 0, + cblas_zhbmv(INVALID, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, INVALID, 0, 0, + cblas_zhbmv(CblasColMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, CblasUpper, INVALID, 0, + cblas_zhbmv(CblasColMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, CblasUpper, 0, INVALID, + cblas_zhbmv(CblasColMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, CblasUpper, 0, 1, + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = FALSE; - cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, INVALID, 0, 0, + cblas_zhbmv(CblasRowMajor, INVALID, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, CblasUpper, INVALID, 0, + cblas_zhbmv(CblasRowMajor, CblasUpper, INVALID, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, CblasUpper, 0, INVALID, + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, INVALID, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 1, + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 12; RowMajorStrg = TRUE; - cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_zhpmv",11)==0) { cblas_rout = "cblas_zhpmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_zhpmv(INVALID, CblasUpper, 0, + cblas_zhpmv(INVALID, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_zhpmv(CblasColMajor, INVALID, 0, + cblas_zhpmv(CblasColMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_zhpmv(CblasColMajor, CblasUpper, INVALID, + cblas_zhpmv(CblasColMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_zhpmv(CblasColMajor, CblasUpper, 0, + cblas_zhpmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_zhpmv(CblasColMajor, CblasUpper, 0, + cblas_zhpmv(CblasColMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_zhpmv(CblasRowMajor, INVALID, 0, + cblas_zhpmv(CblasRowMajor, INVALID, 0, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_zhpmv(CblasRowMajor, CblasUpper, INVALID, + cblas_zhpmv(CblasRowMajor, CblasUpper, INVALID, ALPHA, A, X, 1, BETA, Y, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_zhpmv(CblasRowMajor, CblasUpper, 0, + cblas_zhpmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 0, BETA, Y, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_zhpmv(CblasRowMajor, CblasUpper, 0, + cblas_zhpmv(CblasRowMajor, CblasUpper, 0, ALPHA, A, X, 1, BETA, Y, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztrmv",11)==0) { cblas_rout = "cblas_ztrmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztrmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztrmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztrmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, CblasUpper, INVALID, + cblas_ztrmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztrmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztrmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztbmv",11)==0) { cblas_rout = "cblas_ztbmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztbmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztbmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztbmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, INVALID, + cblas_ztbmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztbmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztpmv",11)==0) { cblas_rout = "cblas_ztpmv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztpmv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztpmv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztpmv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztpmv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztpmv(CblasColMajor, CblasUpper, INVALID, + cblas_ztpmv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztpmv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztpmv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztpmv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztpmv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztrsv",11)==0) { cblas_rout = "cblas_ztrsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztrsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztrsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztrsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, CblasUpper, INVALID, + cblas_ztrsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztrsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztrsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 7; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 2, A, 1, X, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztbsv",11)==0) { cblas_rout = "cblas_ztbsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztbsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztbsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztbsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, INVALID, + cblas_ztbsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = FALSE; - cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztbsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, A, 1, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, 0, A, 1, X, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, INVALID, A, 1, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 1, A, 1, X, 1 ); chkxer(); cblas_info = 10; RowMajorStrg = TRUE; - cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, 0, A, 1, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_ztpsv",11)==0) { cblas_rout = "cblas_ztpsv"; cblas_info = 1; RowMajorStrg = FALSE; - cblas_ztpsv(INVALID, CblasUpper, CblasNoTrans, + cblas_ztpsv(INVALID, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 2; RowMajorStrg = FALSE; - cblas_ztpsv(CblasColMajor, INVALID, CblasNoTrans, + cblas_ztpsv(CblasColMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = FALSE; - cblas_ztpsv(CblasColMajor, CblasUpper, INVALID, + cblas_ztpsv(CblasColMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = FALSE; - cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); cblas_info = 2; RowMajorStrg = TRUE; - cblas_ztpsv(CblasRowMajor, INVALID, CblasNoTrans, + cblas_ztpsv(CblasRowMajor, INVALID, CblasNoTrans, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 3; RowMajorStrg = TRUE; - cblas_ztpsv(CblasRowMajor, CblasUpper, INVALID, + cblas_ztpsv(CblasRowMajor, CblasUpper, INVALID, CblasNonUnit, 0, A, X, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = TRUE; - cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, INVALID, 0, A, X, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, INVALID, A, X, 1 ); chkxer(); cblas_info = 8; RowMajorStrg = TRUE; - cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, CblasNonUnit, 0, A, X, 0 ); chkxer(); } else if (strncmp( sf,"cblas_zgeru",10)==0) { @@ -818,7 +818,7 @@ void F77_z2chke(char *rout) { cblas_info = 6; RowMajorStrg = FALSE; cblas_zhpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); chkxer(); - } + } if (cblas_ok == TRUE) printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else diff --git a/lapack-netlib/CBLAS/testing/c_z3chke.c b/lapack-netlib/CBLAS/testing/c_z3chke.c index 0bb1bfb620..10078a103b 100644 --- a/lapack-netlib/CBLAS/testing/c_z3chke.c +++ b/lapack-netlib/CBLAS/testing/c_z3chke.c @@ -30,7 +30,7 @@ void F77_z3chke(char * rout) { B[4] = {0.0,0.0,0.0,0.0}, C[4] = {0.0,0.0,0.0,0.0}, ALPHA[2] = {0.0,0.0}, - BETA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, RALPHA = 0.0, RBETA = 0.0; extern int cblas_info, cblas_lerr, cblas_ok; extern int RowMajorStrg; @@ -49,15 +49,15 @@ void F77_z3chke(char * rout) { cblas_rout = "cblas_zgemm" ; cblas_info = 1; - cblas_zgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + cblas_zgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_zgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + cblas_zgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_zgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + cblas_zgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; @@ -272,7 +272,7 @@ void F77_z3chke(char * rout) { cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - + } else if (strncmp( sf,"cblas_zhemm" ,11)==0) { cblas_rout = "cblas_zhemm" ; @@ -1696,7 +1696,7 @@ void F77_z3chke(char * rout) { cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - + } if (cblas_ok == 1 ) diff --git a/lapack-netlib/CBLAS/testing/c_zblas1.c b/lapack-netlib/CBLAS/testing/c_zblas1.c index d2215a89e5..2b21d8f187 100644 --- a/lapack-netlib/CBLAS/testing/c_zblas1.c +++ b/lapack-netlib/CBLAS/testing/c_zblas1.c @@ -15,21 +15,21 @@ void F77_zaxpy(const int *N, const void *alpha, void *X, return; } -void F77_zcopy(const int *N, void *X, const int *incX, +void F77_zcopy(const int *N, void *X, const int *incX, void *Y, const int *incY) { cblas_zcopy(*N, X, *incX, Y, *incY); return; } -void F77_zdotc(const int *N, const void *X, const int *incX, +void F77_zdotc(const int *N, const void *X, const int *incX, const void *Y, const int *incY,void *dotc) { cblas_zdotc_sub(*N, X, *incX, Y, *incY, dotc); return; } -void F77_zdotu(const int *N, void *X, const int *incX, +void F77_zdotu(const int *N, void *X, const int *incX, void *Y, const int *incY,void *dotu) { cblas_zdotu_sub(*N, X, *incX, Y, *incY, dotu); diff --git a/lapack-netlib/CBLAS/testing/c_zblas2.c b/lapack-netlib/CBLAS/testing/c_zblas2.c index d4b4608156..b6fbdd628d 100644 --- a/lapack-netlib/CBLAS/testing/c_zblas2.c +++ b/lapack-netlib/CBLAS/testing/c_zblas2.c @@ -8,9 +8,9 @@ #include "cblas.h" #include "cblas_test.h" -void F77_zgemv(int *layout, char *transp, int *m, int *n, +void F77_zgemv(int *layout, char *transp, int *m, int *n, const void *alpha, - CBLAS_TEST_ZOMPLEX *a, int *lda, const void *x, int *incx, + CBLAS_TEST_ZOMPLEX *a, int *lda, const void *x, int *incx, const void *beta, void *y, int *incy) { CBLAS_TEST_ZOMPLEX *A; @@ -38,9 +38,9 @@ void F77_zgemv(int *layout, char *transp, int *m, int *n, *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); } -void F77_zgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, - CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, - CBLAS_TEST_ZOMPLEX *x, int *incx, +void F77_zgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy) { CBLAS_TEST_ZOMPLEX *A; @@ -85,8 +85,8 @@ void F77_zgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, *incx, beta, y, *incy ); } -void F77_zgeru(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, - CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, +void F77_zgeru(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, CBLAS_TEST_ZOMPLEX *a, int *lda){ CBLAS_TEST_ZOMPLEX *A; @@ -114,8 +114,8 @@ void F77_zgeru(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, cblas_zgeru( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); } -void F77_zgerc(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, - CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, +void F77_zgerc(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, CBLAS_TEST_ZOMPLEX *a, int *lda) { CBLAS_TEST_ZOMPLEX *A; int i,j,LDA; @@ -165,7 +165,7 @@ void F77_zhemv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, free(A); } else if (*layout == TEST_COL_MJR) - cblas_zhemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, + cblas_zhemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); else cblas_zhemv( UNDEFINED, uplo, *n, alpha, a, *lda, x, *incx, @@ -173,7 +173,7 @@ void F77_zhemv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, } void F77_zhbmv(int *layout, char *uplow, int *n, int *k, - CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy){ @@ -186,7 +186,7 @@ int i,irow,j,jcol,LDA; if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_zhbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, + cblas_zhbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, *incx, beta, y, *incy ); else { LDA = *k+2; @@ -237,7 +237,7 @@ int i,irow,j,jcol,LDA; } void F77_zhpmv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, - CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, int *incx, + CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy){ CBLAS_TEST_ZOMPLEX *A, *AP; @@ -247,7 +247,7 @@ void F77_zhpmv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, get_uplo_type(uplow,&uplo); if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_zhpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, + cblas_zhpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, beta, y, *incy); else { LDA = *n; @@ -344,7 +344,7 @@ void F77_ztbmv(int *layout, char *uplow, char *transp, char *diagn, } } } - cblas_ztbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, + cblas_ztbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); free(A); } @@ -371,7 +371,7 @@ void F77_ztbsv(int *layout, char *uplow, char *transp, char *diagn, if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_ztbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, + cblas_ztbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, *incx); else { LDA = *k+2; @@ -408,7 +408,7 @@ void F77_ztbsv(int *layout, char *uplow, char *transp, char *diagn, } } } - cblas_ztbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, + cblas_ztbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); free(A); } @@ -674,7 +674,7 @@ void F77_zhpr2(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, if (*layout == TEST_ROW_MJR) { if (uplo != CblasUpper && uplo != CblasLower ) - cblas_zhpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, + cblas_zhpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, *incy, ap ); else { LDA = *n; @@ -752,7 +752,7 @@ void F77_zher(int *layout, char *uplow, int *n, double *alpha, LDA = *n+1; A=(CBLAS_TEST_ZOMPLEX*)malloc((*n)*LDA*sizeof( CBLAS_TEST_ZOMPLEX )); - for( i=0; i<*n; i++ ) + for( i=0; i<*n; i++ ) for( j=0; j<*n; j++ ) { A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; @@ -786,7 +786,7 @@ void F77_zher2(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, LDA = *n+1; A= ( CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); - for( i=0; i<*n; i++ ) + for( i=0; i<*n; i++ ) for( j=0; j<*n; j++ ) { A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; diff --git a/lapack-netlib/CBLAS/testing/c_zblas3.c b/lapack-netlib/CBLAS/testing/c_zblas3.c index de4cb56dd3..65a821359c 100644 --- a/lapack-netlib/CBLAS/testing/c_zblas3.c +++ b/lapack-netlib/CBLAS/testing/c_zblas3.c @@ -11,9 +11,9 @@ #define TEST_ROW_MJR 1 #define UNDEFINED -1 -void F77_zgemm(int *layout, char *transpa, char *transpb, int *m, int *n, +void F77_zgemm(int *layout, char *transpa, char *transpb, int *m, int *n, int *k, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, - CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) { CBLAS_TEST_ZOMPLEX *A, *B, *C; @@ -133,7 +133,7 @@ void F77_zhemm(int *layout, char *rtlf, char *uplow, int *m, int *n, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_zhemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + cblas_zhemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -145,10 +145,10 @@ void F77_zhemm(int *layout, char *rtlf, char *uplow, int *m, int *n, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zhemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_zhemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_zhemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_zhemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_zsymm(int *layout, char *rtlf, char *uplow, int *m, int *n, @@ -189,7 +189,7 @@ void F77_zsymm(int *layout, char *rtlf, char *uplow, int *m, int *n, for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) C[i*LDC+j]=c[j*(*ldc)+i]; - cblas_zsymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + cblas_zsymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) @@ -199,15 +199,15 @@ void F77_zsymm(int *layout, char *rtlf, char *uplow, int *m, int *n, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zsymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_zsymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_zsymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + cblas_zsymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_zherk(int *layout, char *uplow, char *transp, int *n, int *k, - double *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + double *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, double *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) { int i,j,LDA,LDC; @@ -244,7 +244,7 @@ void F77_zherk(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_zherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + cblas_zherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -255,15 +255,15 @@ void F77_zherk(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + cblas_zherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, c, *ldc ); else - cblas_zherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + cblas_zherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, c, *ldc ); } void F77_zsyrk(int *layout, char *uplow, char *transp, int *n, int *k, - CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) { int i,j,LDA,LDC; @@ -300,7 +300,7 @@ void F77_zsyrk(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_zsyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, + cblas_zsyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -311,10 +311,10 @@ void F77_zsyrk(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zsyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, + cblas_zsyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, c, *ldc ); else - cblas_zsyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, + cblas_zsyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, c, *ldc ); } void F77_zher2k(int *layout, char *uplow, char *transp, int *n, int *k, @@ -363,7 +363,7 @@ void F77_zher2k(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_zher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + cblas_zher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, B, LDB, *beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -375,10 +375,10 @@ void F77_zher2k(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + cblas_zher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, *beta, c, *ldc ); else - cblas_zher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + cblas_zher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } void F77_zsyr2k(int *layout, char *uplow, char *transp, int *n, int *k, @@ -427,7 +427,7 @@ void F77_zsyr2k(int *layout, char *uplow, char *transp, int *n, int *k, C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_zsyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + cblas_zsyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, B, LDB, beta, C, LDC ); for( j=0; j<*n; j++ ) for( i=0; i<*n; i++ ) { @@ -439,14 +439,14 @@ void F77_zsyr2k(int *layout, char *uplow, char *transp, int *n, int *k, free(C); } else if (*layout == TEST_COL_MJR) - cblas_zsyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + cblas_zsyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_zsyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + cblas_zsyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } void F77_ztrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, - int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, + int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) { int i,j,LDA,LDB; CBLAS_TEST_ZOMPLEX *A, *B; @@ -486,7 +486,7 @@ void F77_ztrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, B[i*LDB+j].real=b[j*(*ldb)+i].real; B[i*LDB+j].imag=b[j*(*ldb)+i].imag; } - cblas_ztrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, A, LDA, B, LDB ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -497,15 +497,15 @@ void F77_ztrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, free(B); } else if (*layout == TEST_COL_MJR) - cblas_ztrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); else - cblas_ztrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); } void F77_ztrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, - int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, + int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) { int i,j,LDA,LDB; CBLAS_TEST_ZOMPLEX *A, *B; @@ -545,7 +545,7 @@ void F77_ztrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, B[i*LDB+j].real=b[j*(*ldb)+i].real; B[i*LDB+j].imag=b[j*(*ldb)+i].imag; } - cblas_ztrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, A, LDA, B, LDB ); for( j=0; j<*n; j++ ) for( i=0; i<*m; i++ ) { @@ -556,9 +556,9 @@ void F77_ztrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, free(B); } else if (*layout == TEST_COL_MJR) - cblas_ztrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); else - cblas_ztrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + cblas_ztrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, a, *lda, b, *ldb); } diff --git a/lapack-netlib/CBLAS/testing/c_zblat2.f b/lapack-netlib/CBLAS/testing/c_zblat2.f index 236088ff31..4392602302 100644 --- a/lapack-netlib/CBLAS/testing/c_zblat2.f +++ b/lapack-netlib/CBLAS/testing/c_zblat2.f @@ -69,7 +69,7 @@ PROGRAM ZBLAT2 INTEGER NSUBS PARAMETER ( NSUBS = 17 ) COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO, RHALF, RONE PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 ) @@ -348,13 +348,13 @@ PROGRAM ZBLAT2 160 IF (CORDER) THEN CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, $ 0 ) END IF IF (RORDER) THEN CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, - $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, $ 1 ) END IF GO TO 200 @@ -474,7 +474,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * .. Parameters .. COMPLEX*16 ZERO, HALF - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ HALF = ( 0.5D0, 0.0D0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0D0 ) @@ -582,7 +582,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, CTRANS = ' CblasNoTrans' ELSE IF (TRANS.EQ.'T')THEN CTRANS = ' CblasTrans' - ELSE + ELSE CTRANS = 'CblasConjTrans' END IF TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' @@ -685,7 +685,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * See what data changed inside subroutines. * -* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN +* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN ISAME( 1 ) = TRANS.EQ.TRANSS ISAME( 2 ) = MS.EQ.M ISAME( 3 ) = NS.EQ.N @@ -927,7 +927,7 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, UPLO = ICH( IC: IC ) IF (UPLO.EQ.'U')THEN CUPLO = ' CblasUpper' - ELSE + ELSE CUPLO = ' CblasLower' END IF * @@ -1287,7 +1287,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, UPLO = ICHU( ICU: ICU ) IF (UPLO.EQ.'U')THEN CUPLO = ' CblasUpper' - ELSE + ELSE CUPLO = ' CblasLower' END IF * @@ -1297,7 +1297,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, CTRANS = ' CblasNoTrans' ELSE IF (TRANS.EQ.'T')THEN CTRANS = ' CblasTrans' - ELSE + ELSE CTRANS = 'CblasConjTrans' END IF * @@ -1350,7 +1350,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Call the subroutine. * - IF( SNAME( 4: 5 ).EQ.'mv' )THEN + IF( SNAME( 10: 11 ).EQ.'mv' )THEN IF( FULL )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, @@ -1376,7 +1376,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, CALL CZTPMV( IORDER, UPLO, TRANS, DIAG, $ N, AA, XX, INCX ) END IF - ELSE IF( SNAME( 4: 5 ).EQ.'sv' )THEN + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN IF( FULL )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, @@ -1465,7 +1465,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, END IF * IF( .NOT.NULL )THEN - IF( SNAME( 4: 5 ).EQ.'mv' )THEN + IF( SNAME( 10: 11 ).EQ.'mv' )THEN * * Check the result. * @@ -1473,7 +1473,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ INCX, ZERO, Z, INCX, XT, G, $ XX, EPS, ERR, FATAL, NOUT, $ .TRUE. ) - ELSE IF( SNAME( 4: 5 ).EQ.'sv' )THEN + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN * * Compute approximation to original vector. * @@ -1569,7 +1569,7 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * .. Parameters .. COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ HALF = ( 0.5D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO @@ -1611,7 +1611,7 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK * .. Executable Statements .. - CONJ = SNAME( 5: 5 ).EQ.'c' + CONJ = SNAME( 11: 11 ).EQ.'c' * Define the number of arguments. NARGS = 9 * @@ -1847,7 +1847,7 @@ SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * .. Parameters .. COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ HALF = ( 0.5D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO @@ -2141,7 +2141,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * .. Parameters .. COMPLEX*16 ZERO, HALF, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ HALF = ( 0.5D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO @@ -2762,7 +2762,7 @@ SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * * .. Parameters .. COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) COMPLEX*16 ROGUE PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) diff --git a/lapack-netlib/CBLAS/testing/c_zblat3.f b/lapack-netlib/CBLAS/testing/c_zblat3.f index 6e9dbbd8c0..21e743d171 100644 --- a/lapack-netlib/CBLAS/testing/c_zblat3.f +++ b/lapack-netlib/CBLAS/testing/c_zblat3.f @@ -51,7 +51,7 @@ PROGRAM ZBLAT3 INTEGER NSUBS PARAMETER ( NSUBS = 9 ) COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO, RHALF, RONE PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 ) @@ -425,7 +425,7 @@ PROGRAM ZBLAT3 END SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, $ IORDER ) * * Tests ZGEMM. @@ -601,7 +601,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CZGEMM( IORDER, TRANSA, TRANSB, M, N, - $ K, ALPHA, AA, LDA, BB, LDB, + $ K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. @@ -689,7 +689,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - CALL ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + CALL ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) * 130 CONTINUE @@ -725,24 +725,24 @@ SUBROUTINE ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, CHARACTER*1 TRANSA, TRANSB CHARACTER*12 SNAME CHARACTER*14 CRC, CTA,CTB - + IF (TRANSA.EQ.'N')THEN CTA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CTA = ' CblasTrans' - ELSE + ELSE CTA = 'CblasConjTrans' END IF IF (TRANSB.EQ.'N')THEN CTB = ' CblasNoTrans' ELSE IF (TRANSB.EQ.'T')THEN CTB = ' CblasTrans' - ELSE + ELSE CTB = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB @@ -755,7 +755,7 @@ SUBROUTINE ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, * SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, - $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, $ IORDER ) * * Tests ZHEMM and ZSYMM. @@ -911,9 +911,9 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * Call the subroutine. * IF( TRACE ) - $ CALL ZPRCN2(NTRA, NC, SNAME, IORDER, - $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, - $ BETA, LDC) + $ CALL ZPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) IF( REWI ) $ REWIND NTRA IF( CONJ )THEN @@ -1016,7 +1016,7 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME CALL ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, - $ LDB, BETA, LDC) + $ LDB, BETA, LDC) * 120 CONTINUE RETURN @@ -1051,20 +1051,20 @@ SUBROUTINE ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, CHARACTER*1 SIDE, UPLO CHARACTER*12 SNAME CHARACTER*14 CRC, CS,CU - + IF (SIDE.EQ.'L')THEN CS = ' CblasLeft' - ELSE + ELSE CS = ' CblasRight' END IF IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU @@ -1366,8 +1366,9 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - CALL ZPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, - $ M, N, ALPHA, LDA, LDB) + IF( TRACE ) + $ CALL ZPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) * 160 CONTINUE RETURN @@ -1402,22 +1403,22 @@ SUBROUTINE ZPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, CHARACTER*1 SIDE, UPLO, TRANSA, DIAG CHARACTER*12 SNAME CHARACTER*14 CRC, CS, CU, CA, CD - + IF (SIDE.EQ.'L')THEN CS = ' CblasLeft' - ELSE + ELSE CS = ' CblasRight' END IF IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (DIAG.EQ.'N')THEN @@ -1427,7 +1428,7 @@ SUBROUTINE ZPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU @@ -1788,22 +1789,22 @@ SUBROUTINE ZPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA @@ -1822,29 +1823,29 @@ SUBROUTINE ZPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) - 9994 FORMAT( 10X, 2( I3, ',' ), + 9994 FORMAT( 10X, 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) END * @@ -2041,7 +2042,7 @@ SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CZSYR2K( IORDER, UPLO, TRANS, N, K, - $ ALPHA, AA, LDA, BB, LDB, BETA, + $ ALPHA, AA, LDA, BB, LDB, BETA, $ CC, LDC ) END IF * @@ -2241,22 +2242,22 @@ SUBROUTINE ZPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA @@ -2276,22 +2277,22 @@ SUBROUTINE ZPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA - + IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' - ELSE + ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' - ELSE + ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' - ELSE + ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA diff --git a/lapack-netlib/CMAKE/CheckFortranTypeSizes.cmake b/lapack-netlib/CMAKE/CheckFortranTypeSizes.cmake index 1f410e310e..585ca26e72 100644 --- a/lapack-netlib/CMAKE/CheckFortranTypeSizes.cmake +++ b/lapack-netlib/CMAKE/CheckFortranTypeSizes.cmake @@ -3,12 +3,12 @@ # # After execution, the following variables are set. If they are un set then # size detection was not possible -# +# # SIZEOF_INTEGER - Number of bytes used to store the default INTEGER type # SIZEOF_REAL - Number of bytes used to store the default REAL type # SIZEOF_LOGICAL - Number of bytes used to store the default LOGICAL type # SIZEOF_CHARACTER - Number of bytes used to store the default CHARACTER type -# +# #============================================================================= # Author: Chuck Atkins # Copyright 2011 @@ -18,8 +18,8 @@ macro( _CHECK_FORTRAN_TYPE_SIZE _TYPE_NAME _TEST_SIZES ) foreach( __TEST_SIZE ${_TEST_SIZES} ) - set( __TEST_FILE ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortran${_TYPE_NAME}Size${__TEST_SIZE}.f90 ) - file( WRITE ${__TEST_FILE} + set( __TEST_FILE ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortran${_TYPE_NAME}Size${__TEST_SIZE}.f90 ) + file( WRITE ${__TEST_FILE} " PROGRAM check_size ${_TYPE_NAME}*${__TEST_SIZE}, TARGET :: a @@ -27,7 +27,7 @@ macro( _CHECK_FORTRAN_TYPE_SIZE _TYPE_NAME _TEST_SIZES ) pa => a END PROGRAM ") - try_compile( SIZEOF_${_TYPE_NAME} ${PROJECT_BINARY_DIR} ${__TEST_FILE} ) + try_compile( SIZEOF_${_TYPE_NAME} ${CMAKE_BINARY_DIR} ${__TEST_FILE} ) if( SIZEOF_${_TYPE_NAME} ) message( STATUS "Testing default ${_TYPE_NAME}*${__TEST_SIZE} - found" ) set( SIZEOF_${_TYPE_NAME} ${__TEST_SIZE} CACHE INTERNAL "Size of the default ${_TYPE_NAME} type" FORCE ) diff --git a/lapack-netlib/CMAKE/CheckLAPACKCompilerFlags.cmake b/lapack-netlib/CMAKE/CheckLAPACKCompilerFlags.cmake index 77026a6631..acc51629e9 100644 --- a/lapack-netlib/CMAKE/CheckLAPACKCompilerFlags.cmake +++ b/lapack-netlib/CMAKE/CheckLAPACKCompilerFlags.cmake @@ -1,10 +1,10 @@ # This module checks against various known compilers and thier respective # flags to determine any specific flags needing to be set. -# +# # 1. If FPE traps are enabled either abort or disable them # 2. Specify fixed form if needed # 3. Ensure that Release builds use O2 instead of O3 -# +# #============================================================================= # Author: Chuck Atkins # Copyright 2011 @@ -16,7 +16,7 @@ set( FPE_EXIT FALSE ) # GNU Fortran if( CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" ) - if( "${CMAKE_Fortran_FLAGS}" MATCHES "-ffpe-trap=[izoupd]") + if( "${CMAKE_Fortran_FLAGS}" MATCHES "-ffpe-trap=[izoupd]") set( FPE_EXIT TRUE ) endif() @@ -55,12 +55,12 @@ elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "HP" ) if( "${CMAKE_Fortran_FLAGS}" MATCHES "\\+fp_exception" ) set( FPE_EXIT TRUE ) endif() - + if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "\\+fltconst_strict") ) message( STATUS "Enabling strict float conversion with +fltconst_strict" ) set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} +fltconst_strict" CACHE STRING "Flags for Fortran compiler." FORCE ) - endif() + endif() # Most versions of cmake don't have good default options for the HP compiler set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -g" @@ -76,7 +76,7 @@ endif() if( "${CMAKE_Fortran_FLAGS_RELEASE}" MATCHES "O[3-9]" ) message( STATUS "Reducing RELEASE optimization level to O2" ) - string( REGEX REPLACE "O[3-9]" "O2" CMAKE_Fortran_FLAGS_RELEASE + string( REGEX REPLACE "O[3-9]" "O2" CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" ) set( CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" CACHE STRING "Flags used by the compiler during release builds" FORCE ) diff --git a/lapack-netlib/CMAKE/CheckTimeFunction.cmake b/lapack-netlib/CMAKE/CheckTimeFunction.cmake index 1a65f242bc..b57394887c 100644 --- a/lapack-netlib/CMAKE/CheckTimeFunction.cmake +++ b/lapack-netlib/CMAKE/CheckTimeFunction.cmake @@ -16,13 +16,13 @@ macro(CHECK_TIME_FUNCTION FUNCTION VARIABLE) if(RES) set(${VARIABLE} ${FUNCTION} CACHE INTERNAL "Have Fortran function ${FUNCTION}") message(STATUS "Looking for Fortran ${FUNCTION} - found") - file(APPEND ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log + file(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log "Fortran ${FUNCTION} exists. ${OUTPUT} \n\n") - else(RES) + else() message(STATUS "Looking for Fortran ${FUNCTION} - not found") - file(APPEND ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log + file(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log "Fortran ${FUNCTION} does not exist. \n ${OUTPUT} \n") - endif(RES) -endmacro(CHECK_TIME_FUNCTION) + endif() +endmacro() diff --git a/lapack-netlib/CMAKE/FortranMangling.cmake b/lapack-netlib/CMAKE/FortranMangling.cmake index 538c80218c..d772dc9bba 100644 --- a/lapack-netlib/CMAKE/FortranMangling.cmake +++ b/lapack-netlib/CMAKE/FortranMangling.cmake @@ -8,98 +8,98 @@ # NoChange # f77IsF2C # UpCase -# +# macro(FORTRAN_MANGLING CDEFS) -MESSAGE(STATUS "=========") - GET_FILENAME_COMPONENT(F77_NAME ${CMAKE_Fortran_COMPILER} NAME) - GET_FILENAME_COMPONENT(F77_PATH ${CMAKE_Fortran_COMPILER} PATH) - SET(F77 ${F77_NAME} CACHE INTERNAL "Name of the fortran compiler.") +message(STATUS "=========") + get_filename_component(F77_NAME ${CMAKE_Fortran_COMPILER} NAME) + get_filename_component(F77_PATH ${CMAKE_Fortran_COMPILER} PATH) + set(F77 ${F77_NAME} CACHE INTERNAL "Name of the fortran compiler.") - IF(${F77} STREQUAL "ifort.exe") + if(${F77} STREQUAL "ifort.exe") #settings for Intel Fortran - SET(F77_OPTION_COMPILE "/c" CACHE INTERNAL + set(F77_OPTION_COMPILE "/c" CACHE INTERNAL "Fortran compiler option for compiling without linking.") - SET(F77_OUTPUT_OBJ "/Fo" CACHE INTERNAL + set(F77_OUTPUT_OBJ "/Fo" CACHE INTERNAL "Fortran compiler option for setting object file name.") - SET(F77_OUTPUT_EXE "/Fe" CACHE INTERNAL + set(F77_OUTPUT_EXE "/Fe" CACHE INTERNAL "Fortran compiler option for setting executable file name.") - ELSE(${F77} STREQUAL "ifort.exe") + else() # in other case, let user specify their fortran configrations. - SET(F77_OPTION_COMPILE "-c" CACHE STRING + set(F77_OPTION_COMPILE "-c" CACHE STRING "Fortran compiler option for compiling without linking.") - SET(F77_OUTPUT_OBJ "-o" CACHE STRING + set(F77_OUTPUT_OBJ "-o" CACHE STRING "Fortran compiler option for setting object file name.") - SET(F77_OUTPUT_EXE "-o" CACHE STRING + set(F77_OUTPUT_EXE "-o" CACHE STRING "Fortran compiler option for setting executable file name.") - SET(F77_LIB_PATH "" CACHE PATH + set(F77_LIB_PATH "" CACHE PATH "Library path for the fortran compiler") - SET(F77_INCLUDE_PATH "" CACHE PATH + set(F77_INCLUDE_PATH "" CACHE PATH "Include path for the fortran compiler") - ENDIF(${F77} STREQUAL "ifort.exe") + endif() + +message(STATUS "Testing FORTRAN_MANGLING") -MESSAGE(STATUS "Testing FORTRAN_MANGLING") - -MESSAGE(STATUS "Compiling Finface.f...") +message(STATUS "Compiling Finface.f...") execute_process ( COMMAND ${CMAKE_Fortran_COMPILER} ${F77_OPTION_COMPILE} ${PROJECT_SOURCE_DIR}/lapacke/mangling/Fintface.f - WORKING_DIRECTORY ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp OUTPUT_VARIABLE OUTPUT RESULT_VARIABLE RESULT ERROR_VARIABLE ERROR) if(RESULT EQUAL 0) - MESSAGE(STATUS "Compiling Finface.f successful") + message(STATUS "Compiling Finface.f successful") else() - MESSAGE(FATAL_ERROR " Compiling Finface.f FAILED") - MESSAGE(FATAL_ERROR " Error:\n ${ERROR}") + message(FATAL_ERROR " Compiling Finface.f FAILED") + message(FATAL_ERROR " Error:\n ${ERROR}") endif() -MESSAGE(STATUS "Compiling Cintface.c...") +message(STATUS "Compiling Cintface.c...") execute_process ( COMMAND ${CMAKE_C_COMPILER} ${F77_OPTION_COMPILE} ${PROJECT_SOURCE_DIR}/lapacke/mangling/Cintface.c - WORKING_DIRECTORY ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp OUTPUT_VARIABLE OUTPUT RESULT_VARIABLE RESULT ERROR_VARIABLE ERROR) if(RESULT EQUAL 0) - MESSAGE(STATUS "Compiling Cintface.c successful") + message(STATUS "Compiling Cintface.c successful") else() - MESSAGE(FATAL_ERROR " Compiling Cintface.c FAILED") - MESSAGE(FATAL_ERROR " Error:\n ${ERROR}") + message(FATAL_ERROR " Compiling Cintface.c FAILED") + message(FATAL_ERROR " Error:\n ${ERROR}") endif() -MESSAGE(STATUS "Linking Finface.f and Cintface.c...") +message(STATUS "Linking Finface.f and Cintface.c...") execute_process ( COMMAND ${CMAKE_Fortran_COMPILER} ${F77_OUTPUT_OBJ} xintface.exe Fintface.o Cintface.o - WORKING_DIRECTORY ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp OUTPUT_VARIABLE OUTPUT RESULT_VARIABLE RESULT ERROR_VARIABLE ERROR) if(RESULT EQUAL 0) - MESSAGE(STATUS "Linking Finface.f and Cintface.c successful") + message(STATUS "Linking Finface.f and Cintface.c successful") else() - MESSAGE(FATAL_ERROR " Linking Finface.f and Cintface.c FAILED") - MESSAGE(FATAL_ERROR " Error:\n ${ERROR}") + message(FATAL_ERROR " Linking Finface.f and Cintface.c FAILED") + message(FATAL_ERROR " Error:\n ${ERROR}") endif() -MESSAGE(STATUS "Running ./xintface...") +message(STATUS "Running ./xintface...") execute_process ( COMMAND ./xintface.exe - WORKING_DIRECTORY ${PROJECT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp RESULT_VARIABLE xintface_RES OUTPUT_VARIABLE xintface_OUT ERROR_VARIABLE xintface_ERR) - + if (xintface_RES EQUAL 0) - STRING(REPLACE "\n" "" xintface_OUT "${xintface_OUT}") - MESSAGE(STATUS "Fortran MANGLING convention: ${xintface_OUT}") - SET(CDEFS ${xintface_OUT}) + string(REPLACE "\n" "" xintface_OUT "${xintface_OUT}") + message(STATUS "Fortran MANGLING convention: ${xintface_OUT}") + set(CDEFS ${xintface_OUT}) else() - MESSAGE(FATAL_ERROR "FORTRAN_MANGLING:ERROR ${xintface_ERR}") - endif() - -endmacro(FORTRAN_MANGLING) + message(FATAL_ERROR "FORTRAN_MANGLING:ERROR ${xintface_ERR}") + endif() + +endmacro() diff --git a/lapack-netlib/CMAKE/PreventInBuildInstalls.cmake b/lapack-netlib/CMAKE/PreventInBuildInstalls.cmake new file mode 100644 index 0000000000..accfea64c1 --- /dev/null +++ b/lapack-netlib/CMAKE/PreventInBuildInstalls.cmake @@ -0,0 +1,9 @@ +string(TOLOWER "${CMAKE_INSTALL_PREFIX}" _PREFIX) +string(TOLOWER "${ITK_BINARY_DIR}" _BUILD) +if("${_PREFIX}" STREQUAL "${_BUILD}") + message(FATAL_ERROR + "The current CMAKE_INSTALL_PREFIX points at the build tree:\n" + " ${CMAKE_INSTALL_PREFIX}\n" + "This is not supported." + ) +endif() diff --git a/lapack-netlib/CMAKE/PreventInSourceBuilds.cmake b/lapack-netlib/CMAKE/PreventInSourceBuilds.cmake new file mode 100644 index 0000000000..8101aa65c7 --- /dev/null +++ b/lapack-netlib/CMAKE/PreventInSourceBuilds.cmake @@ -0,0 +1,45 @@ +# +# This function will prevent in-source builds +function(AssureOutOfSourceBuilds) + # make sure the user doesn't play dirty with symlinks + get_filename_component(srcdir "${CMAKE_SOURCE_DIR}" REALPATH) + get_filename_component(bindir "${CMAKE_BINARY_DIR}" REALPATH) + + # disallow in-source builds + if("${srcdir}" STREQUAL "${bindir}") + message("######################################################") + message("# lapack should not be configured & built in the lapack source directory") + message("# You must run cmake in a build directory.") + message("# For example:") + message("# mkdir lapack-Sandbox ; cd lapack-sandbox") + message("# git clone https://github.com/Reference-LAPACK/lapack.git # or download & unpack the source tarball") + message("# mkdir lapack-build") + message("# this will create the following directory structure") + message("#") + message("# lapack-Sandbox") + message("# +--lapack") + message("# +--lapack-build") + message("#") + message("# Then you can proceed to configure and build") + message("# by using the following commands") + message("#") + message("# cd lapack-build") + message("# cmake ../lapack # or ccmake, or cmake-gui ") + message("# make") + message("#") + message("# NOTE: Given that you already tried to make an in-source build") + message("# CMake have already created several files & directories") + message("# in your source tree. run 'git status' to find them and") + message("# remove them by doing:") + message("#") + message("# cd lapack-Sandbox/lapack") + message("# git clean -n -d") + message("# git clean -f -d") + message("# git checkout --") + message("#") + message("######################################################") + message(FATAL_ERROR "Quitting configuration") + endif() +endfunction() + +AssureOutOfSourceBuilds() diff --git a/lapack-netlib/CMakeLists.txt b/lapack-netlib/CMakeLists.txt index ab29bd274c..beb732106c 100644 --- a/lapack-netlib/CMakeLists.txt +++ b/lapack-netlib/CMakeLists.txt @@ -1,8 +1,17 @@ cmake_minimum_required(VERSION 2.8.10) + +# Set a default build type if none was specified +if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + message(STATUS "Setting build type to 'Release' as none was specified.") + set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) + # Set the possible values of build type for cmake-gui + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + project(LAPACK Fortran) set(LAPACK_MAJOR_VERSION 3) -set(LAPACK_MINOR_VERSION 6) +set(LAPACK_MINOR_VERSION 7) set(LAPACK_PATCH_VERSION 0) set( LAPACK_VERSION @@ -14,50 +23,80 @@ set( # the OSX RPATH settings have been updated per recommendations found # in the CMake Wiki: # http://www.cmake.org/Wiki/CMake_RPATH_handling#Mac_OS_X_and_the_RPATH - set(CMAKE_MACOSX_RPATH ON) - set(CMAKE_SKIP_BUILD_RPATH FALSE) - set(CMAKE_BUILD_WITH_INSTALL_RPATH FALSE) - set(CMAKE_INSTALL_RPATH "${CMAKE_INSTALL_PREFIX}/lib") - set(CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE) - list(FIND CMAKE_PLATFORM_IMPLICIT_LINK_DIRECTORIES "${CMAKE_INSTALL_PREFIX}/lib" isSystemDir) - if("${isSystemDir}" STREQUAL "-1") - set(CMAKE_INSTALL_RPATH "${CMAKE_INSTALL_PREFIX}/lib") - endif() +set(CMAKE_MACOSX_RPATH ON) +set(CMAKE_SKIP_BUILD_RPATH FALSE) +set(CMAKE_BUILD_WITH_INSTALL_RPATH FALSE) +list(FIND CMAKE_PLATFORM_IMPLICIT_LINK_DIRECTORIES "${CMAKE_INSTALL_PREFIX}/lib${LIB_SUFFIX}" isSystemDir) +if("${isSystemDir}" STREQUAL "-1") + set(CMAKE_INSTALL_RPATH "${CMAKE_INSTALL_PREFIX}/lib${LIB_SUFFIX}") + set(CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE) +endif() # Configure the warning and code coverage suppression file configure_file( "${LAPACK_SOURCE_DIR}/CTestCustom.cmake.in" "${LAPACK_BINARY_DIR}/CTestCustom.cmake" - COPYONLY + @ONLY ) # Add the CMake directory for custon CMake modules set(CMAKE_MODULE_PATH "${LAPACK_SOURCE_DIR}/CMAKE" ${CMAKE_MODULE_PATH}) - -if (UNIX) - if ( "${CMAKE_Fortran_COMPILER}" MATCHES "ifort" ) - set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fltconsistency -fp_port" ) - endif () - if ( "${CMAKE_Fortran_COMPILER}" MATCHES "xlf" ) - set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qnosave -qstrict=none" ) - endif () +include(PreventInSourceBuilds) +include(PreventInBuildInstalls) + +if(UNIX) + if("${CMAKE_Fortran_COMPILER}" MATCHES "ifort") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fp-model strict") + endif() + if("${CMAKE_Fortran_COMPILER}" MATCHES "xlf") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qnosave -qstrict=none") + endif() # Delete libmtsk in linking sequence for Sun/Oracle Fortran Compiler. # This library is not present in the Sun package SolarisStudio12.3-linux-x86-bin - STRING(REPLACE \;mtsk\; \; CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES "${CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES}") -endif () + string(REPLACE \;mtsk\; \; CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES "${CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES}") +endif() + +if(CMAKE_Fortran_COMPILER_ID STREQUAL "Compaq") + if(WIN32) + if(CMAKE_GENERATOR STREQUAL "NMake Makefiles") + get_filename_component(CMAKE_Fortran_COMPILER_CMDNAM ${CMAKE_Fortran_COMPILER} NAME_WE) + message(STATUS "Using Compaq Fortran compiler with command name ${CMAKE_Fortran_COMPILER_CMDNAM}") + set(cmd ${CMAKE_Fortran_COMPILER_CMDNAM}) + string(TOLOWER "${cmd}" cmdlc) + if(cmdlc STREQUAL "df") + message(STATUS "Assume the Compaq Visual Fortran Compiler is being used") + set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_OBJECTS 1) + set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_INCLUDES 1) + #This is a workaround that is needed to avoid forward-slashes in the + #filenames listed in response files from incorrectly being interpreted as + #introducing compiler command options + if(${BUILD_SHARED_LIBS}) + message(FATAL_ERROR "Making of shared libraries with CVF has not been tested.") + endif() + set(str "NMake version 9 or later should be used. NMake version 6.0 which is\n") + set(str "${str} included with the CVF distribution fails to build Lapack because\n") + set(str "${str} the number of source files exceeds the limit for NMake v6.0\n") + message(STATUS ${str}) + set(CMAKE_Fortran_LINK_EXECUTABLE "LINK /out: ") + endif() + endif() + endif() +endif() # Get Python -find_package(PythonInterp) -message(STATUS "Looking for Python found - ${PYTHONINTERP_FOUND}") -if (PYTHONINTERP_FOUND) - message(STATUS "Using Python version ${PYTHON_VERSION_STRING}") +message(STATUS "Looking for Python greater than 2.6 - ${PYTHONINTERP_FOUND}") +find_package(PythonInterp 2.7) # lapack_testing.py uses features from python 2.7 and greater +if(PYTHONINTERP_FOUND) + message(STATUS "Using Python version ${PYTHON_VERSION_STRING}") +else() + message(STATUS "No suitable Python version found, so skipping summary tests.") endif() # -------------------------------------------------- set(LAPACK_INSTALL_EXPORT_NAME lapack-targets) -if (UNIX) +if(UNIX) include(GNUInstallDirs) set(ARCHIVE_DIR ${CMAKE_INSTALL_LIBDIR}) set(LIBRARY_DIR ${CMAKE_INSTALL_LIBDIR}) @@ -77,6 +116,14 @@ macro(lapack_install_library lib) ) endmacro() +set(PKG_CONFIG_DIR ${LIBRARY_DIR}/pkgconfig) +set(prefix ${CMAKE_INSTALL_PREFIX}) +if(NOT IS_ABSOLUTE ${LIBRARY_DIR}) + set(libdir "\${prefix}/${LIBRARY_DIR}") +else() + set(libdir "${LIBRARY_DIR}") +endif() + # -------------------------------------------------- # Testing @@ -93,7 +140,7 @@ set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${LAPACK_BINARY_DIR}/lib) # -------------------------------------------------- # Check for any necessary platform specific compiler flags -include( CheckLAPACKCompilerFlags ) +include(CheckLAPACKCompilerFlags) CheckLAPACKCompilerFlags() # -------------------------------------------------- @@ -108,57 +155,65 @@ CHECK_TIME_FUNCTION(EXT_ETIME_ TIME_FUNC) CHECK_TIME_FUNCTION(INT_ETIME TIME_FUNC) message(STATUS "--> Will use second_${TIME_FUNC}.f and dsecnd_${TIME_FUNC}.f as timing function.") -set(SECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/second_${TIME_FUNC}.f) -set(DSECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/dsecnd_${TIME_FUNC}.f) -set(PKG_CONFIG_DIR ${LIBRARY_DIR}/pkgconfig) +set(SECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/second_${TIME_FUNC}.f) +set(DSECOND_SRC ${LAPACK_SOURCE_DIR}/INSTALL/dsecnd_${TIME_FUNC}.f) + +# By default static library +option(BUILD_SHARED_LIBS "Build shared libraries" OFF) + +option(BUILD_TESTING "Build tests" OFF) + +# deprecated LAPACK routines +option(BUILD_DEPRECATED "Build deprecated routines" OFF) # -------------------------------------------------- # Precision to build # By default all precisions are generated - +option(BUILD_SINGLE "Build LAPACK Single Precision" ON) +option(BUILD_DOUBLE "Build LAPACK Double Precision" ON) +option(BUILD_COMPLEX "Build LAPACK Complex Precision" ON) +option(BUILD_COMPLEX16 "Build LAPACK Double Complex Precision" ON) # -------------------------------------------------- # Subdirectories that need to be processed - option(USE_OPTIMIZED_BLAS "Whether or not to use an optimized BLAS library instead of included netlib BLAS" OFF) - # Check the usage of the user provided BLAS libraries if(BLAS_LIBRARIES) include(CheckFortranFunctionExists) set(CMAKE_REQUIRED_LIBRARIES ${BLAS_LIBRARIES}) CHECK_FORTRAN_FUNCTION_EXISTS("dgemm" BLAS_FOUND) - unset( CMAKE_REQUIRED_LIBRARIES ) + unset(CMAKE_REQUIRED_LIBRARIES) if(BLAS_FOUND) message(STATUS "--> BLAS supplied by user is WORKING, will use ${BLAS_LIBRARIES}.") - else(BLAS_FOUND) + else() message(ERROR "--> BLAS supplied by user is not WORKING, CANNOT USE ${BLAS_LIBRARIES}.") message(ERROR "--> Will use REFERENCE BLAS (by default)") message(ERROR "--> Or Correct your BLAS_LIBRARIES entry ") message(ERROR "--> Or Consider checking USE_OPTIMIZED_BLAS") - endif(BLAS_FOUND) + endif() # User did not provide a BLAS Library but specified to search for one -elseif( USE_OPTIMIZED_BLAS ) - find_package( BLAS ) -endif (BLAS_LIBRARIES) +elseif(USE_OPTIMIZED_BLAS) + find_package(BLAS) +endif() # Neither user specified or optimized BLAS libraries can be used if(NOT BLAS_FOUND) message(STATUS "Using supplied NETLIB BLAS implementation") add_subdirectory(BLAS) - set( BLAS_LIBRARIES blas ) + set(BLAS_LIBRARIES blas) else() - set( CMAKE_EXE_LINKER_FLAGS - "${CMAKE_EXE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" + set(CMAKE_EXE_LINKER_FLAGS + "${CMAKE_EXE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" CACHE STRING "Linker flags for executables" FORCE) - set( CMAKE_MODULE_LINKER_FLAGS - "${CMAKE_MODULE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" + set(CMAKE_MODULE_LINKER_FLAGS + "${CMAKE_MODULE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" CACHE STRING "Linker flags for modules" FORCE) - set( CMAKE_SHARED_LINKER_FLAGS - "${CMAKE_SHARED_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" + set(CMAKE_SHARED_LINKER_FLAGS + "${CMAKE_SHARED_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}" CACHE STRING "Linker flags for shared libs" FORCE) -endif( NOT BLAS_FOUND ) +endif() # -------------------------------------------------- @@ -167,24 +222,24 @@ option(CBLAS "Build CBLAS" OFF) if(CBLAS) add_subdirectory(CBLAS) -endif(CBLAS) +endif() # -------------------------------------------------- # XBLAS option(USE_XBLAS "Build extended precision (needs XBLAS)" OFF) -if (USE_XBLAS) +if(USE_XBLAS) find_library(XBLAS_LIBRARY NAMES xblas) -endif(USE_XBLAS) - +endif() + option(USE_OPTIMIZED_LAPACK "Whether or not to use an optimized LAPACK library instead of included netlib LAPACK" OFF) # -------------------------------------------------- # LAPACK # User did not provide a LAPACK Library but specified to search for one -if( USE_OPTIMIZED_LAPACK ) - find_package( LAPACK ) -endif (USE_OPTIMIZED_LAPACK) +if(USE_OPTIMIZED_LAPACK) + find_package(LAPACK) +endif() # Check the usage of the user provided or automatically found LAPACK libraries if(LAPACK_LIBRARIES) @@ -192,45 +247,38 @@ if(LAPACK_LIBRARIES) set(CMAKE_REQUIRED_LIBRARIES ${LAPACK_LIBRARIES}) # Check if new routine of 3.4.0 is in LAPACK_LIBRARIES CHECK_FORTRAN_FUNCTION_EXISTS("dgeqrt" LATESTLAPACK_FOUND) - unset( CMAKE_REQUIRED_LIBRARIES ) + unset(CMAKE_REQUIRED_LIBRARIES) if(LATESTLAPACK_FOUND) message(STATUS "--> LAPACK supplied by user is WORKING, will use ${LAPACK_LIBRARIES}.") - else(LAPACK_FOUND) - message(ERROR "--> LAPACK supplied by user is not WORKING or is older than LAPACK 3.4.0, CANNOT USE ${LAPACK_LIBRARIES}.") + else() + message(ERROR "--> LAPACK supplied by user is not WORKING or is older than LAPACK 3.4.0, CANNOT USE ${LAPACK_LIBRARIES}.") message(ERROR "--> Will use REFERENCE LAPACK (by default)") message(ERROR "--> Or Correct your LAPACK_LIBRARIES entry ") message(ERROR "--> Or Consider checking USE_OPTIMIZED_LAPACK") - endif(LATESTLAPACK_FOUND) -endif (LAPACK_LIBRARIES) + endif() +endif() # Neither user specified or optimized LAPACK libraries can be used if(NOT LATESTLAPACK_FOUND) message(STATUS "Using supplied NETLIB LAPACK implementation") - set( LAPACK_LIBRARIES lapack ) - option(BUILD_SINGLE "Build LAPACK Single Precision" ON) - option(BUILD_DOUBLE "Build LAPACK Double Precision" ON) - option(BUILD_COMPLEX "Build LAPACK Complex Precision" ON) - option(BUILD_COMPLEX16 "Build LAPACK Double Complex Precision" ON) + set(LAPACK_LIBRARIES lapack) add_subdirectory(SRC) else() - set( CMAKE_EXE_LINKER_FLAGS - "${CMAKE_EXE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" + set(CMAKE_EXE_LINKER_FLAGS + "${CMAKE_EXE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" CACHE STRING "Linker flags for executables" FORCE) - set( CMAKE_MODULE_LINKER_FLAGS - "${CMAKE_MODULE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" + set(CMAKE_MODULE_LINKER_FLAGS + "${CMAKE_MODULE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" CACHE STRING "Linker flags for modules" FORCE) - set( CMAKE_SHARED_LINKER_FLAGS - "${CMAKE_SHARED_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" + set(CMAKE_SHARED_LINKER_FLAGS + "${CMAKE_SHARED_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}" CACHE STRING "Linker flags for shared libs" FORCE) -endif( NOT LATESTLAPACK_FOUND ) +endif() -message(STATUS "BUILD TESTING : ${BUILD_TESTING}" ) +message(STATUS "BUILD TESTING : ${BUILD_TESTING}") if(BUILD_TESTING) add_subdirectory(TESTING) -endif(BUILD_TESTING) - -# deprecated LAPACK routines -option(BUILD_DEPRECATED "Build deprecated routines" OFF) +endif() # -------------------------------------------------- # LAPACKE @@ -239,63 +287,59 @@ option(LAPACKE "Build LAPACKE" OFF) # LAPACKE has also the interface to some routines from tmglib, # if LAPACKE_WITH_TMG is selected, we need to add those routines to LAPACKE option(LAPACKE_WITH_TMG "Build LAPACKE with tmglib routines" OFF) -if (LAPACKE_WITH_TMG) +if(LAPACKE_WITH_TMG) set(LAPACKE ON) - if(NOT BUILD_TESTING) - add_subdirectory(TESTING/MATGEN) - endif(NOT BUILD_TESTING) -endif(LAPACKE_WITH_TMG) +endif() +if(BUILD_TESTING OR LAPACKE_WITH_TMG) #already included, avoid double inclusion + add_subdirectory(TESTING/MATGEN) +endif() if(LAPACKE) add_subdirectory(LAPACKE) -endif(LAPACKE) +endif() # -------------------------------------------------- -# CPACK Packaging +# CPACK Packaging -SET(CPACK_PACKAGE_NAME "LAPACK") -SET(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") -SET(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") +set(CPACK_PACKAGE_NAME "LAPACK") +set(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") +set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") set(CPACK_PACKAGE_VERSION_MAJOR 3) set(CPACK_PACKAGE_VERSION_MINOR 5) set(CPACK_PACKAGE_VERSION_PATCH 0) set(CPACK_RESOURCE_FILE_LICENSE "${CMAKE_CURRENT_SOURCE_DIR}/LICENSE") -SET(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") -IF(WIN32 AND NOT UNIX) +set(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") +if(WIN32 AND NOT UNIX) # There is a bug in NSI that does not handle full unix paths properly. Make # sure there is at least one set of four (4) backlasshes. - SET(CPACK_NSIS_HELP_LINK "http:\\\\\\\\http://icl.cs.utk.edu/lapack-forum") - SET(CPACK_NSIS_URL_INFO_ABOUT "http:\\\\\\\\www.netlib.org/lapack") - SET(CPACK_NSIS_CONTACT "lapack@eecs.utk.edu") - SET(CPACK_NSIS_MODIFY_PATH ON) - SET(CPACK_NSIS_DISPLAY_NAME "LAPACK-${LAPACK_VERSION}") + set(CPACK_NSIS_HELP_LINK "http:\\\\\\\\http://icl.cs.utk.edu/lapack-forum") + set(CPACK_NSIS_URL_INFO_ABOUT "http:\\\\\\\\www.netlib.org/lapack") + set(CPACK_NSIS_CONTACT "lapack@eecs.utk.edu") + set(CPACK_NSIS_MODIFY_PATH ON) + set(CPACK_NSIS_DISPLAY_NAME "LAPACK-${LAPACK_VERSION}") set(CPACK_PACKAGE_RELOCATABLE "true") -ELSE(WIN32 AND NOT UNIX) - SET(CPACK_GENERATOR "TGZ") - SET(CPACK_SOURCE_GENERATOR TGZ) - SET(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-${LAPACK_VERSION}" ) - SET(CPACK_SOURCE_IGNORE_FILES ~$ .svn ${CPACK_SOURCE_IGNORE_FILES} ) -ENDIF(WIN32 AND NOT UNIX) -INCLUDE(CPack) +else() + set(CPACK_GENERATOR "TGZ") + set(CPACK_SOURCE_GENERATOR TGZ) + set(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-${LAPACK_VERSION}") + set(CPACK_SOURCE_IGNORE_FILES ~$ .svn ${CPACK_SOURCE_IGNORE_FILES}) +endif() +include(CPack) # -------------------------------------------------- -# By default static library -OPTION(BUILD_SHARED_LIBS "Build shared libraries" OFF ) -OPTION(BUILD_STATIC_LIBS "Build static libraries" ON ) -#OPTION(BUILD_SHARED_LIBS "Build shared libraries" ON ) if(NOT BLAS_FOUND) set(ALL_TARGETS ${ALL_TARGETS} blas) -endif(NOT BLAS_FOUND) +endif() if(NOT LATESTLAPACK_FOUND) set(ALL_TARGETS ${ALL_TARGETS} lapack) -endif(NOT LATESTLAPACK_FOUND) +endif() if(BUILD_TESTING OR LAPACKE_WITH_TMG) set(ALL_TARGETS ${ALL_TARGETS} tmglib) -endif(BUILD_TESTING OR LAPACKE_WITH_TMG) +endif() # Export lapack targets, not including lapacke, from the # install tree, if any. @@ -312,12 +356,12 @@ endif() # Include cblas in targets exported from the build tree. if(CBLAS) set(ALL_TARGETS ${ALL_TARGETS} cblas) -endif(CBLAS) +endif() # Include lapacke in targets exported from the build tree. if(LAPACKE) set(ALL_TARGETS ${ALL_TARGETS} lapacke) -endif(LAPACKE) +endif() # Export lapack and lapacke targets from the build tree, if any. set(_lapack_config_build_guard_target "") @@ -333,11 +377,11 @@ configure_file(${LAPACK_SOURCE_DIR}/CMAKE/lapack-config-build.cmake.in ${LAPACK_BINARY_DIR}/lapack-config.cmake @ONLY) -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/lapack.pc.in ${CMAKE_CURRENT_BINARY_DIR}/lapack.pc) +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/lapack.pc.in ${CMAKE_CURRENT_BINARY_DIR}/lapack.pc @ONLY) install(FILES ${CMAKE_CURRENT_BINARY_DIR}/lapack.pc DESTINATION ${PKG_CONFIG_DIR} - ) + ) configure_file(${LAPACK_SOURCE_DIR}/CMAKE/lapack-config-install.cmake.in ${LAPACK_BINARY_DIR}/CMakeFiles/lapack-config.cmake @ONLY) diff --git a/lapack-netlib/CTestConfig.cmake b/lapack-netlib/CTestConfig.cmake index a12749640b..17770d86b0 100644 --- a/lapack-netlib/CTestConfig.cmake +++ b/lapack-netlib/CTestConfig.cmake @@ -2,8 +2,8 @@ ## Then modify the CMakeLists.txt file in the root directory of your ## project to incorporate the testing dashboard. ## # The following are required to uses Dart and the Cdash dashboard -## ENABLE_TESTING() -## INCLUDE(CTest) +## enable_testing() +## include(CTest) set(CTEST_PROJECT_NAME "LAPACK") set(CTEST_NIGHTLY_START_TIME "00:00:00 EST") diff --git a/lapack-netlib/CTestCustom.cmake.in b/lapack-netlib/CTestCustom.cmake.in index bbdeadb71c..45fb1ccda7 100644 --- a/lapack-netlib/CTestCustom.cmake.in +++ b/lapack-netlib/CTestCustom.cmake.in @@ -1,17 +1,17 @@ # -# For further details regarding this file, +# For further details regarding this file, # see http://www.vtk.org/Wiki/CMake_Testing_With_CTest#Customizing_CTest # -SET(CTEST_CUSTOM_MAXIMUM_PASSED_TEST_OUTPUT_SIZE 0) -SET(CTEST_CUSTOM_MAXIMUM_FAILED_TEST_OUTPUT_SIZE 0) -SET(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_ERRORS 500) -SET(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_WARNINGS 500) +set(CTEST_CUSTOM_MAXIMUM_PASSED_TEST_OUTPUT_SIZE 0) +set(CTEST_CUSTOM_MAXIMUM_FAILED_TEST_OUTPUT_SIZE 0) +set(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_ERRORS 500) +set(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_WARNINGS 500) # Files to explicitly exclude from code coverage -SET(CTEST_CUSTOM_COVERAGE_EXCLUDE +set(CTEST_CUSTOM_COVERAGE_EXCLUDE ${CTEST_CUSTOM_COVERAGE_EXCLUDE} - + # Exclude the internal BLAS libraries "/BLAS/" @@ -20,27 +20,36 @@ SET(CTEST_CUSTOM_COVERAGE_EXCLUDE ) # Warnings to explicitly ignore -SET(CTEST_CUSTOM_WARNING_EXCEPTION +set(CTEST_CUSTOM_WARNING_EXCEPTION ${CTEST_CUSTOM_WARNING_EXCEPTION} - # Common warning when linking ATLAS built with GNU Fortran 4.1 and building + # Common warning when linking ATLAS built with GNU Fortran 4.1 and building # with GNU Fortran 4.4. It can be safely ignored. "libgfortran.*may conflict with libgfortran" # Harmless warning often seen on IRIX "WARNING 84 : .*libm.* is not used for resolving any symbol" - # Warnings caused by sun compilers when building code to only run on your + # Warnings caused by sun compilers when building code to only run on your # native platform "xarch=native on this architecture implies -xarch=.*which generates code that does not run" - + # Harmless warnings from the Intel compiler on Windows "ipo: warning #11010: file format not recognized for .*\\.exe\\.embed\\.manifest\\.res" "LINK : warning LNK4224: /INCREMENTAL:YES is no longer supported; ignored" - # Warnings caused by string truncation in the test code. The truncation is + # Warnings caused by string truncation in the test code. The truncation is # intentional "Character string truncated to length 1 on assignment" + + # Warnings caused by NFS build directories have out-of-sync times + "Warning: File .* has modification time .* in the future" ) -SET(CTEST_CUSTOM_POST_TEST "./lapack_testing.py -s -d TESTING") \ No newline at end of file +# Only rung post test if suitable python interpreter was found +set(PYTHONINTERP_FOUND @PYTHONINTERP_FOUND@) +set(PYTHON_EXECUTABLE @PYTHON_EXECUTABLE@) +if(PYTHONINTERP_FOUND) + set(CTEST_CUSTOM_POST_TEST "${PYTHON_EXECUTABLE} ./lapack_testing.py -s -d TESTING") +endif() + diff --git a/lapack-netlib/DOCS/Doxyfile b/lapack-netlib/DOCS/Doxyfile index 2ffed29f29..db9bb4725e 100644 --- a/lapack-netlib/DOCS/Doxyfile +++ b/lapack-netlib/DOCS/Doxyfile @@ -38,7 +38,7 @@ PROJECT_NAME = LAPACK # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = 3.6.0 +PROJECT_NUMBER = 3.7.0 # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -210,7 +210,7 @@ INHERIT_DOCS = YES # of the file/class/namespace that contains it. # The default value is: NO. -SEPARATE_MEMBER_PAGES = NO +SEPARATE_MEMBER_PAGES = YES # The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen # uses this value to replace tabs by spaces in code fragments. @@ -1045,7 +1045,7 @@ CLANG_ASSISTED_PARSING = NO # specified with INPUT and INCLUDE_PATH. # This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. -CLANG_OPTIONS = +CLANG_OPTIONS = #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index diff --git a/lapack-netlib/DOCS/Doxyfile_man b/lapack-netlib/DOCS/Doxyfile_man index 255adf1603..7b048a29f8 100644 --- a/lapack-netlib/DOCS/Doxyfile_man +++ b/lapack-netlib/DOCS/Doxyfile_man @@ -38,7 +38,7 @@ PROJECT_NAME = LAPACK # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = 3.6.0 +PROJECT_NUMBER = 3.7.0 # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -705,7 +705,7 @@ CITE_BIB_FILES = # messages are off. # The default value is: NO. -QUIET = YES +QUIET = NO # The WARNINGS tag can be used to turn on/off the warning messages that are # generated to standard error (stderr) by doxygen. If WARNINGS is set to YES @@ -810,32 +810,12 @@ RECURSIVE = YES EXCLUDE = CMAKE \ DOCS \ - .svn \ - CBLAS/.svn \ - CBLAS/src/.svn \ - CBLAS/testing/.svn \ - CBLAS/example/.svn \ - CBLAS/include/.svn \ - BLAS/.svn \ - BLAS/SRC/.svn \ - BLAS/TESTING/.svn \ - SRC/.svn \ - SRC/VARIANTS/.svn \ - SRC/VARIANTS/LIB/.svn \ - SRC/VARIANTS/cholesky/.svn \ - SRC/VARIANTS/cholesky/RL/.svn \ - SRC/VARIANTS/cholesky/TOP/.svn \ - SRC/VARIANTS/lu/.svn \ - SRC/VARIANTS/lu/CR/.svn \ - SRC/VARIANTS/lu/LL/.svn \ - SRC/VARIANTS/lu/REC/.svn \ - SRC/VARIANTS/qr/.svn \ - SRC/VARIANTS/qr/LL/.svn \ - INSTALL/.svn \ - TESTING/.svn \ - TESTING/EIG/.svn \ - TESTING/MATGEN/.svn \ - TESTING/LIN/.svn + BLAS/TESTING \ + CBLAS \ + LAPACKE/mangling \ + INSTALL \ + SRC/DEPRECATED \ + TESTING # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -959,7 +939,7 @@ SOURCE_BROWSER = YES # classes and enums directly into the documentation. # The default value is: NO. -INLINE_SOURCES = YES +INLINE_SOURCES = NO # Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any # special comment blocks from generated source code fragments. Normal C, C++ and @@ -1045,7 +1025,7 @@ CLANG_ASSISTED_PARSING = NO # specified with INPUT and INCLUDE_PATH. # This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. -CLANG_OPTIONS = +CLANG_OPTIONS = #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index @@ -2164,7 +2144,7 @@ HIDE_UNDOC_RELATIONS = YES # set to NO # The default value is: NO. -HAVE_DOT = YES +HAVE_DOT = NO # The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed # to run in parallel. When set to 0 doxygen will base this on the number of @@ -2206,7 +2186,7 @@ DOT_FONTPATH = # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -CLASS_GRAPH = YES +CLASS_GRAPH = NO # If the COLLABORATION_GRAPH tag is set to YES then doxygen will generate a # graph for each documented class showing the direct and indirect implementation @@ -2215,14 +2195,14 @@ CLASS_GRAPH = YES # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -COLLABORATION_GRAPH = YES +COLLABORATION_GRAPH = NO # If the GROUP_GRAPHS tag is set to YES then doxygen will generate a graph for # groups, showing the direct groups dependencies. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -GROUP_GRAPHS = YES +GROUP_GRAPHS = NO # If the UML_LOOK tag is set to YES, doxygen will generate inheritance and # collaboration diagrams in a style similar to the OMG's Unified Modeling @@ -2260,7 +2240,7 @@ TEMPLATE_RELATIONS = NO # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -INCLUDE_GRAPH = YES +INCLUDE_GRAPH = NO # If the INCLUDED_BY_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are # set to YES then doxygen will generate a graph for each documented file showing @@ -2269,7 +2249,7 @@ INCLUDE_GRAPH = YES # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -INCLUDED_BY_GRAPH = YES +INCLUDED_BY_GRAPH = NO # If the CALL_GRAPH tag is set to YES then doxygen will generate a call # dependency graph for every global function or class method. @@ -2281,7 +2261,7 @@ INCLUDED_BY_GRAPH = YES # The default value is: NO. # This tag requires that the tag HAVE_DOT is set to YES. -CALL_GRAPH = YES +CALL_GRAPH = NO # If the CALLER_GRAPH tag is set to YES then doxygen will generate a caller # dependency graph for every global function or class method. @@ -2293,14 +2273,14 @@ CALL_GRAPH = YES # The default value is: NO. # This tag requires that the tag HAVE_DOT is set to YES. -CALLER_GRAPH = YES +CALLER_GRAPH = NO # If the GRAPHICAL_HIERARCHY tag is set to YES then doxygen will graphical # hierarchy of all classes instead of a textual one. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -GRAPHICAL_HIERARCHY = YES +GRAPHICAL_HIERARCHY = NO # If the DIRECTORY_GRAPH tag is set to YES then doxygen will show the # dependencies a directory has on other directories in a graphical way. The @@ -2309,7 +2289,7 @@ GRAPHICAL_HIERARCHY = YES # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -DIRECTORY_GRAPH = YES +DIRECTORY_GRAPH = NO # The DOT_IMAGE_FORMAT tag can be used to set the image format of the images # generated by dot. For an explanation of the image formats see the section @@ -2336,7 +2316,7 @@ DOT_IMAGE_FORMAT = svg # The default value is: NO. # This tag requires that the tag HAVE_DOT is set to YES. -INTERACTIVE_SVG = YES +INTERACTIVE_SVG = NO # The DOT_PATH tag can be used to specify the path where the dot tool can be # found. If left blank, it is assumed the dot tool can be found in the path. @@ -2427,7 +2407,7 @@ DOT_MULTI_TARGETS = NO # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. -GENERATE_LEGEND = YES +GENERATE_LEGEND = NO # If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate dot # files that are used to generate the various graphs. diff --git a/lapack-netlib/DOCS/groups-usr.dox b/lapack-netlib/DOCS/groups-usr.dox index feb134f118..6c31e4cf5f 100644 --- a/lapack-netlib/DOCS/groups-usr.dox +++ b/lapack-netlib/DOCS/groups-usr.dox @@ -14,6 +14,9 @@ * @defgroup SY Symmetric Matrix * @ingroup lapack * This is the group of Symmetric Matrix routines + * @defgroup HE Hermitian Matrix + * @ingroup lapack + * This is the group of Hermitian Matrix routines * @defgroup PO Positive Definite Matrix * @ingroup lapack * This is the group of Positive Definite routines @@ -23,9 +26,18 @@ * @defgroup PT Positive Definite tridiagonal Matrix * @ingroup lapack * This is the group of Positive Definite tridiagonal routines - * @defgroup auxOTHERauxiliary Other Auxiliary Routines + * @defgroup OTHEReigen Eigenvalue + * @ingroup lapack + * This is the group of Other Eigenvalue routines + * @defgroup OTHERauxiliary Other Auxiliary Routines * @ingroup lapack * This is the group of Other Auxiliary routines + * @defgroup OTHERcomputational Other Computational Routines + * @ingroup lapack + * This is the group of Other Computational routines + * @defgroup OTHERsolve Other Solve Routines + * @ingroup lapack + * This is the group of Other Solve routines * **** * @@ -38,6 +50,9 @@ * @defgroup solveSY Linear Solve * @ingroup SY * This is the group of Linear Solve Driver routines + * @defgroup solveHE Linear Solve + * @ingroup HE + * This is the group of Linear Solve Driver routines * @defgroup solvePO Linear Solve * @ingroup PO * This is the group of Linear Solve Driver routines @@ -53,27 +68,42 @@ * @defgroup eigenSY Eigenvalue * @ingroup SY * This is the group of Eigenvalue Driver routines + * @defgroup eigenHE Eigenvalue + * @ingroup HE + * This is the group of Eigenvalue Driver routines * @defgroup singGE Singular Value * @ingroup GE * This is the group of Singular Value Driver routines * @defgroup computationalGE Computational routines * @ingroup GE * This is the group of Computational routines + * @defgroup variantsGEcomputational Variants Computational routines + * @ingroup GE + * This is the group of Variants Computational routines * @defgroup computationalGB Computational routines * @ingroup GB * This is the group of Computational routines * @defgroup computationalSY Computational routines * @ingroup SY * This is the group of Computational routines + * @defgroup computationalHE Computational routines + * @ingroup HE + * This is the group of Computational routines * @defgroup computationalPO Computational routines * @ingroup PO * This is the group of Computational routines + * @defgroup variantsPOcomputational Variants Computational routines + * @ingroup PO + * This is the group of Variants Computational routines * @defgroup computationalGT Computational routines * @ingroup GT * This is the group of Computational routines * @defgroup computationalPT Computational routines * @ingroup PT * This is the group of Computational routines + * @defgroup variantsOTHERcomputational Variants Computational routines + * @ingroup OTHERcomputational + * This is the group of Variants Computational routines * @defgroup auxiliaryGE Auxiliary routines * @ingroup GE * This is the group of Auxiliary routines @@ -83,6 +113,9 @@ * @defgroup auxiliarySY Auxiliary routines * @ingroup SY * This is the group of Auxiliary routines + * @defgroup auxiliaryHE Auxiliary routines + * @ingroup HE + * This is the group of Auxiliary routines * @defgroup auxiliaryPO Auxiliary routines * @ingroup PO * This is the group of Auxiliary routines @@ -96,10 +129,10 @@ **** * * @defgroup doubleGEsolve double - * @ingroup solveGE + * @ingroup solveGE * This is the group of double solve driver functions for GE matrices * @defgroup doublePOsolve double - * @ingroup solvePO + * @ingroup solvePO * This is the group of double solve driver functions for PO matrices * @defgroup doubleSYsolve double * @ingroup solveSY @@ -114,22 +147,22 @@ * @ingroup solvePT * This is the group of double solve driver functions for PT matrices * @defgroup doubleGEeigen double - * @ingroup eigenGE + * @ingroup eigenGE * This is the group of double eigenvalue driver functions for GE matrices * @defgroup doubleSYeigen double * @ingroup eigenSY * This is the group of double eigenvalue driver functions for SY matrices * @defgroup doubleGEsing double - * @ingroup singGE + * @ingroup singGE * This is the group of double singular value driver functions for GE matrices * @defgroup doubleGEcomputational double - * @ingroup computationalGE + * @ingroup computationalGE * This is the group of double computational functions for GE matrices * @defgroup doublePOcomputational double - * @ingroup computationalPO + * @ingroup computationalPO * This is the group of double computational functions for PO matrices * @defgroup doubleSYcomputational double - * @ingroup computationalSY + * @ingroup computationalSY * This is the group of double computational functions for SY matrices * @defgroup doubleGBcomputational double * @ingroup computationalGB @@ -141,31 +174,43 @@ * @ingroup computationalPT * This is the group of double computational functions for PT matrices * @defgroup doubleGEauxiliary double - * @ingroup auxiliaryGE + * @ingroup auxiliaryGE * This is the group of double auxiliary functions for GE matrices * @defgroup doublePOauxiliary double - * @ingroup auxiliaryPO + * @ingroup auxiliaryPO * This is the group of double auxiliary functions for PO matrices * @defgroup doubleSYauxiliary double * @ingroup auxiliarySY * This is the group of double auxiliary functions for SY matrices * @defgroup doubleGBauxiliary double - * @ingroup auxiliaryGB + * @ingroup auxiliaryGB * This is the group of double auxiliary functions for GB matrices * @defgroup doublePTauxiliary double - * @ingroup auxiliaryPT + * @ingroup auxiliaryPT * This is the group of double auxiliary functions for PT matrices * @defgroup doubleGTauxiliary double - * @ingroup auxiliaryGT + * @ingroup auxiliaryGT * This is the group of double auxiliary functions for GT matrices + * @defgroup doubleOTHERauxiliary double + * @ingroup OTHERauxiliary + * This is the group of double other auxiliary routines + * @defgroup doubleOTHERcomputational double + * @ingroup OTHERcomputational + * This is the group of double other Computational routines + * @defgroup doubleOTHERsolve double Other Solve Routines + * @ingroup OTHERsolve + * This is the group of double Other Solve routines + * @defgroup doubleOTHEReigen double + * @ingroup OTHEReigen + * This is the group of double Other Eigenvalue routines * **** * * @defgroup realGEsolve real - * @ingroup solveGE + * @ingroup solveGE * This is the group of real solve driver functions for GE matrices * @defgroup realPOsolve real - * @ingroup solvePO + * @ingroup solvePO * This is the group of real solve driver functions for PO matrices * @defgroup realSYsolve real * @ingroup solveSY @@ -180,22 +225,22 @@ * @ingroup solvePT * This is the group of real solve driver functions for PT matrices * @defgroup realGEeigen real - * @ingroup eigenGE + * @ingroup eigenGE * This is the group of real eigenvalue driver functions for GE matrices * @defgroup realSYeigen real * @ingroup eigenSY * This is the group of real eigenvalue driver functions for SY matrices * @defgroup realGEsing real - * @ingroup singGE + * @ingroup singGE * This is the group of real singular value driver functions for GE matrices * @defgroup realGEcomputational real - * @ingroup computationalGE + * @ingroup computationalGE * This is the group of real computational functions for GE matrices * @defgroup realPOcomputational real - * @ingroup computationalPO + * @ingroup computationalPO * This is the group of real computational functions for PO matrices * @defgroup realSYcomputational real - * @ingroup computationalSY + * @ingroup computationalSY * This is the group of real computational functions for SY matrices * @defgroup realGBcomputational real * @ingroup computationalGB @@ -207,16 +252,16 @@ * @ingroup computationalGT * This is the group of real computational functions for GT matrices * @defgroup realGEauxiliary real - * @ingroup auxiliaryGE + * @ingroup auxiliaryGE * This is the group of real auxiliary functions for GE matrices * @defgroup realPOauxiliary real - * @ingroup auxiliaryPO + * @ingroup auxiliaryPO * This is the group of real auxiliary functions for PO matrices * @defgroup realSYauxiliary real * @ingroup auxiliarySY * This is the group of real auxiliary functions for SY matrices * @defgroup realGBauxiliary real - * @ingroup auxiliaryGB + * @ingroup auxiliaryGB * This is the group of real auxiliary functions for GB matrices * @defgroup realGTauxiliary real * @ingroup auxiliaryGT @@ -224,18 +269,33 @@ * @defgroup realPTauxiliary real * @ingroup auxiliaryPT * This is the group of real auxiliary functions for PT matrices + * @defgroup realOTHERauxiliary real + * @ingroup OTHERauxiliary + * This is the group of real other auxiliary routines + * @defgroup realOTHERcomputational real + * @ingroup OTHERcomputational + * This is the group of real other Computational routines + * @defgroup realOTHERsolve real Other Solve Routines + * @ingroup OTHERsolve + * This is the group of real Other Solve routines + * @defgroup realOTHEReigen real + * @ingroup OTHEReigen + * This is the group of real Other Eigenvalue routines * **** * * @defgroup complexGEsolve complex - * @ingroup solveGE + * @ingroup solveGE * This is the group of complex solve driver functions for GE matrices * @defgroup complexPOsolve complex - * @ingroup solvePO + * @ingroup solvePO * This is the group of complex solve driver functions for PO matrices * @defgroup complexSYsolve complex * @ingroup solveSY * This is the group of complex solve driver functions for SY matrices + * @defgroup complexHEsolve complex + * @ingroup solveHE + * This is the group of complex solve driver functions for HE matrices * @defgroup complexGBsolve complex * @ingroup solveGB * This is the group of complex solve driver functions for GB matrices @@ -246,23 +306,29 @@ * @ingroup solvePT * This is the group of complex solve driver functions for PT matrices * @defgroup complexGEeigen complex - * @ingroup eigenGE + * @ingroup eigenGE * This is the group of complex eigenvalue driver functions for GE matrices * @defgroup complexSYeigen complex * @ingroup eigenSY * This is the group of complex eigenvalue driver functions for SY matrices + * @defgroup complexHEeigen complex + * @ingroup eigenHE + * This is the group of complex eigenvalue driver functions for HE matrices * @defgroup complexGEsing complex - * @ingroup singGE + * @ingroup singGE * This is the group of complex singular value driver functions for GE matrices * @defgroup complexGEcomputational complex - * @ingroup computationalGE + * @ingroup computationalGE * This is the group of complex computational functions for GE matrices * @defgroup complexPOcomputational complex - * @ingroup computationalPO + * @ingroup computationalPO * This is the group of complex computational functions for PO matrices * @defgroup complexSYcomputational complex - * @ingroup computationalSY + * @ingroup computationalSY * This is the group of complex computational functions for SY matrices + * @defgroup complexHEcomputational complex + * @ingroup computationalHE + * This is the group of complex computational functions for HE matrices * @defgroup complexGBcomputational complex * @ingroup computationalGB * This is the group of complex computational functions for GB matrices @@ -273,29 +339,47 @@ * @ingroup computationalPT * This is the group of complex computational functions for PT matrices * @defgroup complexGEauxiliary complex - * @ingroup auxiliaryGE + * @ingroup auxiliaryGE * This is the group of complex auxiliary functions for GE matrices * @defgroup complexPOauxiliary complex - * @ingroup auxiliaryPO + * @ingroup auxiliaryPO * This is the group of complex auxiliary functions for PO matrices * @defgroup complexSYauxiliary complex * @ingroup auxiliarySY * This is the group of complex auxiliary functions for SY matrices + * @defgroup complexHEauxiliary complex + * @ingroup auxiliaryHE + * This is the group of complex auxiliary functions for HE matrices * @defgroup complexGBauxiliary complex - * @ingroup auxiliaryGB + * @ingroup auxiliaryGB * This is the group of complex auxiliary functions for GB matrices + * @defgroup complexOTHERauxiliary complex + * @ingroup OTHERauxiliary + * This is the group of complex other auxiliary routines + * @defgroup complexOTHERcomputational complex + * @ingroup OTHERcomputational + * This is the group of complex other Computational routines + * @defgroup complexOTHERsolve complex Other Solve Routines + * @ingroup OTHERsolve + * This is the group of complex Other Solve routines + * @defgroup complexOTHEReigen complex Other Eigenvalue routines + * @ingroup OTHEReigen + * This is the group of complex Other Eigenvalue routines * **** * * @defgroup complex16GEsolve complex16 - * @ingroup solveGE + * @ingroup solveGE * This is the group of complex16 solve driver functions for GE matrices * @defgroup complex16POsolve complex16 - * @ingroup solvePO + * @ingroup solvePO * This is the group of complex16 solve driver functions for PO matrices * @defgroup complex16SYsolve complex16 * @ingroup solveSY * This is the group of complex16 solve driver functions for SY matrices + * @defgroup complex16HEsolve complex16 + * @ingroup solveHE + * This is the group of complex16 solve driver functions for HE matrices * @defgroup complex16GBsolve complex16 * @ingroup solveGB * This is the group of complex16 solve driver functions for GB matrices @@ -306,23 +390,29 @@ * @ingroup solvePT * This is the group of complex16 solve driver functions for PT matrices * @defgroup complex16GEeigen complex16 - * @ingroup eigenGE + * @ingroup eigenGE * This is the group of complex16 eigenvalue driver functions for GE matrices * @defgroup complex16SYeigen complex16 * @ingroup eigenSY * This is the group of complex16 eigenvalue driver functions for SY matrices + * @defgroup complex16HEeigen complex16 + * @ingroup eigenHE + * This is the group of complex16 eigenvalue driver functions for HE matrices * @defgroup complex16GEsing complex16 - * @ingroup singGE + * @ingroup singGE * This is the group of complex16 singular value driver functions for GE matrices * @defgroup complex16GEcomputational complex16 - * @ingroup computationalGE + * @ingroup computationalGE * This is the group of complex16 computational functions for GE matrices * @defgroup complex16POcomputational complex16 - * @ingroup computationalPO + * @ingroup computationalPO * This is the group of complex16 computational functions for PO matrices * @defgroup complex16SYcomputational complex16 - * @ingroup computationalSY + * @ingroup computationalSY * This is the group of complex16 computational functions for SY matrices + * @defgroup complex16HEcomputational complex16 + * @ingroup computationalHE + * This is the group of complex16 computational functions for HE matrices * @defgroup complex16GBcomputational complex16 * @ingroup computationalGB * This is the group of complex16 computational functions for GB matrices @@ -333,17 +423,35 @@ * @ingroup computationalPT * This is the group of complex16 computational functions for PT matrices * @defgroup complex16GEauxiliary complex16 - * @ingroup auxiliaryGE + * @ingroup auxiliaryGE * This is the group of complex16 auxiliary functions for GE matrices * @defgroup complex16POauxiliary complex16 - * @ingroup auxiliaryPO + * @ingroup auxiliaryPO * This is the group of complex16 auxiliary functions for PO matrices * @defgroup complex16SYauxiliary complex16 * @ingroup auxiliarySY * This is the group of complex16 auxiliary functions for SY matrices + * @defgroup complex16HEauxiliary complex16 + * @ingroup auxiliaryHE + * This is the group of complex16 auxiliary functions for HE matrices * @defgroup complex16GBauxiliary complex16 - * @ingroup auxiliaryGB + * @ingroup auxiliaryGB * This is the group of complex16 auxiliary functions for GB matrices + * @defgroup complex16OTHERcomputational complex16 + * @ingroup OTHERcomputational + * This is the group of complex16 other Computational routines + * @defgroup complex16OTHERauxiliary complex16 + * @ingroup OTHERauxiliary + * This is the group of complex16 other auxiliary routines + * @defgroup auxOTHERcomputational auxiliary Computational routines + * @ingroup OTHERcomputational + * This is the group of auxiliary Computational routines + * @defgroup complex16OTHERsolve complex16 Other Solve Routines + * @ingroup OTHERsolve + * This is the group of complex16 Other Solve routines + * @defgroup complex16OTHEReigen complex16 Other Eigenvalue routines + * @ingroup OTHEReigen + * This is the group of complex16 Other Eigenvalue routines * **** * @@ -351,75 +459,75 @@ * This is the group of LAPACK TESTING routines. * * @defgroup matgen Matrix Generation - * @ingroup testing + * @ingroup testing * This is the group of LAPACK TESTING MATGEN routines. * * @defgroup lin Linear Solve - * @ingroup testing + * @ingroup testing * This is the group of LAPACK TESTING LIN routines. * * @defgroup eig Eigenvalue and Singular value - * @ingroup testing + * @ingroup testing * This is the group of LAPACK TESTING EIG routines. * * @defgroup real_matgen real - * @ingroup matgen + * @ingroup matgen * This is the group of real LAPACK TESTING MATGEN routines. * * @defgroup double_matgen double - * @ingroup matgen + * @ingroup matgen * This is the group of double LAPACK TESTING MATGEN routines. * * @defgroup complex_matgen complex - * @ingroup matgen + * @ingroup matgen * This is the group of complex LAPACK TESTING MATGEN routines. * * @defgroup complex16_matgen complex16 - * @ingroup matgen + * @ingroup matgen * This is the group of complex16 LAPACK TESTING MATGEN routines. * * @defgroup aux_matgen aux - * @ingroup matgen + * @ingroup matgen * This is the group of auxiliary LAPACK TESTING MATGEN routines. * * @defgroup single_lin real - * @ingroup lin + * @ingroup lin * This is the group of real LAPACK TESTING LIN routines. * * @defgroup double_lin double - * @ingroup lin + * @ingroup lin * This is the group of double LAPACK TESTING LIN routines. * * @defgroup complex_lin complex - * @ingroup lin + * @ingroup lin * This is the group of complex LAPACK TESTING LIN routines. * * @defgroup complex16_lin complex16 - * @ingroup lin + * @ingroup lin * This is the group of complex16 LAPACK TESTING LIN routines. * * @defgroup aux_lin aux - * @ingroup lin + * @ingroup lin * This is the group of auxiliary LAPACK TESTING LIN routines. * * @defgroup single_eig real - * @ingroup eig + * @ingroup eig * This is the group of real LAPACK TESTING EIG routines. * * @defgroup double_eig double - * @ingroup eig + * @ingroup eig * This is the group of double LAPACK TESTING EIG routines. * * @defgroup complex_eig complex - * @ingroup eig + * @ingroup eig * This is the group of complex LAPACK TESTING EIG routines. * * @defgroup complex16_eig complex16 - * @ingroup eig + * @ingroup eig * This is the group of complex16 LAPACK TESTING EIG routines. * * @defgroup aux_eig aux - * @ingroup eig + * @ingroup eig * This is the group of auxiliary LAPACK TESTING EIG routines. * **** @@ -435,7 +543,10 @@ * @defgroup level3 Level3 * @ingroup blas * This is the group of LEVEL 3 BLAS routines. - * @defgroup blastesting Testing + * @defgroup aux_blas Auxiliary BLAS + * @ingroup blas + * This is the group of Auxiliary 3 BLAS routines. +* @defgroup blastesting Testing * @ingroup blas * This is the group of BLAS TESTING routines. * @@ -443,52 +554,52 @@ * @ingroup level1 * This is the group of real LEVEL 1 BLAS routines. * @defgroup double_blas_level1 double - * @ingroup level1 + * @ingroup level1 * This is the group of double LEVEL 1 BLAS routines. * @defgroup complex_blas_level1 complex - * @ingroup level1 + * @ingroup level1 * This is the group of complex LEVEL 1 BLAS routines. * @defgroup complex16_blas_level1 complex16 - * @ingroup level1 + * @ingroup level1 * This is the group of complex16 LEVEL 1 BLAS routines. * * @defgroup single_blas_level2 real * @ingroup level2 * This is the group of real LEVEL 2 BLAS routines. * @defgroup double_blas_level2 double - * @ingroup level2 + * @ingroup level2 * This is the group of double LEVEL 2 BLAS routines. * @defgroup complex_blas_level2 complex - * @ingroup level2 + * @ingroup level2 * This is the group of complex LEVEL 2 BLAS routines. * @defgroup complex16_blas_level2 complex16 - * @ingroup level2 + * @ingroup level2 * This is the group of complex16 LEVEL 2 BLAS routines. * * @defgroup single_blas_level3 real * @ingroup level3 * This is the group of real LEVEL 3 BLAS routines. * @defgroup double_blas_level3 double - * @ingroup level3 + * @ingroup level3 * This is the group of double LEVEL 3 BLAS routines. * @defgroup complex_blas_level3 complex - * @ingroup level3 + * @ingroup level3 * This is the group of complex LEVEL 3 BLAS routines. * @defgroup complex16_blas_level3 complex16 - * @ingroup level3 + * @ingroup level3 * This is the group of complex16 LEVEL 3 BLAS routines. * * @defgroup single_blas_testing real * @ingroup blastesting * This is the group of real BLAS TESTING routines. * @defgroup double_blas_testing double - * @ingroup blastesting + * @ingroup blastesting * This is the group of double BLAS TESTING routines. * @defgroup complex_blas_testing complex - * @ingroup blastesting + * @ingroup blastesting * This is the group of complex BLAS TESTING routines. * @defgroup complex16_blas_testing complex16 - * @ingroup blastesting + * @ingroup blastesting * This is the group of complex16 BLAS TESTING routines. * **/ diff --git a/lapack-netlib/DOCS/lawn81.tex b/lapack-netlib/DOCS/lawn81.tex index 16efef7680..73a4437756 100644 --- a/lapack-netlib/DOCS/lawn81.tex +++ b/lapack-netlib/DOCS/lawn81.tex @@ -43,7 +43,7 @@ %Separate instructions are provided for the Unix and non-Unix %versions of the test package. %Further details are also given on the design of the test and timing -%programs. +%programs. \newpage \tableofcontents @@ -55,7 +55,7 @@ \section{Introduction} LAPACK is a linear algebra library for high-performance computers. -The library includes Fortran subroutines for +The library includes Fortran subroutines for the analysis and solution of systems of simultaneous linear algebraic equations, linear least-squares problems, and matrix eigenvalue problems. @@ -63,21 +63,21 @@ \section{Introduction} a standard set of Basic Linear Algebra Subprograms (the BLAS), which can be optimized for each computing environment. By confining most of the computational work to the BLAS, -the subroutines should be +the subroutines should be transportable and efficient across a wide range of computers. This working note describes how to install, test, and time this release of LAPACK on a Unix System. -The instructions for installing, testing, and timing -\footnote{timing are only provided in LAPACK 3.0 and before} +The instructions for installing, testing, and timing +\footnote{timing are only provided in LAPACK 3.0 and before} are designed for a person whose responsibility is the maintenance of a mathematical software library. -We assume the installer has experience in compiling and running +We assume the installer has experience in compiling and running Fortran programs and in creating object libraries. The installation process involves untarring the file, creating a set of -libraries, and compiling and running the test and timing programs -\footnotemark[\value{footnote}]. +libraries, and compiling and running the test and timing programs +\footnotemark[\value{footnote}]. %This guide combines the instructions for the Unix and non-Unix %versions of the LAPACK test package (the non-Unix version is in Appendix @@ -97,13 +97,13 @@ \section{Introduction} % Sections~\ref{moretesting} %and ~\ref{moretiming} give %details of the test and timing programs and their input files. -%Appendices ~\ref{appendixa} and ~\ref{appendixb} briefly describe +%Appendices ~\ref{appendixa} and ~\ref{appendixb} briefly describe %the LAPACK routines and auxiliary routines provided -%in this release. -%Appendix ~\ref{appendixc} lists the operation counts we have computed +%in this release. +%Appendix ~\ref{appendixc} lists the operation counts we have computed %for the BLAS and for some of the LAPACK routines. -Appendix ~\ref{appendixd}, entitled ``Caveats'', is a compendium of the known -problems from our own experiences, with suggestions on how to +Appendix ~\ref{appendixd}, entitled ``Caveats'', is a compendium of the known +problems from our own experiences, with suggestions on how to overcome them. \textbf{It is strongly advised that the user read Appendix @@ -122,9 +122,9 @@ \section{Revisions Since the First Public Release} June 30, 1992, was version 1.0a; the second update, October 31, 1992, was version 1.0b; the third update, March 31, 1993, was version 1.1; version 2.0 on September 30, 1994, coincided with the release of the -Second Edition of the LAPACK Users' Guide; +Second Edition of the LAPACK Users' Guide; version 3.0 on June 30, 1999 coincided with the release of the Third Edition of -the LAPACK Users' Guide; +the LAPACK Users' Guide; version 3.1 was released on November, 2006; version 3.1.1 was released on November, 2007; and version 3.2.0 was released on November, 2008. @@ -141,7 +141,7 @@ \section{Revisions Since the First Public Release} %available on netlib is always the most up-to-date. % %On-line manpages (troff files) for LAPACK driver and computational -%routines, as well as most of the BLAS routines, are available via +%routines, as well as most of the BLAS routines, are available via %the \texttt{lapack} index on netlib. \section{File Format}\label{fileformat} @@ -151,7 +151,7 @@ \section{File Format}\label{fileformat} which contains the Fortran source for LAPACK, the Basic Linear Algebra Subprograms (the Level 1, 2, and 3 BLAS) needed by LAPACK, the testing programs, -and the timing programs\footnotemark[\value{footnote}]. +and the timing programs\footnotemark[\value{footnote}]. Users who wish to have a non-Unix installation should refer to LAPACK Working Note 41, although the overview in section~\ref{overview} applies to both the Unix and non-Unix @@ -189,13 +189,13 @@ \section{File Format}\label{fileformat} \caption{Unix organization of LAPACK 3.0} \vspace{11pt} \end{figure} -Libraries are created in the LAPACK directory and +Libraries are created in the LAPACK directory and executable files are created in one of the directories BLAS, TESTING, -or TIMING\footnotemark[\value{footnote}]. Input files for the test and +or TIMING\footnotemark[\value{footnote}]. Input files for the test and timing\footnotemark[\value{footnote}] programs are also found in these three directories so that testing may be carried out in the directories LAPACK/BLAS, LAPACK/TESTING, and LAPACK/TIMING \footnotemark[\value{footnote}]. -A top-level makefile in the LAPACK directory is provided to perform the +A top-level makefile in the LAPACK directory is provided to perform the entire installation procedure. \section{Overview of Tape Contents}\label{overview} @@ -209,7 +209,7 @@ \section{Overview of Tape Contents}\label{overview} Some routines use features of Fortran 90. For convenience, we often refer to routines by their single precision names; the leading `S' can be replaced by a `D' for double precision, -a `C' for complex, or a `Z' for complex*16. +a `C' for complex, or a `Z' for complex*16. For LAPACK use and testing you must decide which version(s) of the package you intend to install at your site (for example, REAL and COMPLEX on a Cray computer or DOUBLE PRECISION and @@ -231,14 +231,14 @@ \subsection{LAPACK Routines} perform a distinct computational task, such as computing the $LU$ decomposition of an $m$-by-$n$ matrix or finding the eigenvalues and eigenvectors of a symmetric tridiagonal matrix using -the $QR$ algorithm. +the $QR$ algorithm. The LAPACK routines are listed in LAPACK Working Note 41~\cite{WN41} and the LAPACK Users' Guide~\cite{LUG}. %The LAPACK routines are listed in Appendix ~\ref{appendixa}; see also LAPACK %Working Note \#5 \cite{WN5}. \item \textbf{auxiliary} routines are all the other subroutines called -by the driver routines and computational routines. +by the driver routines and computational routines. %Among them are subroutines to perform subtasks of block algorithms, %in particular, the unblocked versions of the block algorithms; %extensions to the BLAS, such as matrix-vector operations involving @@ -260,12 +260,12 @@ \subsection{LAPACK Routines} \subsection{Level 1, 2, and 3 BLAS} The BLAS are a set of Basic Linear Algebra Subprograms that perform -vector-vector, matrix-vector, and matrix-matrix operations. +vector-vector, matrix-vector, and matrix-matrix operations. LAPACK is designed around the Level 1, 2, and 3 BLAS, and nearly all of the parallelism in the LAPACK routines is contained in the BLAS. Therefore, the key to getting good performance from LAPACK lies in having an -efficient version of the BLAS optimized for your particular machine. +efficient version of the BLAS optimized for your particular machine. Optimized BLAS libraries are available on a variety of architectures, refer to the BLAS FAQ on netlib for further information. \begin{quote} @@ -290,7 +290,7 @@ \subsection{Level 1, 2, and 3 BLAS} employ the standard tricks for optimizing Fortran code. The formal definitions of the Level 1, 2, and 3 BLAS -are in \cite{BLAS1}, \cite{BLAS2}, and \cite{BLAS3}. +are in \cite{BLAS1}, \cite{BLAS2}, and \cite{BLAS3}. The BLAS Quick Reference card is available on netlib. \subsection{Mixed- and Extended-Precision BLAS: XBLAS} @@ -320,7 +320,7 @@ \subsection{LAPACK Test Routines} \subsection{LAPACK Timing Routines (for LAPACK 3.0 and before) } This release also contains two distinct timing programs for the -LAPACK routines in each data type. +LAPACK routines in each data type. The linear equation timing program gathers performance data in megaflops on the factor, solve, and inverse routines for solving linear systems, the routines to generate or apply an orthogonal matrix @@ -341,12 +341,12 @@ \subsection{LAPACK Timing Routines (for LAPACK 3.0 and before) } \section{Installing LAPACK on a Unix System}\label{installation} Installing, testing, and timing\footnotemark[\value{footnote}] the Unix version of LAPACK -involves the following steps: +involves the following steps: \begin{enumerate} \item Gunzip and tar the file. \item Copy and edit the file \texttt{LAPACK/make.inc.example to LAPACK/make.inc}. - + \item Edit the file \texttt{LAPACK/Makefile} and type \texttt{make}. %\item Test and Install the Machine-Dependent Routines \\ @@ -402,7 +402,7 @@ \section{Installing LAPACK on a Unix System}\label{installation} %\item \texttt{make blas\_timing} %\end{list} \end{enumerate} - + \subsection{Untar the File} If you received a tar file of LAPACK via the World Wide @@ -424,7 +424,7 @@ \subsection{Copy and edit the file \texttt{LAPACK/make.inc.example to LAPACK/mak run, you must define all machine-specific parameters for the architecture to which you are installing LAPACK. All machine-specific parameters are contained in the file \texttt{LAPACK/make.inc}. -An example of \texttt{LAPACK/make.inc} for a LINUX machine with GNU compilers is given +An example of \texttt{LAPACK/make.inc} for a LINUX machine with GNU compilers is given in \texttt{LAPACK/make.inc.example}, copy that file to LAPACK/make.inc by entering the following command: \begin{list}{} @@ -452,14 +452,14 @@ \subsection{Copy and edit the file \texttt{LAPACK/make.inc.example to LAPACK/mak \begin{verbatim} #The Default : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME TIMER = EXT_ETIME -# For RS6K : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME_ +# For RS6K : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME_ # TIMER = EXT_ETIME_ # For gfortran compiler: SECOND and DSECND will use the INTERNAL FUNCTION ETIME # TIMER = INT_ETIME # If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...) # SECOND and DSECND will use a call to the INTERNAL FUNCTION CPU_TIME # TIMER = INT_CPU_TIME -# If neither of this works...you can use the NONE value... +# If neither of this works...you can use the NONE value... # In that case, SECOND and DSECND will always return 0 # TIMER = NONE \end{verbatim} @@ -497,7 +497,7 @@ \subsection{Edit the file \texttt{LAPACK/Makefile}}\label{toplevelmakefile} installation process as the user desires. Ideally, this is the ONLY makefile the user must modify. However, modification of lower-level makefiles may be necessary if a specific routine needs to be compiled -with a different level of optimization. +with a different level of optimization. First, edit the definitions of \texttt{blaslib}, \texttt{lapacklib}, \texttt{tmglib}, \texttt{lapack\_testing}, and \texttt{timing}\footnotemark[\value{footnote}] in the file \texttt{LAPACK/Makefile} @@ -529,7 +529,7 @@ \subsection{Edit the file \texttt{LAPACK/Makefile}}\label{toplevelmakefile} %timing: % ( cd TIMING; $(MAKE) -f Makefile.sgi ) %\end{verbatim} - + Next, if you will be using a locally available BLAS library, you will need to remove \texttt{blaslib} from the \texttt{lib} definition. And finally, if you do not wish to build all of the libraries individually and @@ -595,7 +595,7 @@ \subsection{Test and Install the Machine-Dependent Routines.} type \texttt{make lapack\_install}. The test programs are called \texttt{testlsame, testslamch, testdlamch, testsecond, testdsecnd} and \texttt{testieee}. -If you do not wish to run all tests, you will need to modify the +If you do not wish to run all tests, you will need to modify the \texttt{lapack\_install} definition in the \texttt{LAPACK/Makefile} to only include the tests you wish to run. Otherwise, all tests will be performed. The expected results of each test program are described below. @@ -604,18 +604,18 @@ \subsubsection{Installing LSAME} LSAME is a logical function with two character parameters, A and B. It returns .TRUE. if A and B are the same regardless of case, or .FALSE. -if they are different. +if they are different. For example, the expression -\begin{list}{}{} +\begin{list}{}{} \item \texttt{LSAME( UPLO, 'U' )} \end{list} -\noindent +\noindent is equivalent to -\begin{list}{}{} +\begin{list}{}{} \item \texttt{( UPLO.EQ.'U' ).OR.( UPLO.EQ.'u' )} -\end{list} - +\end{list} + The test program in \texttt{lsametst.f} tests all combinations of the same character in upper and lower case for A and B, and two cases where A and B are different characters. @@ -628,7 +628,7 @@ \subsubsection{Installing LSAME} Tests completed \end{verbatim} The file \texttt{lsame.f} is automatically copied to -\texttt{LAPACK/BLAS/SRC/} and \texttt{LAPACK/SRC/}. +\texttt{LAPACK/BLAS/SRC/} and \texttt{LAPACK/SRC/}. The function LSAME is needed by both the BLAS and LAPACK, so it is safer to have it in both libraries as long as this does not cause trouble in the link phase when both libraries are used. @@ -636,10 +636,10 @@ \subsubsection{Installing LSAME} \subsubsection{Installing SLAMCH and DLAMCH} SLAMCH and DLAMCH are real functions with a single character parameter -that indicates the machine parameter to be returned. The test +that indicates the machine parameter to be returned. The test program in \texttt{slamchtst.f} simply prints out the different values computed by SLAMCH, -so you need to know something about what the values should be. +so you need to know something about what the values should be. For example, the output of the test program executable \texttt{testslamch} for SLAMCH on a Sun SPARCstation is \begin{verbatim} @@ -699,7 +699,7 @@ \subsubsection{Installing SLAMCH and DLAMCH} it is recomputed as $(1/(\mathrm{overflow})) * ( 1 + \varepsilon )$, where $\varepsilon$ is the machine precision. -BE AWARE that the initial call to SLAMCH or DLAMCH is expensive. +BE AWARE that the initial call to SLAMCH or DLAMCH is expensive. We suggest that installers run it once, save the results, and hard-code the constants in the version they put in their library. @@ -708,9 +708,9 @@ \subsubsection{Installing SECOND and DSECND}\label{second} Both the timing routines\footnotemark[\value{footnote}] and the test routines call SECOND (DSECND), a real function with no arguments that returns the time in seconds from some fixed starting time. -Our version of this routine -returns only ``user time'', and not ``user time $+$ system time''. -The following version of SECOND in \texttt{second\_EXT\_ETIME.f, second\_INT\_ETIME.f} calls +Our version of this routine +returns only ``user time'', and not ``user time $+$ system time''. +The following version of SECOND in \texttt{second\_EXT\_ETIME.f, second\_INT\_ETIME.f} calls ETIME, a Fortran library routine available on some computer systems. If ETIME is not available or a better local timing function exists, you will have to provide the correct interface to SECOND and DSECND @@ -720,18 +720,18 @@ \subsubsection{Installing SECOND and DSECND}\label{second} The version that will be used depends on the value of the TIMER variable in the make.inc \begin{itemize} -\item If ETIME is available as an external function, set the value of the TIMER variable in your +\item If ETIME is available as an external function, set the value of the TIMER variable in your make.inc to \texttt{EXT\_ETIME}:\texttt{second\_EXT\_ETIME.f} and \texttt{dsecnd\_EXT\_ETIME.f} will be used. Usually on HPPA architectures, the compiler and loader flag \texttt{+U77} should be included to access the function \texttt{ETIME}. -\item If ETIME\_ is available as an external function, set the value of the TIMER variable in your make.inc +\item If ETIME\_ is available as an external function, set the value of the TIMER variable in your make.inc to \texttt{EXT\_ETIME\_}:\texttt{second\_EXT\_ETIME\_.f} and \texttt{dsecnd\_EXT\_ETIME\_.f} will be used. It is the case on some IBM architectures such as IBM RS/6000s. \item If ETIME is available as an internal function, set the value of the TIMER variable in your make.inc -to \texttt{INT\_ETIME}:\texttt{second\_INT\_ETIME.f} and \texttt{dsecnd\_INT\_ETIME.f} will be used. +to \texttt{INT\_ETIME}:\texttt{second\_INT\_ETIME.f} and \texttt{dsecnd\_INT\_ETIME.f} will be used. This is the case with gfortan. \item If CPU\_TIME is available as an internal function, set the value of the TIMER variable in your make.inc @@ -743,19 +743,19 @@ \subsubsection{Installing SECOND and DSECND}\label{second} \end{itemize} The test program in \texttt{secondtst.f} -performs a million operations using 5000 iterations of +performs a million operations using 5000 iterations of the SAXPY operation $y := y + \alpha x$ on a vector of length 100. The total time and megaflops for this test is reported, then the operation is repeated including a call to SECOND on each of the 5000 iterations to determine the overhead due to calling SECOND. The test program executable is called \texttt{testsecond} (or \texttt{testdsecnd}). There is no single right answer, but the times -in seconds should be positive and the megaflop ratios should be +in seconds should be positive and the megaflop ratios should be appropriate for your machine. \subsubsection{Testing IEEE arithmetic and ILAENV}\label{testieee} -%\textbf{If you are installing LAPACK on a non-IEEE machine, you MUST +%\textbf{If you are installing LAPACK on a non-IEEE machine, you MUST %modify ILAENV! Otherwise, ILAENV will crash . By default, ILAENV %assumes an IEEE machine, and does a test for IEEE-754 compliance.} @@ -767,7 +767,7 @@ \subsubsection{Testing IEEE arithmetic and ILAENV}\label{testieee} are installing LAPACK on a non-IEEE machine, you MUST modify ILAENV, as this test inside ILAENV will crash!} -If \texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is +If \texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is issued, then \texttt{ILAENV=1} is returned to signal IEEE-754 compliance, and \texttt{ILAENV=0} if the architecture is non-IEEE-754 compliant. @@ -791,10 +791,10 @@ \subsubsection{Testing IEEE arithmetic and ILAENV}\label{testieee} The test program in \texttt{LAPACK/INSTALL/tstiee.f} checks an installation architecture -to see if infinity arithmetic and NaN arithmetic are IEEE-754 compliant. +to see if infinity arithmetic and NaN arithmetic are IEEE-754 compliant. A warning message to the user is printed if non-compliance is detected. This same test is performed inside the function ILAENV. If -\texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is +\texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is issued, then \texttt{ILAENV=1} is returned to signal IEEE-754 compliance, and \texttt{ILAENV=0} if the architecture is non-IEEE-754 compliant. @@ -805,12 +805,12 @@ \subsubsection{Testing IEEE arithmetic and ILAENV}\label{testieee} his library. As aforementioned, there are also specialized testing and timing\footnotemark[\value{footnote}] versions of ILAENV that will also need to be modified. -\subsection{Create the BLAS Library} +\subsection{Create the BLAS Library} Ideally, a highly optimized version of the BLAS library already -exists on your machine. +exists on your machine. In this case you can go directly to Section~\ref{testblas} to -make the BLAS test programs. +make the BLAS test programs. \begin{itemize} \item[a)] @@ -819,13 +819,13 @@ \subsection{Create the BLAS Library} in Section~\ref{toplevelmakefile}. If you already have some of the BLAS, you will need to edit the file -\texttt{LAPACK/BLAS/SRC/Makefile} to comment out the lines -defining the BLAS you have. +\texttt{LAPACK/BLAS/SRC/Makefile} to comment out the lines +defining the BLAS you have. \item[b)] Type \texttt{make blaslib}. The make command can be run more than once to add another -data type to the library if necessary. +data type to the library if necessary. \end{itemize} \noindent @@ -835,7 +835,7 @@ \subsection{Create the BLAS Library} \subsection{Run the BLAS Test Programs}\label{testblas} -Test programs for the Level 1, 2, and 3 BLAS are in the directory +Test programs for the Level 1, 2, and 3 BLAS are in the directory \texttt{LAPACK/BLAS/TESTING}. To compile and run the Level 1, 2, and 3 BLAS test programs, @@ -856,14 +856,14 @@ \subsection{Run the BLAS Test Programs}\label{testblas} For example, on a machine with vector registers, at least one value of $N$ greater than the length of the vector registers should be used; otherwise, important parts of the compiled code may not be -exercised by the tests. +exercised by the tests. If the tests were not successful, either because the program did not finish or the test ratios did not pass the threshold, you will -probably have to find and correct the problem before continuing. +probably have to find and correct the problem before continuing. If you have been testing a system-specific BLAS library, try using the Fortran BLAS for the routines that did not pass the tests. -For more details on the BLAS test programs, +For more details on the BLAS test programs, see \cite{BLAS2-test} and \cite{BLAS3-test}. \subsection{Create the LAPACK Library} @@ -877,7 +877,7 @@ \subsection{Create the LAPACK Library} \item[b)] Type \texttt{make lapacklib}. The make command can be run more than once to add another -data type to the library if necessary. +data type to the library if necessary. \end{itemize} @@ -897,13 +897,13 @@ \subsection{Create the Test Matrix Generator Library} \item[b)] Type \texttt{make tmglib}. The make command can be run more than once to add another -data type to the library if necessary. +data type to the library if necessary. \end{itemize} \noindent The test matrix generator library is created in \texttt{LAPACK/tmglib\_PLAT.a}, -where \texttt{PLAT} is the user-defined architecture suffix specified in the +where \texttt{PLAT} is the user-defined architecture suffix specified in the file \texttt{LAPACK/make.inc}. \subsection{Run the LAPACK Test Programs} @@ -917,13 +917,13 @@ \subsection{Run the LAPACK Test Programs} The input files reside in \texttt{LAPACK/TESTING}. For more information on the test programs and how to modify the input files, please refer to LAPACK Working Note 41~\cite{WN41}. -% see Section~\ref{moretesting}. +% see Section~\ref{moretesting}. If you do not wish to run each of the tests individually, you can go to \texttt{LAPACK}, edit the definition \texttt{lapack\_testing} in the file \texttt{Makefile} to specify the data types desired, and type \texttt{make lapack\_testing}. This will -compile and run the tests as described in sections~\ref{testlin} +compile and run the tests as described in sections~\ref{testlin} and ~\ref{testeig}. %If you are installing LAPACK on a Silicon Graphics machine, you must @@ -932,7 +932,7 @@ \subsection{Run the LAPACK Test Programs} %testing: % ( cd TESTING; $(MAKE) -f Makefile.sgi ) %\end{verbatim} - + \subsubsection{Testing the Linear Equations Routines}\label{testlin} \begin{itemize} @@ -1071,7 +1071,7 @@ \subsection{Run the LAPACK Timing Programs (For LAPACK 3.0 and before)} \texttt{Makefile} to specify the data types desired, and type \texttt{make lapack\_timing}. This will compile and run the timings for the linear equation routines and the eigensystem -routines (see Sections~\ref{timelin} and ~\ref{timeeig}). +routines (see Sections~\ref{timelin} and ~\ref{timeeig}). %If you are installing LAPACK on a Silicon Graphics machine, you must %modify the definition of \texttt{timing} to be @@ -1082,7 +1082,7 @@ \subsection{Run the LAPACK Timing Programs (For LAPACK 3.0 and before)} If you encounter failures in any phase of the timing process, please feel free to contact the authors as directed in Section~\ref{sendresults}. -Tell us the +Tell us the type of machine on which the tests were run, the version of the operating system, the compiler and compiler options that were used, and details of the BLAS library or libraries that you used. You should @@ -1112,7 +1112,7 @@ \subsubsection{Timing the Linear Equations Routines}\label{timelin} \begin{sloppypar} To make a library of the instrumented LAPACK routines, first go to \texttt{LAPACK/TIMING/LIN/LINSRC} and type \texttt{make} followed -by the data types desired, as in the examples of Section~\ref{toplevelmakefile}. +by the data types desired, as in the examples of Section~\ref{toplevelmakefile}. The library of instrumented code is created in \texttt{LAPACK/TIMING/LIN/linsrc\_PLAT.a}, where \texttt{PLAT} is the user-defined architecture suffix specified in the @@ -1137,11 +1137,11 @@ \subsubsection{Timing the Linear Equations Routines}\label{timelin} The computational requirements can be cut in half by using only one value of LDA. If it is necessary to also reduce the matrix sizes or the values of -the blocksize, corresponding changes should be made to the +the blocksize, corresponding changes should be made to the BLAS input files (see Section~\ref{timeblas}). \item[d)] -Run the programs for each data type you are using. +Run the programs for each data type you are using. For the REAL version, the commands for the small data sets are \begin{list}{}{} @@ -1164,10 +1164,10 @@ \subsubsection{Timing the BLAS}\label{timeblas} The linear equation timing program is also used to time the BLAS. Three input files are provided in each data type for timing the Level -2 and 3 BLAS. +2 and 3 BLAS. These input files time the BLAS using the matrix shapes encountered in the LAPACK routines, and we will use the results to analyze the -performance of the LAPACK routines. +performance of the LAPACK routines. For the REAL version, the small data files are \texttt{sblasa\_small.in}, \texttt{sblasb\_small.in}, and \texttt{sblasc\_small.in} and the large data files are @@ -1176,10 +1176,10 @@ \subsubsection{Timing the BLAS}\label{timeblas} parameters in the Level 3 BLAS, M, N, and K, and in most applications one of these parameters is small (on the order of the blocksize) while the other two are large (on the order of the -matrix size). +matrix size). In \texttt{sblasa\_small.in}, M and N are large but K is small, while in \texttt{sblasb\_small.in} the small parameter is M, and -in \texttt{sblasc\_small.in} the small parameter is N. +in \texttt{sblasc\_small.in} the small parameter is N. The Level 2 BLAS are timed only in the first data set, where K is also used as the bandwidth for the banded routines. @@ -1190,7 +1190,7 @@ \subsubsection{Timing the BLAS}\label{timeblas} make any necessary modifications to the input files. You may need to set the minimum time a subroutine will be timed to a positive value. -If you modified the values of N or NB +If you modified the values of N or NB in Section~\ref{timelin}, set M, N, and K accordingly. The large parameters among M, N, and K should be the same as the matrix sizes used in timing the linear @@ -1201,7 +1201,7 @@ \subsubsection{Timing the BLAS}\label{timeblas} value of LDA. \item[b)] -Run the programs for each data type you are using. +Run the programs for each data type you are using. For the REAL version, the commands for the small data sets are \begin{list}{}{} @@ -1226,8 +1226,8 @@ \subsubsection{Timing the Eigensystem Routines}\label{timeeig} and the input files are in \texttt{LAPACK/TIMING}. Four input files are provided in each data type for timing the eigensystem routines, -one for the generalized nonsymmetric eigenvalue problem, -one for the nonsymmetric eigenvalue problem, +one for the generalized nonsymmetric eigenvalue problem, +one for the nonsymmetric eigenvalue problem, one for the symmetric and generalized symmetric eigenvalue problem, and one for the singular value decomposition. For the REAL version, the small data sets are called \texttt{sgeptim\_small.in}, @@ -1249,7 +1249,7 @@ \subsubsection{Timing the Eigensystem Routines}\label{timeeig} \begin{sloppypar} To make a library of the instrumented LAPACK routines, first go to \texttt{LAPACK/TIMING/EIG/EIGSRC} and type \texttt{make} followed -by the data types desired, as in the examples of Section~\ref{toplevelmakefile}. +by the data types desired, as in the examples of Section~\ref{toplevelmakefile}. The library of instrumented code is created in \texttt{LAPACK/TIMING/EIG/eigsrc\_PLAT.a}, where \texttt{PLAT} is the user-defined architecture suffix specified in the @@ -1257,7 +1257,7 @@ \subsubsection{Timing the Eigensystem Routines}\label{timeeig} \end{sloppypar} \item[b)] -To make the eigensystem timing programs, +To make the eigensystem timing programs, go to \texttt{LAPACK/TIMING/EIG} and type \texttt{make} followed by the data types desired, as in the examples of Section~\ref{toplevelmakefile}. The executable files are called @@ -1281,7 +1281,7 @@ \subsubsection{Timing the Eigensystem Routines}\label{timeeig} % See Section~\ref{moretiming} for further details. \item[d)] -Run the programs for each data type you are using. +Run the programs for each data type you are using. For the REAL version, the commands for the small data sets are \begin{list}{}{} @@ -1305,13 +1305,13 @@ \subsubsection{Timing the Eigensystem Routines}\label{timeeig} \subsection{Send the Results to Tennessee}\label{sendresults} Congratulations! You have now finished installing, testing, and -timing LAPACK. If you encountered failures in any phase of the +timing LAPACK. If you encountered failures in any phase of the testing or timing process, please consult our \texttt{release\_notes} file on netlib. \begin{quote} \url{http://www.netlib.org/lapack/release\_notes} \end{quote} -This file contains machine-dependent installation clues which hopefully will +This file contains machine-dependent installation clues which hopefully will alleviate your difficulties or at least let you know that other users have had similar difficulties on that machine. If there is not an entry for your machine or the suggestions do not fix your problem, please feel @@ -1319,7 +1319,7 @@ \subsection{Send the Results to Tennessee}\label{sendresults} \begin{list}{}{} \item \href{mailto:lapack@cs.utk.edu}{\texttt{lapack@cs.utk.edu}}. \end{list} -Tell us the +Tell us the type of machine on which the tests were run, the version of the operating system, the compiler and compiler options that were used, and details of the BLAS library or libraries that you used. You should @@ -1328,7 +1328,7 @@ \subsection{Send the Results to Tennessee}\label{sendresults} We would like to keep our \texttt{release\_notes} file as up-to-date as possible. Therefore, if you do not see an entry for your machine, please contact us with your testing results. - + Comments and suggestions are also welcome. We encourage you to make the LAPACK library available to your @@ -1337,16 +1337,16 @@ \subsection{Send the Results to Tennessee}\label{sendresults} %with any previous test release. \subsection{Get support}\label{getsupport} -First, take a look at the complete installation manual in the LAPACK Working Note 41~\cite{WN41}. +First, take a look at the complete installation manual in the LAPACK Working Note 41~\cite{WN41}. if you still cannot solve your problem, you have 2 ways to go: \begin{itemize} \item -either send a post in the LAPACK forum +either send a post in the LAPACK forum \begin{quote} \url{http://icl.cs.utk.edu/lapack-forum} \end{quote} \item -or send an email to the LAPACK mailing list: +or send an email to the LAPACK mailing list: \begin{list}{}{} \item \href{mailto:lapack@cs.utk.edu}{\texttt{lapack@cs.utk.edu}}. \end{list} @@ -1493,7 +1493,7 @@ \section{Compiling testing/timing drivers} has two options: increase your stack size, or force all local variables to be allocated statically. -On HPPA architectures, the +On HPPA architectures, the compiler and loader flag \texttt{-K} should be used when compiling these testing and timing main programs to avoid such a stack overflow. I.e., set \texttt{DRVOPTS = -K} in the \texttt{LAPACK/make.inc} file. @@ -1619,19 +1619,19 @@ \section{Timing programs} \bibitem{LUG} E. Anderson, Z. Bai, C. Bischof, J. Demmel, J. Dongarra, J. Du Croz, A. Greenbaum, S. Hammarling, A. McKenney, -S. Ostrouchov, and D. Sorensen, +S. Ostrouchov, and D. Sorensen, \textit{LAPACK Users' Guide}, Second Edition, {SIAM}, Philadelphia, PA, 1995. \bibitem{WN16} E. Anderson and J. Dongarra, -\textit{LAPACK Working Note 16: +\textit{LAPACK Working Note 16: Results from the Initial Release of LAPACK}, University of Tennessee, CS-89-89, November 1989. \bibitem{WN41} E. Anderson, J. Dongarra, and S. Ostrouchov, -\textit{LAPACK Working Note 41: +\textit{LAPACK Working Note 41: Installation Guide for LAPACK}, University of Tennessee, CS-92-151, February 1992 (revised June 1999). @@ -1644,7 +1644,7 @@ \section{Timing programs} \bibitem{WN13} Z. Bai, J. Demmel, and A. McKenney, \textit{LAPACK Working Note \#13: On the Conditioning of the Nonsymmetric -Eigenvalue Problem: Theory and Software}, +Eigenvalue Problem: Theory and Software}, University of Tennessee, CS-89-86, October 1989. \bibitem{XBLAS} @@ -1653,7 +1653,7 @@ \section{Timing programs} and D. J. Yoo, \textit{Design, implementation and testing of extended and mixed precision BLAS}, \textit{ACM Trans. Math. Soft.}, 28, 2:152--205, June 2002. - + \bibitem{BLAS3} J. Dongarra, J. Du Croz, I. Duff, and S. Hammarling, ``A Set of Level 3 Basic Linear Algebra Subprograms,'' diff --git a/lapack-netlib/INSTALL/CMakeLists.txt b/lapack-netlib/INSTALL/CMakeLists.txt index 1e2867f122..1e808a64c3 100644 --- a/lapack-netlib/INSTALL/CMakeLists.txt +++ b/lapack-netlib/INSTALL/CMakeLists.txt @@ -7,4 +7,3 @@ add_executable(secondtst_INT_ETIME second_INT_ETIME.f secondtst.f) add_executable(secondtst_INT_CPU_TIME second_INT_CPU_TIME.f secondtst.f) add_executable(testieee tstiee.f) add_executable(testversion ilaver.f LAPACK_version.f) - diff --git a/lapack-netlib/INSTALL/LAPACK_version.f b/lapack-netlib/INSTALL/LAPACK_version.f index 81d1f08caa..163b7e2b26 100644 --- a/lapack-netlib/INSTALL/LAPACK_version.f +++ b/lapack-netlib/INSTALL/LAPACK_version.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,21 +13,21 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== PROGRAM LAPACK_VERSION * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * INTEGER MAJOR, MINOR, PATCH * diff --git a/lapack-netlib/INSTALL/Makefile b/lapack-netlib/INSTALL/Makefile index d322048b02..15f5252be1 100644 --- a/lapack-netlib/INSTALL/Makefile +++ b/lapack-netlib/INSTALL/Makefile @@ -1,35 +1,35 @@ include ../make.inc -.SUFFIXES : .o .f -all: slamch.o dlamch.o testlsame testslamch testdlamch testsecond testdsecnd testieee testversion +.SUFFIXES: .o .f +all: testlsame testslamch testdlamch testsecond testdsecnd testieee testversion -testlsame: lsame.o lsametst.o - $(LOADER) $(LOADOPTS) -o testlsame lsame.o lsametst.o +testlsame: lsame.o lsametst.o + $(LOADER) $(LOADOPTS) -o $@ lsame.o lsametst.o testslamch: slamch.o lsame.o slamchtst.o - $(LOADER) $(LOADOPTS) -o testslamch slamch.o lsame.o slamchtst.o + $(LOADER) $(LOADOPTS) -o $@ slamch.o lsame.o slamchtst.o testdlamch: dlamch.o lsame.o dlamchtst.o - $(LOADER) $(LOADOPTS) -o testdlamch dlamch.o lsame.o dlamchtst.o + $(LOADER) $(LOADOPTS) -o $@ dlamch.o lsame.o dlamchtst.o testsecond: second_$(TIMER).o secondtst.o @echo "[INFO] : TIMER value: $(TIMER) (given by make.inc)" - $(LOADER) $(LOADOPTS) -o testsecond second_$(TIMER).o secondtst.o + $(LOADER) $(LOADOPTS) -o $@ second_$(TIMER).o secondtst.o testdsecnd: dsecnd_$(TIMER).o dsecndtst.o @echo "[INFO] : TIMER value: $(TIMER) (given by make.inc)" - $(LOADER) $(LOADOPTS) -o testdsecnd dsecnd_$(TIMER).o dsecndtst.o + $(LOADER) $(LOADOPTS) -o $@ dsecnd_$(TIMER).o dsecndtst.o testieee: tstiee.o - $(LOADER) $(LOADOPTS) -o testieee tstiee.o + $(LOADER) $(LOADOPTS) -o $@ tstiee.o testversion: ilaver.o LAPACK_version.o - $(LOADER) $(LOADOPTS) -o testversion ilaver.o LAPACK_version.o + $(LOADER) $(LOADOPTS) -o $@ ilaver.o LAPACK_version.o clean: rm -f *.o -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< -slamch.o: slamch.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -dlamch.o: dlamch.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +slamch.o: slamch.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dlamch.o: dlamch.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< diff --git a/lapack-netlib/INSTALL/dlamch.f b/lapack-netlib/INSTALL/dlamch.f index 22a1621881..76f875cef6 100644 --- a/lapack-netlib/INSTALL/dlamch.f +++ b/lapack-netlib/INSTALL/dlamch.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* +* * *> \par Purpose: * ============= @@ -51,22 +51,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER CMACH @@ -151,7 +151,7 @@ DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) *> might hold one of these in a register. *> \endverbatim *> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. -*> \date November 2015 +*> \date December 2016 *> \ingroup auxOTHERauxiliary *> *> \param[in] A @@ -167,7 +167,7 @@ DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) *> DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * diff --git a/lapack-netlib/INSTALL/dlamchf77.f b/lapack-netlib/INSTALL/dlamchf77.f index 1e1772c669..3efd215358 100644 --- a/lapack-netlib/INSTALL/dlamchf77.f +++ b/lapack-netlib/INSTALL/dlamchf77.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* +* * *> \par Purpose: * ============= @@ -51,10 +51,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -63,7 +63,7 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary 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..-- * April 2012 @@ -205,7 +205,7 @@ DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) *> SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -418,7 +418,7 @@ SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) *> \endverbatim SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -641,7 +641,7 @@ SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -688,7 +688,7 @@ DOUBLE PRECISION FUNCTION DLAMC3( A, B ) *> SUBROUTINE DLAMC4( EMIN, START, BASE ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -795,7 +795,7 @@ SUBROUTINE DLAMC4( EMIN, START, BASE ) *> SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * diff --git a/lapack-netlib/INSTALL/dlamchtst.f b/lapack-netlib/INSTALL/dlamchtst.f index e8cd557da7..7395688182 100644 --- a/lapack-netlib/INSTALL/dlamchtst.f +++ b/lapack-netlib/INSTALL/dlamchtst.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DLAMCHTST -* +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== PROGRAM DLAMCHTST * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/dsecnd_EXT_ETIME.f b/lapack-netlib/INSTALL/dsecnd_EXT_ETIME.f index f5c0902489..35377643be 100644 --- a/lapack-netlib/INSTALL/dsecnd_EXT_ETIME.f +++ b/lapack-netlib/INSTALL/dsecnd_EXT_ETIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSECND( ) -* +* * *> \par Purpose: * ============= @@ -23,22 +23,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DSECND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * * ===================================================================== diff --git a/lapack-netlib/INSTALL/dsecnd_EXT_ETIME_.f b/lapack-netlib/INSTALL/dsecnd_EXT_ETIME_.f index d473e41f6e..d0a3945787 100644 --- a/lapack-netlib/INSTALL/dsecnd_EXT_ETIME_.f +++ b/lapack-netlib/INSTALL/dsecnd_EXT_ETIME_.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSECND( ) -* +* * *> \par Purpose: * ============= @@ -23,19 +23,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DSECND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * ===================================================================== diff --git a/lapack-netlib/INSTALL/dsecnd_INT_CPU_TIME.f b/lapack-netlib/INSTALL/dsecnd_INT_CPU_TIME.f index 7a049271b2..26f8cb17de 100644 --- a/lapack-netlib/INSTALL/dsecnd_INT_CPU_TIME.f +++ b/lapack-netlib/INSTALL/dsecnd_INT_CPU_TIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSECND( ) -* +* * *> \par Purpose: * ============= @@ -23,35 +23,35 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DSECND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * * .. Local Scalars .. -* +* REAL T -* +* * .. Intrinsic Functions .. -* +* INTRINSIC CPU_TIME -* +* * .. Executable Statements .. * -* +* CALL CPU_TIME( T ) DSECND = T RETURN diff --git a/lapack-netlib/INSTALL/dsecnd_INT_ETIME.f b/lapack-netlib/INSTALL/dsecnd_INT_ETIME.f index a183a92fa5..22df7b442c 100644 --- a/lapack-netlib/INSTALL/dsecnd_INT_ETIME.f +++ b/lapack-netlib/INSTALL/dsecnd_INT_ETIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSECND( ) -* +* * *> \par Purpose: * ============= @@ -23,22 +23,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DSECND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/dsecnd_NONE.f b/lapack-netlib/INSTALL/dsecnd_NONE.f index 61a8dff134..7635a9681c 100644 --- a/lapack-netlib/INSTALL/dsecnd_NONE.f +++ b/lapack-netlib/INSTALL/dsecnd_NONE.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSECND( ) -* +* * *> \par Purpose: * ============= @@ -25,22 +25,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DSECND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/dsecndtst.f b/lapack-netlib/INSTALL/dsecndtst.f index 9da745c8b3..a39e00c951 100644 --- a/lapack-netlib/INSTALL/dsecndtst.f +++ b/lapack-netlib/INSTALL/dsecndtst.f @@ -2,34 +2,34 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DSECNDTST -* +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== PROGRAM DSECNDTST * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/ilaver.f b/lapack-netlib/INSTALL/ilaver.f index c882d03f5e..8578953a37 100644 --- a/lapack-netlib/INSTALL/ilaver.f +++ b/lapack-netlib/INSTALL/ilaver.f @@ -2,8 +2,8 @@ ** * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH -* +* * *> \par Purpose: * ============= @@ -36,29 +36,29 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * ===================================================================== * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 - VERS_MINOR = 6 + VERS_MINOR = 7 VERS_PATCH = 0 * ===================================================================== * diff --git a/lapack-netlib/INSTALL/lsame.f b/lapack-netlib/INSTALL/lsame.f index 315304c3d5..cead2c5c81 100644 --- a/lapack-netlib/INSTALL/lsame.f +++ b/lapack-netlib/INSTALL/lsame.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * .. Scalar Arguments .. * CHARACTER CA, CB * .. -* +* * *> \par Purpose: * ============= @@ -39,22 +39,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== LOGICAL FUNCTION LSAME( CA, CB ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER CA, CB diff --git a/lapack-netlib/INSTALL/lsametst.f b/lapack-netlib/INSTALL/lsametst.f index 525eb160ae..aad0e5836b 100644 --- a/lapack-netlib/INSTALL/lsametst.f +++ b/lapack-netlib/INSTALL/lsametst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,23 +13,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== PROGRAM LSAMETST * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * ===================================================================== * .. Local Scalars .. diff --git a/lapack-netlib/INSTALL/make.inc.ALPHA b/lapack-netlib/INSTALL/make.inc.ALPHA index 33353d2d0e..b5815876e5 100644 --- a/lapack-netlib/INSTALL/make.inc.ALPHA +++ b/lapack-netlib/INSTALL/make.inc.ALPHA @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -65,7 +65,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.HPPA b/lapack-netlib/INSTALL/make.inc.HPPA index 062e1a56b1..869a7ec7e9 100644 --- a/lapack-netlib/INSTALL/make.inc.HPPA +++ b/lapack-netlib/INSTALL/make.inc.HPPA @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -65,7 +65,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.IRIX64 b/lapack-netlib/INSTALL/make.inc.IRIX64 index c8b34e4ed4..68482060ba 100644 --- a/lapack-netlib/INSTALL/make.inc.IRIX64 +++ b/lapack-netlib/INSTALL/make.inc.IRIX64 @@ -5,11 +5,11 @@ #################################################################### # SHELL = /sbin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -68,7 +68,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.O2K b/lapack-netlib/INSTALL/make.inc.O2K index 55b7de2456..ceeccef78d 100644 --- a/lapack-netlib/INSTALL/make.inc.O2K +++ b/lapack-netlib/INSTALL/make.inc.O2K @@ -5,11 +5,11 @@ #################################################################### # SHELL = /sbin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -68,7 +68,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.SGI5 b/lapack-netlib/INSTALL/make.inc.SGI5 index dccfae3339..de55f15212 100644 --- a/lapack-netlib/INSTALL/make.inc.SGI5 +++ b/lapack-netlib/INSTALL/make.inc.SGI5 @@ -5,11 +5,11 @@ #################################################################### # SHELL = /sbin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -65,7 +65,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.SUN4 b/lapack-netlib/INSTALL/make.inc.SUN4 index dd5cfd41e2..d9c68c4c78 100644 --- a/lapack-netlib/INSTALL/make.inc.SUN4 +++ b/lapack-netlib/INSTALL/make.inc.SUN4 @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -65,7 +65,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.SUN4SOL2 b/lapack-netlib/INSTALL/make.inc.SUN4SOL2 index eb71a386d4..d3c78437ea 100644 --- a/lapack-netlib/INSTALL/make.inc.SUN4SOL2 +++ b/lapack-netlib/INSTALL/make.inc.SUN4SOL2 @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 @@ -69,7 +69,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.XLF b/lapack-netlib/INSTALL/make.inc.XLF index 5824e8f155..d7fa4b73bd 100644 --- a/lapack-netlib/INSTALL/make.inc.XLF +++ b/lapack-netlib/INSTALL/make.inc.XLF @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = xlf @@ -66,7 +66,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.gfortran b/lapack-netlib/INSTALL/make.inc.gfortran index 43986435cf..ccd0994f96 100644 --- a/lapack-netlib/INSTALL/make.inc.gfortran +++ b/lapack-netlib/INSTALL/make.inc.gfortran @@ -5,18 +5,18 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # # Note: During a regular execution, LAPACK might create NaN and Inf -# and handle these quantities appropriately. As a consequence, one +# and handle these quantities appropriately. As a consequence, one # should not compile LAPACK with flags such as -ffpe-trap=overflow. # -FORTRAN = gfortran +FORTRAN = gfortran OPTS = -O2 -frecursive DRVOPTS = $(OPTS) NOOPT = -O0 -frecursive @@ -69,7 +69,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.gfortran_debug b/lapack-netlib/INSTALL/make.inc.gfortran_debug index 294758f097..f87b949c45 100644 --- a/lapack-netlib/INSTALL/make.inc.gfortran_debug +++ b/lapack-netlib/INSTALL/make.inc.gfortran_debug @@ -5,7 +5,7 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is @@ -13,7 +13,7 @@ SHELL = /bin/sh # and desired load options for your machine. # # Note: During a regular execution, LAPACK might create NaN and Inf -# and handle these quantities appropriately. As a consequence, one +# and handle these quantities appropriately. As a consequence, one # should not compile LAPACK with flags such as -ffpe-trap=overflow. # FORTRAN = gfortran -fimplicit-none -g -frecursive @@ -32,7 +32,7 @@ LOADOPTS = # For gfortran compiler: SECOND and DSECND will use a call to the INTERNAL FUNCTION ETIME # TIMER = INT_ETIME # If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...) -# SECOND and DSECND will use a call to the Fortran standard INTERNAL FUNCTION CPU_TIME +# SECOND and DSECND will use a call to the Fortran standard INTERNAL FUNCTION CPU_TIME TIMER = INT_CPU_TIME # If neither of this works...you can use the NONE value... In that case, SECOND and DSECND will always return 0 # TIMER = NONE @@ -69,7 +69,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.ifort b/lapack-netlib/INSTALL/make.inc.ifort index 5fca5c47e5..b26e9601cb 100644 --- a/lapack-netlib/INSTALL/make.inc.ifort +++ b/lapack-netlib/INSTALL/make.inc.ifort @@ -1,11 +1,11 @@ #################################################################### # LAPACK make include file. # # LAPACK, Version 3.6.0 # -# November 2015 # +# June 2016 # #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is @@ -13,11 +13,11 @@ SHELL = /bin/sh # and desired load options for your machine. # FORTRAN = ifort -OPTS = -O3 +OPTS = -O3 -fp-model strict -assume protect_parens DRVOPTS = $(OPTS) -NOOPT = -O3 -fltconsistency -fp_port +NOOPT = -O0 -fp-model strict -assume protect_parens LOADER = ifort -LOADOPTS = +LOADOPTS = # # Timer for the SECOND and DSECND routines # @@ -28,7 +28,7 @@ TIMER = EXT_ETIME # For gfortran compiler: SECOND and DSECND will use a call to the INTERNAL FUNCTION ETIME # TIMER = INT_ETIME # If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...) -# SECOND and DSECND will use a call to the Fortran standard INTERNAL FUNCTION CPU_TIME +# SECOND and DSECND will use a call to the Fortran standard INTERNAL FUNCTION CPU_TIME # TIMER = INT_CPU_TIME # If neither of this works...you can use the NONE value... In that case, SECOND and DSECND will always return 0 # TIMER = NONE @@ -65,7 +65,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.pgf95 b/lapack-netlib/INSTALL/make.inc.pgf95 index aaddfa5bd7..595b64c873 100644 --- a/lapack-netlib/INSTALL/make.inc.pgf95 +++ b/lapack-netlib/INSTALL/make.inc.pgf95 @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = pgf95 @@ -65,7 +65,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/make.inc.pghpf b/lapack-netlib/INSTALL/make.inc.pghpf index 782c16d76e..8639530a50 100644 --- a/lapack-netlib/INSTALL/make.inc.pghpf +++ b/lapack-netlib/INSTALL/make.inc.pghpf @@ -5,11 +5,11 @@ #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = pghpf @@ -65,7 +65,7 @@ RANLIB = echo XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack-netlib/INSTALL/second_EXT_ETIME.f b/lapack-netlib/INSTALL/second_EXT_ETIME.f index f47969fd0d..43044cda7c 100644 --- a/lapack-netlib/INSTALL/second_EXT_ETIME.f +++ b/lapack-netlib/INSTALL/second_EXT_ETIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SECOND( ) -* +* * *> \par Purpose: * ============= @@ -23,22 +23,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SECOND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/second_EXT_ETIME_.f b/lapack-netlib/INSTALL/second_EXT_ETIME_.f index 0c45459bb9..cb7869e649 100644 --- a/lapack-netlib/INSTALL/second_EXT_ETIME_.f +++ b/lapack-netlib/INSTALL/second_EXT_ETIME_.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SECOND( ) -* +* * *> \par Purpose: * ============= @@ -23,19 +23,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SECOND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * ===================================================================== diff --git a/lapack-netlib/INSTALL/second_INT_CPU_TIME.f b/lapack-netlib/INSTALL/second_INT_CPU_TIME.f index 1aa0d6eee4..067151adc0 100644 --- a/lapack-netlib/INSTALL/second_INT_CPU_TIME.f +++ b/lapack-netlib/INSTALL/second_INT_CPU_TIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SECOND( ) -* +* * *> \par Purpose: * ============= @@ -23,35 +23,35 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SECOND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * * .. Local Scalars .. -* +* REAL T -* +* * .. Intrinsic Functions .. -* +* INTRINSIC CPU_TIME -* +* * .. Executable Statements .. * -* +* CALL CPU_TIME( T ) SECOND = T RETURN diff --git a/lapack-netlib/INSTALL/second_INT_ETIME.f b/lapack-netlib/INSTALL/second_INT_ETIME.f index 57b7cb8da8..454718db0f 100644 --- a/lapack-netlib/INSTALL/second_INT_ETIME.f +++ b/lapack-netlib/INSTALL/second_INT_ETIME.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SECOND( ) -* +* * *> \par Purpose: * ============= @@ -23,22 +23,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SECOND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/second_NONE.f b/lapack-netlib/INSTALL/second_NONE.f index d3e6d3319b..ea983b6675 100644 --- a/lapack-netlib/INSTALL/second_NONE.f +++ b/lapack-netlib/INSTALL/second_NONE.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SECOND( ) -* +* * *> \par Purpose: * ============= @@ -25,22 +25,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SECOND( ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/secondtst.f b/lapack-netlib/INSTALL/secondtst.f index 4f56b4262b..03f19ab6e1 100644 --- a/lapack-netlib/INSTALL/secondtst.f +++ b/lapack-netlib/INSTALL/secondtst.f @@ -2,30 +2,30 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== PROGRAM SECONDTST * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/slamch.f b/lapack-netlib/INSTALL/slamch.f index 4bffad0eb6..3282fa6a3c 100644 --- a/lapack-netlib/INSTALL/slamch.f +++ b/lapack-netlib/INSTALL/slamch.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * .. Scalar Arguments .. * CHARACTER CMACH * .. -* +* * *> \par Purpose: * ============= @@ -55,22 +55,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== REAL FUNCTION SLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER CMACH @@ -155,7 +155,7 @@ REAL FUNCTION SLAMCH( CMACH ) *> might hold one of these in a register. *> \endverbatim *> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. -*> \date November 2011 +*> \date December 2016 *> \ingroup auxOTHERauxiliary *> *> \param[in] A @@ -170,7 +170,7 @@ REAL FUNCTION SLAMCH( CMACH ) * REAL FUNCTION SLAMC3( A, B ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * diff --git a/lapack-netlib/INSTALL/slamchf77.f b/lapack-netlib/INSTALL/slamchf77.f index 6c419e13bb..fe7cc4e213 100644 --- a/lapack-netlib/INSTALL/slamchf77.f +++ b/lapack-netlib/INSTALL/slamchf77.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * .. Scalar Arguments .. * CHARACTER CMACH * .. -* +* * *> \par Purpose: * ============= @@ -55,10 +55,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -67,7 +67,7 @@ * ===================================================================== REAL FUNCTION SLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary 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..-- * April 2012 @@ -209,7 +209,7 @@ REAL FUNCTION SLAMCH( CMACH ) *> SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -422,7 +422,7 @@ SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) *> \endverbatim SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -645,7 +645,7 @@ SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) REAL FUNCTION SLAMC3( A, B ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -692,7 +692,7 @@ REAL FUNCTION SLAMC3( A, B ) *> SUBROUTINE SLAMC4( EMIN, START, BASE ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * @@ -800,7 +800,7 @@ SUBROUTINE SLAMC4( EMIN, START, BASE ) *> SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.4.1) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2010 * diff --git a/lapack-netlib/INSTALL/slamchtst.f b/lapack-netlib/INSTALL/slamchtst.f index 71133e71fc..da8bc990b0 100644 --- a/lapack-netlib/INSTALL/slamchtst.f +++ b/lapack-netlib/INSTALL/slamchtst.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== PROGRAM SLAMCHTST * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * ===================================================================== * diff --git a/lapack-netlib/INSTALL/tstiee.f b/lapack-netlib/INSTALL/tstiee.f index b6e85de3c4..210abe4394 100644 --- a/lapack-netlib/INSTALL/tstiee.f +++ b/lapack-netlib/INSTALL/tstiee.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERauxiliary * * ===================================================================== PROGRAM TSTIEE * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -81,7 +81,7 @@ PROGRAM TSTIEE INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -569,7 +569,7 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, ILAENV = 2 RETURN * - 600 CONTINUE + 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * @@ -605,7 +605,7 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * ILAENV = 1 IF (ILAENV .EQ. 1) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) + ILAENV = IEEECK( 0, 0.0, 1.0 ) ENDIF RETURN * @@ -615,16 +615,16 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * ILAENV = 1 IF (ILAENV .EQ. 1) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) + ILAENV = IEEECK( 1, 0.0, 1.0 ) ENDIF RETURN * * End of ILAENV * END - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -636,7 +636,7 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * Purpose * ======= * -* IEEECK is called from the ILAENV to verify that Inifinity and +* IEEECK is called from the ILAENV to verify that Inifinity and * possibly NaN arithmetic is safe (i.e. will not trap). * * Arguments: @@ -650,12 +650,12 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * ZERO (input) REAL * Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing +* This is passed to prevent the compiler from optimizing * away this code. * * ONE (input) REAL * Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing +* This is passed to prevent the compiler from optimizing * away this code. * * RETURN VALUE: INTEGER @@ -686,8 +686,8 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) IEEECK = 0 RETURN ENDIF - - NEGINF = ONE / NEGZRO + + NEGINF = ONE / NEGZRO IF ( NEGINF .GE. ZERO ) THEN IEEECK = 0 RETURN @@ -698,20 +698,20 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) IEEECK = 0 RETURN ENDIF - + POSINF = ONE / NEWZRO IF ( POSINF .LE. ONE ) THEN IEEECK = 0 RETURN ENDIF - NEGINF = NEGINF * POSINF + NEGINF = NEGINF * POSINF IF ( NEGINF .GE. ZERO ) THEN IEEECK = 0 RETURN ENDIF - POSINF = POSINF * POSINF + POSINF = POSINF * POSINF IF ( POSINF .LE. ONE ) THEN IEEECK = 0 RETURN @@ -727,11 +727,11 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) NAN1 = POSINF + NEGINF NAN2 = POSINF / NEGINF - + NAN3 = POSINF / POSINF - + NAN4 = POSINF * ZERO - + NAN5 = NEGINF * NEGZRO NAN6 = NAN5 * 0.0 diff --git a/lapack-netlib/LAPACKE/CMakeLists.txt b/lapack-netlib/LAPACKE/CMakeLists.txt index 008f24cd35..2a60a1ea1c 100644 --- a/lapack-netlib/LAPACKE/CMakeLists.txt +++ b/lapack-netlib/LAPACKE/CMakeLists.txt @@ -3,39 +3,36 @@ enable_language(C) set(LAPACK_INSTALL_EXPORT_NAME lapacke-targets) -# Create a header file netlib.h for the routines called in my C programs +# Create a header file lapacke_mangling.h for the routines called in my C programs include(FortranCInterface) -FortranCInterface_HEADER( ${CMAKE_CURRENT_SOURCE_DIR}/include/lapacke_mangling.h - MACRO_NAMESPACE "LAPACK_" - SYMBOL_NAMESPACE "LAPACK_" ) - -# Old way to detect mangling -#include(FortranMangling) -#FORTRAN_MANGLING(CDEFS) -#set(CDEFS ${CDEFS} CACHE STRING "Fortran Mangling" FORCE) -#MESSAGE(STATUS "=========") - -# -------------------------------------------------- -# Compiler Flags -#ADD_DEFINITIONS( "-D${CDEFS}") - -if (WIN32 AND NOT UNIX) - ADD_DEFINITIONS(-DHAVE_LAPACK_CONFIG_H -DLAPACK_COMPLEX_STRUCTURE) - MESSAGE (STATUS "Windows BUILD") -endif (WIN32 AND NOT UNIX) - -get_directory_property( DirDefs COMPILE_DEFINITIONS ) - -include_directories( include ) +## Ensure that the fortran compiler and c compiler specified are compatible +FortranCInterface_VERIFY() +FortranCInterface_HEADER(${LAPACK_BINARY_DIR}/include/lapacke_mangling.h + MACRO_NAMESPACE "LAPACK_" + SYMBOL_NAMESPACE "LAPACK_") +if(NOT FortranCInterface_GLOBAL_FOUND OR NOT FortranCInterface_MODULE_FOUND) + message(WARNING "Reverting to pre-defined include/lapacke_mangling.h") + configure_file(include/lapacke_mangling_with_flags.h.in + ${LAPACK_BINARY_DIR}/include/lapacke_mangling.h) +endif() + +if(WIN32 AND NOT UNIX) + add_definitions(-DHAVE_LAPACK_CONFIG_H -DLAPACK_COMPLEX_STRUCTURE) + message(STATUS "Windows BUILD") +endif() + +get_directory_property(DirDefs COMPILE_DEFINITIONS) + +include_directories(include ${LAPACK_BINARY_DIR}/include) add_subdirectory(include) add_subdirectory(src) add_subdirectory(utils) macro(append_subdir_files variable dirname) -get_directory_property(holder DIRECTORY ${dirname} DEFINITION ${variable}) -foreach(depfile ${holder}) - list(APPEND ${variable} "${dirname}/${depfile}") -endforeach() + get_directory_property(holder DIRECTORY ${dirname} DEFINITION ${variable}) + foreach(depfile ${holder}) + list(APPEND ${variable} "${dirname}/${depfile}") + endforeach() endmacro() append_subdir_files(LAPACKE_INCLUDE "include") @@ -44,32 +41,32 @@ append_subdir_files(SRCX_OBJ "src") append_subdir_files(MATGEN_OBJ "src") append_subdir_files(UTILS_OBJ "utils") -if (USE_XBLAS) - add_library(lapacke ${SRC_OBJ} ${SRCX_OBJ} ${UTILS_OBJ}) - target_link_libraries(lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${XBLAS_LIBRARY}) -else (USE_XBLAS) - if (LAPACKE_WITH_TMG) - add_library(lapacke ${SRC_OBJ} ${MATGEN_OBJ} ${UTILS_OBJ}) - target_link_libraries(lapacke tmglib ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) - else (LAPACKE_WITH_TMG) - add_library(lapacke ${SRC_OBJ} ${UTILS_OBJ}) - target_link_libraries(lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) - endif(LAPACKE_WITH_TMG) -endif(USE_XBLAS) +if(USE_XBLAS) + add_library(lapacke ${SRC_OBJ} ${SRCX_OBJ} ${UTILS_OBJ}) + target_link_libraries(lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${XBLAS_LIBRARY}) +else() + if(LAPACKE_WITH_TMG) + add_library(lapacke ${SRC_OBJ} ${MATGEN_OBJ} ${UTILS_OBJ}) + target_link_libraries(lapacke tmglib ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + else() + add_library(lapacke ${SRC_OBJ} ${UTILS_OBJ}) + target_link_libraries(lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + endif() +endif() lapack_install_library(lapacke) -INSTALL( FILES ${LAPACKE_INCLUDE} DESTINATION include ) +install(FILES ${LAPACKE_INCLUDE} ${LAPACK_BINARY_DIR}/include/lapacke_mangling.h DESTINATION include) if(BUILD_TESTING) - add_subdirectory(example) -endif(BUILD_TESTING) + add_subdirectory(example) +endif() -configure_file(${CMAKE_CURRENT_SOURCE_DIR}/lapacke.pc.in ${CMAKE_CURRENT_BINARY_DIR}/lapacke.pc) - install(FILES +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/lapacke.pc.in ${CMAKE_CURRENT_BINARY_DIR}/lapacke.pc @ONLY) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/lapacke.pc DESTINATION ${PKG_CONFIG_DIR} - ) + ) configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/lapacke-config-version.cmake.in ${LAPACK_BINARY_DIR}/lapacke-config-version.cmake @ONLY) @@ -81,8 +78,8 @@ configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/lapacke-config-install.cmake.in install(FILES ${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/lapacke-config.cmake ${LAPACK_BINARY_DIR}/lapacke-config-version.cmake - DESTINATION lib/cmake/lapacke-${LAPACK_VERSION} + DESTINATION ${LIBRARY_DIR}/cmake/lapacke-${LAPACK_VERSION} ) install(EXPORT lapacke-targets - DESTINATION lib/cmake/lapacke-${LAPACK_VERSION}) + DESTINATION ${LIBRARY_DIR}/cmake/lapacke-${LAPACK_VERSION}) diff --git a/lapack-netlib/LAPACKE/LICENSE b/lapack-netlib/LAPACKE/LICENSE index 8fc2ed9072..2c954cd605 100644 --- a/lapack-netlib/LAPACKE/LICENSE +++ b/lapack-netlib/LAPACKE/LICENSE @@ -1,26 +1,26 @@ - Copyright (c) 2012, Intel Corp. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of Intel Corporation nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF - THE POSSIBILITY OF SUCH DAMAGE. + Copyright (c) 2012, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lapack-netlib/LAPACKE/Makefile b/lapack-netlib/LAPACKE/Makefile index 31ddcd7a5d..f1b07ad5ad 100644 --- a/lapack-netlib/LAPACKE/Makefile +++ b/lapack-netlib/LAPACKE/Makefile @@ -42,16 +42,16 @@ # include ../make.inc -all: lapacke +all: lapacke lapacke: - cd include && cp lapacke_mangling_with_flags.h lapacke_mangling.h + cd include && cp lapacke_mangling_with_flags.h.in lapacke_mangling.h cd src && $(MAKE) cd utils && $(MAKE) lapacke_example: cd example && $(MAKE) - + clean: cleanlib cleanlib: @@ -61,4 +61,3 @@ cleanlib: cleanall: clean rm -f $(LAPACKE) cd example && $(MAKE) clean - diff --git a/lapack-netlib/LAPACKE/README b/lapack-netlib/LAPACKE/README index 343de50d11..205ce6c3a0 100644 --- a/lapack-netlib/LAPACKE/README +++ b/lapack-netlib/LAPACKE/README @@ -6,25 +6,25 @@ Introduction ------------------------------------------------------------------------------- This library is a part of reference implementation for the C interface to -LAPACK project according to the specifications described at the forum for +LAPACK project according to the specifications described at the forum for the Intel(R) Math Kernel Library (Intel(R) MKL): http://software.intel.com/en-us/forums/showthread.php?t=61234 This implementation provides a native C interface to LAPACK routines available -at www.netlib.org/lapack to facilitate usage of LAPACK functionality +at www.netlib.org/lapack to facilitate usage of LAPACK functionality for C programmers. This implementation introduces: -- row-major and column-major matrix layout controlled by the first function +- row-major and column-major matrix layout controlled by the first function parameter; -- an implementation with working arrays (middle-level interface) as well as +- an implementation with working arrays (middle-level interface) as well as without working arrays (high-level interface); - input scalars passed by value; - error code as a return value instead of the INFO parameter. -This implementation supports both the ILP64 and LP64 programming models, +This implementation supports both the ILP64 and LP64 programming models, and different complex type styles: structure, C99. -This implementation includes interfaces for the LAPACK-3.2.1 Driver and +This implementation includes interfaces for the LAPACK-3.2.1 Driver and Computational routines only. ------------------------------------------------------------------------------- @@ -42,12 +42,12 @@ Installation ------------------------------------------------------------------------------- The reference code for the C interface to LAPACK is built similarly to the -Basic Linear Algebra Subprograms (BLAS) and LAPACK. The build system produces +Basic Linear Algebra Subprograms (BLAS) and LAPACK. The build system produces a static binary lapacke.a. You need to provide a make.inc file in the top directory that defines the compiler, compiler flags, names for binaries to be created/linked to. You may -choose the appropriate LP64/ILP64 model, convenient complex type style, +choose the appropriate LP64/ILP64 model, convenient complex type style, LAPACKE name pattern, and/or redefine system malloc/free in make.inc. Several examples of make.inc are provided. @@ -75,7 +75,7 @@ typedef struct { double real, imag; } _lapack_complex_double; #define lapack_complex_float _lapack_complex_float #define lapack_complex_double _lapack_complex_double -3) C++ complex types (set by enabling in the configuration file): +3) C++ complex types (set by enabling in the configuration file): -DHAVE_LAPACK_CONFIG_H -DLAPACK_COMPLEX_CPP #define lapack_complex_float std::complex @@ -87,9 +87,9 @@ You have to compile the interface with C++ compiler with C++ types. -DLAPACK_COMPLEX_CUSTOM To use custom complex types, you need to: -- Define lapack_complex_float/lapack_complex_double types on your own. +- Define lapack_complex_float/lapack_complex_double types on your own. - Optionally define lapack_make_complex_float/lapack_make_complex_double_real - functions if you want to build the testing suite supplied. Use these + functions if you want to build the testing suite supplied. Use these functions for the testing system. Their purpose is to make a complex value of a real part re, imaginary part im. The prototypes are as follows: @@ -99,7 +99,7 @@ To use custom complex types, you need to: ------------------------------------------------------------------------------- Choosing ILP64 Data Model ------------------------------------------------------------------------------- -To choose ILP64 data model (set by enabling in the configuration file), use the +To choose ILP64 data model (set by enabling in the configuration file), use the following options: -DHAVE_LAPACK_CONFIG_H -DLAPACK_ILP64 @@ -108,7 +108,7 @@ following options: Using Predicate Functions ------------------------------------------------------------------------------- -The functions +The functions lapacke_?gees/lapacke_?gees_work lapacke_?geesx/lapacke_?geesx_work @@ -139,8 +139,8 @@ The row-major matrices are transposed on entry to and on exit from the LAPACK routine, if needed. Top-level interfaces additionally allocate/deallocate working space on entry to and on exit from the LAPACK routine. -Because of possible additional transpositions, a routine called with -this interface may require more memory space and run slower than the +Because of possible additional transpositions, a routine called with +this interface may require more memory space and run slower than the corresponding LAPACK routine. ------------------------------------------------------------------------------- @@ -185,7 +185,7 @@ numbers differentiate features within each processor family, not across different processor families. See http://www.intel.com/products/processor_number for details. -This document contains information on products in the design phase of +This document contains information on products in the design phase of development. BunnyPeople, Celeron, Celeron Inside, Centrino, Centrino Atom, diff --git a/lapack-netlib/LAPACKE/cmake/lapacke-config-build.cmake.in b/lapack-netlib/LAPACKE/cmake/lapacke-config-build.cmake.in index eaf71f818a..6900f45335 100644 --- a/lapack-netlib/LAPACKE/cmake/lapacke-config-build.cmake.in +++ b/lapack-netlib/LAPACKE/cmake/lapacke-config-build.cmake.in @@ -7,8 +7,8 @@ if(NOT TARGET lapacke) include("@LAPACK_BINARY_DIR@/lapack-targets.cmake") endif() -# Report lapacke header search locations. -set(LAPACKE_INCLUDE_DIRS "@LAPACK_SOURCE_DIR@/lapacke/include") +# Report lapacke header search locations from build tree. +set(LAPACKE_INCLUDE_DIRS "@LAPACK_BINARY_DIR@/include") # Report lapacke libraries. set(LAPACKE_LIBRARIES lapacke) diff --git a/lapack-netlib/LAPACKE/cmake/lapacke-config-install.cmake.in b/lapack-netlib/LAPACKE/cmake/lapacke-config-install.cmake.in index 2b6b3f0c86..9b2452b80f 100644 --- a/lapack-netlib/LAPACKE/cmake/lapacke-config-install.cmake.in +++ b/lapack-netlib/LAPACKE/cmake/lapacke-config-install.cmake.in @@ -1,11 +1,11 @@ -# Compute locations from /lib/cmake/lapacke-/.cmake +# Compute locations from /@{LIBRARY_DIR@/cmake/lapacke-/.cmake get_filename_component(_LAPACKE_SELF_DIR "${CMAKE_CURRENT_LIST_FILE}" PATH) get_filename_component(_LAPACKE_PREFIX "${_LAPACKE_SELF_DIR}" PATH) get_filename_component(_LAPACKE_PREFIX "${_LAPACKE_PREFIX}" PATH) get_filename_component(_LAPACKE_PREFIX "${_LAPACKE_PREFIX}" PATH) # Load the LAPACK package with which we were built. -set(LAPACK_DIR "${_LAPACKE_PREFIX}/lib/cmake/lapack-@LAPACK_VERSION@") +set(LAPACK_DIR "${_LAPACKE_PREFIX}/@{LIBRARY_DIR@/cmake/lapack-@LAPACK_VERSION@") find_package(LAPACK NO_MODULE) # Load lapacke targets from the install tree. diff --git a/lapack-netlib/LAPACKE/example/Makefile b/lapack-netlib/LAPACKE/example/Makefile index 52c46707f4..80968e8c95 100644 --- a/lapack-netlib/LAPACKE/example/Makefile +++ b/lapack-netlib/LAPACKE/example/Makefile @@ -3,33 +3,29 @@ include ../../make.inc all: xexample_DGESV_rowmajor \ xexample_DGESV_colmajor \ xexample_DGELS_rowmajor \ - xexample_DGELS_colmajor + xexample_DGELS_colmajor -LIBRAIRIES= ../../$(LAPACKELIB) ../../$(LAPACKLIB) $(BLASLIB) +LIBRARIES = ../../$(LAPACKELIB) ../../$(LAPACKLIB) $(BLASLIB) # Double Precision Examples -xexample_DGESV_rowmajor: example_DGESV_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES) - $(LOADER) $(LOADOPTS) example_DGESV_rowmajor.o lapacke_example_aux.o \ - $(LIBRAIRIES) -o $@ +xexample_DGESV_rowmajor: example_DGESV_rowmajor.o lapacke_example_aux.o $(LIBRARIES) + $(LOADER) $(LOADOPTS) -o $@ example_DGESV_rowmajor.o lapacke_example_aux.o $(LIBRARIES) ./$@ -xexample_DGESV_colmajor: example_DGESV_colmajor.o lapacke_example_aux.o $(LIBRAIRIES) - $(LOADER) $(LOADOPTS) example_DGESV_colmajor.o lapacke_example_aux.o \ - $(LIBRAIRIES) -o $@ +xexample_DGESV_colmajor: example_DGESV_colmajor.o lapacke_example_aux.o $(LIBRARIES) + $(LOADER) $(LOADOPTS) -o $@ example_DGESV_colmajor.o lapacke_example_aux.o $(LIBRARIES) ./$@ -xexample_DGELS_rowmajor: example_DGELS_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES) - $(LOADER) $(LOADOPTS) example_DGELS_rowmajor.o lapacke_example_aux.o \ - $(LIBRAIRIES) -o $@ +xexample_DGELS_rowmajor: example_DGELS_rowmajor.o lapacke_example_aux.o $(LIBRARIES) + $(LOADER) $(LOADOPTS) -o $@ example_DGELS_rowmajor.o lapacke_example_aux.o $(LIBRARIES) ./$@ -xexample_DGELS_colmajor: example_DGELS_colmajor.o lapacke_example_aux.o $(LIBRAIRIES) - $(LOADER) $(LOADOPTS) example_DGELS_colmajor.o lapacke_example_aux.o \ - $(LIBRAIRIES) -o $@ +xexample_DGELS_colmajor: example_DGELS_colmajor.o lapacke_example_aux.o $(LIBRARIES) + $(LOADER) $(LOADOPTS) -o $@ example_DGELS_colmajor.o lapacke_example_aux.o $(LIBRARIES) ./$@ .c.o: - $(CC) -c $(CFLAGS) -I. -I ../include -o $@ $< + $(CC) $(CFLAGS) -I. -I../include -c -o $@ $< clean: rm -f *.o x* diff --git a/lapack-netlib/LAPACKE/example/example_DGELS_colmajor.c b/lapack-netlib/LAPACKE/example/example_DGELS_colmajor.c index 5fa04bb417..b2ea2a93e6 100644 --- a/lapack-netlib/LAPACKE/example/example_DGELS_colmajor.c +++ b/lapack-netlib/LAPACKE/example/example_DGELS_colmajor.c @@ -1,16 +1,16 @@ /* LAPACKE Example : Calling DGELS using col-major layout ===================================================== - + The program computes the solution to the system of linear equations with a square matrix A and multiple right-hand sides B, where A is the coefficient matrix and b is the right-hand side matrix: - + Description =========== - - In this example, we wish solve the least squares problem min_x || B - Ax || + + In this example, we wish solve the least squares problem min_x || B - Ax || for two right-hand sides using the LAPACK routine DGELS. For input we will use the 5-by-3 matrix @@ -28,11 +28,11 @@ ( 18 16 ) We will first store the input matrix as a static C two-dimensional array, which is stored in col-major layout, and let LAPACKE handle the work space - array allocation. The LAPACK base name for this function is gels, and we + array allocation. The LAPACK base name for this function is gels, and we will use double precision (d), so the LAPACKE function name is LAPACKE_dgels. lda=5 and ldb=5. The output for each right hand side is stored in b as - consecutive vectors of length 3. The correct answer for this problem is + consecutive vectors of length 3. The correct answer for this problem is the 3-by-2 matrix ( 2 1 ) @@ -49,10 +49,10 @@ LAPACKE_dgels (col-major, high-level) Example Program Results - -- LAPACKE Example routine (version 3.6.0) -- + -- LAPACKE Example 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..-- - November 2015 + December 2016 */ /* Calling DGELS using col-major layout */ @@ -82,7 +82,7 @@ int main (int argc, const char * argv[]) /* Print Right Rand Side */ print_matrix_colmajor( "Right Hand Side b", n, nrhs, *b, ldb ); printf( "\n" ); - + /* Executable statements */ printf( "LAPACKE_dgels (col-major, high-level) Example Program Results\n" ); /* Solve least squares problem*/ diff --git a/lapack-netlib/LAPACKE/example/example_DGELS_rowmajor.c b/lapack-netlib/LAPACKE/example/example_DGELS_rowmajor.c index a5d02e2e64..1c027f8623 100644 --- a/lapack-netlib/LAPACKE/example/example_DGELS_rowmajor.c +++ b/lapack-netlib/LAPACKE/example/example_DGELS_rowmajor.c @@ -1,16 +1,16 @@ /* LAPACKE Example : Calling DGELS using row-major layout ===================================================== - + The program computes the solution to the system of linear equations with a square matrix A and multiple right-hand sides B, where A is the coefficient matrix and b is the right-hand side matrix: - + Description =========== - - In this example, we wish solve the least squares problem min_x || B - Ax || + + In this example, we wish solve the least squares problem min_x || B - Ax || for two right-hand sides using the LAPACK routine DGELS. For input we will use the 5-by-3 matrix @@ -28,11 +28,11 @@ ( 18 16 ) We will first store the input matrix as a static C two-dimensional array, which is stored in row-major layout, and let LAPACKE handle the work space - array allocation. The LAPACK base name for this function is gels, and we + array allocation. The LAPACK base name for this function is gels, and we will use double precision (d), so the LAPACKE function name is LAPACKE_dgels. thus lda=3 and ldb=2. The output for each right hand side is stored in b as - consecutive vectors of length 3. The correct answer for this problem is + consecutive vectors of length 3. The correct answer for this problem is the 3-by-2 matrix ( 2 1 ) @@ -49,10 +49,10 @@ LAPACKE_dgels (row-major, high-level) Example Program Results - -- LAPACKE Example routine (version 3.6.0) -- + -- LAPACKE Example 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..-- - November 2015 + December 2016 */ /* Calling DGELS using row-major layout */ @@ -69,7 +69,6 @@ int main (int argc, const char * argv[]) double A[5][3] = {1,1,1,2,3,4,3,5,2,4,2,5,5,4,3}; double b[5][2] = {-10,-3,12,14,14,12,16,16,18,16}; lapack_int info,m,n,lda,ldb,nrhs; - int i,j; /* Initialization */ m = 5; @@ -83,7 +82,7 @@ int main (int argc, const char * argv[]) /* Print Right Rand Side */ print_matrix_rowmajor( "Right Hand Side b", n, nrhs, *b, ldb ); printf( "\n" ); - + /* Executable statements */ printf( "LAPACKE_dgels (row-major, high-level) Example Program Results\n" ); /* Solve least squares problem*/ diff --git a/lapack-netlib/LAPACKE/example/example_DGESV_colmajor.c b/lapack-netlib/LAPACKE/example/example_DGESV_colmajor.c index cc3cd8b343..c8bdd6e4e2 100644 --- a/lapack-netlib/LAPACKE/example/example_DGESV_colmajor.c +++ b/lapack-netlib/LAPACKE/example/example_DGESV_colmajor.c @@ -1,23 +1,23 @@ /* LAPACKE_dgesv Example ===================== - + The program computes the solution to the system of linear equations with a square matrix A and multiple right-hand sides B, where A is the coefficient matrix and b is the right-hand side matrix: - + Description =========== - - The routine solves for X the system of linear equations A*X = B, - where A is an n-by-n matrix, the columns of matrix B are individual - right-hand sides, and the columns of X are the corresponding + + The routine solves for X the system of linear equations A*X = B, + where A is an n-by-n matrix, the columns of matrix B are individual + right-hand sides, and the columns of X are the corresponding solutions. - The LU decomposition with partial pivoting and row interchanges is - used to factor A as A = P*L*U, where P is a permutation matrix, L - is unit lower triangular, and U is upper triangular. The factored + The LU decomposition with partial pivoting and row interchanges is + used to factor A as A = P*L*U, where P is a permutation matrix, L + is unit lower triangular, and U is upper triangular. The factored form of A is then used to solve the system of equations A*X = B. LAPACKE Interface @@ -25,10 +25,10 @@ LAPACKE_dgesv (col-major, high-level) Example Program Results - -- LAPACKE Example routine (version 3.6.0) -- + -- LAPACKE Example 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..-- - November 2015 + December 2016 */ /* Includes */ @@ -47,22 +47,22 @@ int main(int argc, char **argv) { /* Local arrays */ double *A, *b; lapack_int *ipiv; - + /* Default Value */ n = 5; nrhs = 1; /* Arguments */ for( i = 1; i < argc; i++ ) { - if( strcmp( argv[i], "-n" ) == 0 ) { + if( strcmp( argv[i], "-n" ) == 0 ) { n = atoi(argv[i+1]); i++; } - if( strcmp( argv[i], "-nrhs" ) == 0 ) { + if( strcmp( argv[i], "-nrhs" ) == 0 ) { nrhs = atoi(argv[i+1]); i++; - } + } } - + /* Initialization */ lda=n, ldb=n; A = (double *)malloc(n*n*sizeof(double)) ; @@ -75,7 +75,7 @@ int main(int argc, char **argv) { for( i = 0; i < n; i++ ) { for( j = 0; j < n; j++ ) A[i+j*lda] = ((double) rand()) / ((double) RAND_MAX) - 0.5; } - + for(i=0;i 0 ) { printf( "The diagonal element of the triangular factor of A,\n" ); diff --git a/lapack-netlib/LAPACKE/example/example_DGESV_rowmajor.c b/lapack-netlib/LAPACKE/example/example_DGESV_rowmajor.c index c37983829a..35bdcbcae2 100644 --- a/lapack-netlib/LAPACKE/example/example_DGESV_rowmajor.c +++ b/lapack-netlib/LAPACKE/example/example_DGESV_rowmajor.c @@ -1,23 +1,23 @@ /* LAPACKE_dgesv Example ===================== - + The program computes the solution to the system of linear equations with a square matrix A and multiple right-hand sides B, where A is the coefficient matrix and b is the right-hand side matrix: - + Description =========== - - The routine solves for X the system of linear equations A*X = B, - where A is an n-by-n matrix, the columns of matrix B are individual - right-hand sides, and the columns of X are the corresponding + + The routine solves for X the system of linear equations A*X = B, + where A is an n-by-n matrix, the columns of matrix B are individual + right-hand sides, and the columns of X are the corresponding solutions. - The LU decomposition with partial pivoting and row interchanges is - used to factor A as A = P*L*U, where P is a permutation matrix, L - is unit lower triangular, and U is upper triangular. The factored + The LU decomposition with partial pivoting and row interchanges is + used to factor A as A = P*L*U, where P is a permutation matrix, L + is unit lower triangular, and U is upper triangular. The factored form of A is then used to solve the system of equations A*X = B. LAPACKE Interface @@ -25,10 +25,10 @@ LAPACKE_dgesv (row-major, high-level) Example Program Results - -- LAPACKE Example routine (version 3.6.0) -- + -- LAPACKE Example 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..-- - November 2015 + December 2016 */ #include @@ -46,22 +46,22 @@ int main(int argc, char **argv) { /* Local arrays */ double *A, *b; lapack_int *ipiv; - + /* Default Value */ n = 5; nrhs = 1; /* Arguments */ for( i = 1; i < argc; i++ ) { - if( strcmp( argv[i], "-n" ) == 0 ) { + if( strcmp( argv[i], "-n" ) == 0 ) { n = atoi(argv[i+1]); i++; } - if( strcmp( argv[i], "-nrhs" ) == 0 ) { + if( strcmp( argv[i], "-nrhs" ) == 0 ) { nrhs = atoi(argv[i+1]); i++; - } + } } - + /* Initialization */ lda=n, ldb=nrhs; A = (double *)malloc(n*n*sizeof(double)) ; diff --git a/lapack-netlib/LAPACKE/example/example_user.c b/lapack-netlib/LAPACKE/example/example_user.c index c481fa7058..a33c7de613 100644 --- a/lapack-netlib/LAPACKE/example/example_user.c +++ b/lapack-netlib/LAPACKE/example/example_user.c @@ -1,17 +1,17 @@ #include #include #include "lapacke.h" - + /* Auxiliary routines prototypes */ extern void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ); extern void print_int_vector( char* desc, lapack_int n, lapack_int* a ); - + /* Parameters */ #define N 5 #define NRHS 3 #define LDA N #define LDB NRHS - + /* Main program */ int main() { /* Locals */ @@ -32,14 +32,14 @@ int main() { -7.57, 1.75, -8.61, -3.03, 2.86, 8.99 }; - + double aNorm; double rcond; char ONE_NORM = '1'; lapack_int NROWS = n; lapack_int NCOLS = n; lapack_int LEADING_DIMENSION_A = n; - + /* Print Entry Matrix */ print_matrix( "Entry Matrix A", n, n, a, lda ); /* Print Right Rand Side */ @@ -69,13 +69,13 @@ int main() { printf( "Unrecognized value of INFO = %d\n", info ); exit( 1 ); } - + /* Print solution */ printf("LAPACKE_dlange / One-norm of A = %lf\n", aNorm); printf("LAPACKE_dgecon / RCOND of A = %f\n", rcond); exit( 0 ); } /* End of LAPACKE_dgesv Example */ - + /* Auxiliary routine: printing a matrix */ void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ) { lapack_int i, j; @@ -85,7 +85,7 @@ void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int printf( "\n" ); } } - + /* Auxiliary routine: printing a vector of integers */ void print_int_vector( char* desc, lapack_int n, lapack_int* a ) { lapack_int j; @@ -93,5 +93,5 @@ void print_int_vector( char* desc, lapack_int n, lapack_int* a ) { for( j = 0; j < n; j++ ) printf( " %6i", a[j] ); printf( "\n" ); } - - + + diff --git a/lapack-netlib/LAPACKE/example/lapacke_example_aux.c b/lapack-netlib/LAPACKE/example/lapacke_example_aux.c index dfd60eb1d9..9b72eb6209 100644 --- a/lapack-netlib/LAPACKE/example/lapacke_example_aux.c +++ b/lapack-netlib/LAPACKE/example/lapacke_example_aux.c @@ -5,7 +5,7 @@ void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) { lapack_int i, j; printf( "\n %s\n", desc ); - + for( i = 0; i < m; i++ ) { for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i*ldm+j] ); printf( "\n" ); @@ -17,7 +17,7 @@ void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, void print_matrix_colmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) { lapack_int i, j; printf( "\n %s\n", desc ); - + for( i = 0; i < m; i++ ) { for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i+j*ldm] ); printf( "\n" ); diff --git a/lapack-netlib/LAPACKE/include/CMakeLists.txt b/lapack-netlib/LAPACKE/include/CMakeLists.txt index 80b269fb6d..4c30c0501d 100644 --- a/lapack-netlib/LAPACKE/include/CMakeLists.txt +++ b/lapack-netlib/LAPACKE/include/CMakeLists.txt @@ -1,3 +1,3 @@ -SET (LAPACKE_INCLUDE lapacke.h lapacke_config.h lapacke_utils.h lapacke_mangling.h) +set(LAPACKE_INCLUDE lapacke.h lapacke_config.h lapacke_utils.h) file(COPY ${LAPACKE_INCLUDE} DESTINATION ${LAPACK_BINARY_DIR}/include) diff --git a/lapack-netlib/LAPACKE/include/lapacke.h b/lapack-netlib/LAPACKE/include/lapacke.h index 03c33213ee..cacdef9627 100644 --- a/lapack-netlib/LAPACKE/include/lapacke.h +++ b/lapack-netlib/LAPACKE/include/lapacke.h @@ -180,14 +180,14 @@ lapack_int LAPACKE_zbdsqr( int matrix_layout, char uplo, lapack_int n, lapack_int ldc ); lapack_int LAPACKE_sbdsvdx( int matrix_layout, char uplo, char jobz, char range, lapack_int n, float* d, float* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* z, lapack_int ldz, lapack_int* superb ); lapack_int LAPACKE_dbdsvdx( int matrix_layout, char uplo, char jobz, char range, lapack_int n, double* d, double* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* z, lapack_int ldz, lapack_int* superb ); lapack_int LAPACKE_sdisna( char job, lapack_int m, lapack_int n, const float* d, @@ -999,29 +999,29 @@ lapack_int LAPACKE_zgesvd( int matrix_layout, char jobu, char jobvt, lapack_int LAPACKE_sgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* u, lapack_int ldu, float* vt, lapack_int ldvt, lapack_int* superb ); lapack_int LAPACKE_dgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* u, lapack_int ldu, double* vt, lapack_int ldvt, lapack_int* superb ); lapack_int LAPACKE_cgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, lapack_complex_float* u, lapack_int ldu, lapack_complex_float* vt, lapack_int ldvt, lapack_int* superb ); lapack_int LAPACKE_zgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, lapack_complex_double* u, lapack_int ldu, lapack_complex_double* vt, lapack_int ldvt, lapack_int* superb ); @@ -2499,20 +2499,20 @@ lapack_int LAPACKE_zlarnv( lapack_int idist, lapack_int* iseed, lapack_int n, lapack_complex_double* x ); lapack_int LAPACKE_slascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, float* a, lapack_int lda ); lapack_int LAPACKE_dlascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, double* a, lapack_int lda ); lapack_int LAPACKE_clascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, lapack_complex_float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, lapack_complex_float* a, lapack_int lda ); lapack_int LAPACKE_zlascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, lapack_complex_double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, lapack_complex_double* a, lapack_int lda ); lapack_int LAPACKE_slaset( int matrix_layout, char uplo, lapack_int m, @@ -4738,17 +4738,17 @@ lapack_int LAPACKE_dbdsdc_work( int matrix_layout, char uplo, char compq, lapack_int* iwork ); lapack_int LAPACKE_sbdsvdx_work( int matrix_layout, char uplo, char jobz, char range, - lapack_int n, float* d, float* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, - float* s, float* z, lapack_int ldz, - float* work, lapack_int* iwork ); + lapack_int n, float* d, float* e, + float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, + float* s, float* z, lapack_int ldz, + float* work, lapack_int* iwork ); lapack_int LAPACKE_dbdsvdx_work( int matrix_layout, char uplo, char jobz, char range, - lapack_int n, double* d, double* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, - double* s, double* z, lapack_int ldz, - double* work, lapack_int* iwork ); + lapack_int n, double* d, double* e, + double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, + double* s, double* z, lapack_int ldz, + double* work, lapack_int* iwork ); lapack_int LAPACKE_sbdsqr_work( int matrix_layout, char uplo, lapack_int n, lapack_int ncvt, lapack_int nru, lapack_int ncc, @@ -5760,35 +5760,35 @@ lapack_int LAPACKE_zgesvd_work( int matrix_layout, char jobu, char jobvt, lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* u, lapack_int ldu, - float* vt, lapack_int ldvt, + float* vt, lapack_int ldvt, float* work, lapack_int lwork, lapack_int* iwork ); lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* u, lapack_int ldu, - double* vt, lapack_int ldvt, + double* vt, lapack_int ldvt, double* work, lapack_int lwork, lapack_int* iwork ); lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, lapack_complex_float* u, lapack_int ldu, - lapack_complex_float* vt, lapack_int ldvt, + lapack_complex_float* vt, lapack_int ldvt, lapack_complex_float* work, lapack_int lwork, float* rwork, lapack_int* iwork ); lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, lapack_complex_double* u, lapack_int ldu, - lapack_complex_double* vt, lapack_int ldvt, - lapack_complex_double* work, lapack_int lwork, + lapack_complex_double* vt, lapack_int ldvt, + lapack_complex_double* work, lapack_int lwork, double* rwork, lapack_int* iwork ); - + lapack_int LAPACKE_sgesvj_work( int matrix_layout, char joba, char jobu, char jobv, lapack_int m, lapack_int n, float* a, lapack_int lda, float* sva, lapack_int mv, @@ -7695,22 +7695,22 @@ lapack_int LAPACKE_zlarnv_work( lapack_int idist, lapack_int* iseed, lapack_int LAPACKE_slascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, float* a, lapack_int lda ); lapack_int LAPACKE_dlascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, double* a, lapack_int lda ); lapack_int LAPACKE_clascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, lapack_complex_float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, lapack_complex_float* a, lapack_int lda ); lapack_int LAPACKE_zlascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, lapack_complex_double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, lapack_complex_double* a, lapack_int lda ); - + lapack_int LAPACKE_slaset_work( int matrix_layout, char uplo, lapack_int m, lapack_int n, float alpha, float beta, float* a, lapack_int lda ); @@ -8679,16 +8679,16 @@ lapack_int LAPACKE_ssbevx_work( int matrix_layout, char jobz, char range, lapack_int ldq, float vl, float vu, lapack_int il, lapack_int iu, float abstol, lapack_int* m, float* w, float* z, - lapack_int ldz, float* work, lapack_int* iwork, - lapack_int* ifail ); + lapack_int ldz, float* work, + lapack_int* iwork, lapack_int* ifail ); lapack_int LAPACKE_dsbevx_work( int matrix_layout, char jobz, char range, char uplo, lapack_int n, lapack_int kd, double* ab, lapack_int ldab, double* q, lapack_int ldq, double vl, double vu, lapack_int il, lapack_int iu, double abstol, lapack_int* m, double* w, double* z, - lapack_int ldz, double* work, lapack_int* iwork, - lapack_int* ifail ); + lapack_int ldz, double* work, + lapack_int* iwork, lapack_int* ifail ); lapack_int LAPACKE_ssbgst_work( int matrix_layout, char vect, char uplo, lapack_int n, lapack_int ka, lapack_int kb, @@ -10472,11 +10472,11 @@ lapack_int LAPACKE_cbbcsd_work( int matrix_layout, char jobu1, char jobu2, float* b22d, float* b22e, float* rwork, lapack_int lrwork ); lapack_int LAPACKE_cheswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_cheswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_chetri2( int matrix_layout, char uplo, lapack_int n, lapack_complex_float* a, lapack_int lda, const lapack_int* ipiv ); @@ -10502,17 +10502,17 @@ lapack_int LAPACKE_chetrs2_work( int matrix_layout, char uplo, lapack_int n, lapack_complex_float* work ); lapack_int LAPACKE_csyconv( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_float* a, lapack_int lda, - const lapack_int* ipiv, lapack_complex_float* work ); + const lapack_int* ipiv, lapack_complex_float* e ); lapack_int LAPACKE_csyconv_work( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_float* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_float* work ); + lapack_complex_float* e ); lapack_int LAPACKE_csyswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_csyswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_csytri2( int matrix_layout, char uplo, lapack_int n, lapack_complex_float* a, lapack_int lda, const lapack_int* ipiv ); @@ -10590,17 +10590,17 @@ lapack_int LAPACKE_cuncsd2by1( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_float* x11, lapack_int ldx11, lapack_complex_float* x21, lapack_int ldx21, - lapack_complex_float* theta, lapack_complex_float* u1, + float* theta, lapack_complex_float* u1, lapack_int ldu1, lapack_complex_float* u2, lapack_int ldu2, lapack_complex_float* v1t, lapack_int ldv1t ); lapack_int LAPACKE_cuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_float* x11, lapack_int ldx11, lapack_complex_float* x21, lapack_int ldx21, - lapack_complex_float* theta, lapack_complex_float* u1, - lapack_int ldu1, lapack_complex_float* u2, + float* theta, lapack_complex_float* u1, + lapack_int ldu1, lapack_complex_float* u2, lapack_int ldu2, lapack_complex_float* v1t, - lapack_int ldv1t, lapack_complex_float* work, + lapack_int ldv1t, lapack_complex_float* work, lapack_int lwork, float* rwork, lapack_int lrwork, lapack_int* iwork ); lapack_int LAPACKE_dbbcsd( int matrix_layout, char jobu1, char jobu2, @@ -10669,20 +10669,22 @@ lapack_int LAPACKE_dorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, lapack_int ldu2, double* v1t, lapack_int ldv1t, double* work, lapack_int lwork, lapack_int* iwork ); lapack_int LAPACKE_dsyconv( int matrix_layout, char uplo, char way, lapack_int n, - double* a, lapack_int lda, const lapack_int* ipiv, double* work); + double* a, lapack_int lda, const lapack_int* ipiv, double* e); lapack_int LAPACKE_dsyconv_work( int matrix_layout, char uplo, char way, lapack_int n, double* a, lapack_int lda, - const lapack_int* ipiv, double* work ); + const lapack_int* ipiv, double* e ); lapack_int LAPACKE_dsyswapr( int matrix_layout, char uplo, lapack_int n, - double* a, lapack_int i1, lapack_int i2 ); + double* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_dsyswapr_work( int matrix_layout, char uplo, lapack_int n, - double* a, lapack_int i1, lapack_int i2 ); + double* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_dsytri2( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv ); lapack_int LAPACKE_dsytri2_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_double* work, lapack_int lwork ); + double* work, lapack_int lwork ); lapack_int LAPACKE_dsytri2x( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, lapack_int nb ); @@ -10762,20 +10764,22 @@ lapack_int LAPACKE_sorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, lapack_int ldu2, float* v1t, lapack_int ldv1t, float* work, lapack_int lwork, lapack_int* iwork ); lapack_int LAPACKE_ssyconv( int matrix_layout, char uplo, char way, lapack_int n, - float* a, lapack_int lda, const lapack_int* ipiv, float* work ); + float* a, lapack_int lda, const lapack_int* ipiv, float* e ); lapack_int LAPACKE_ssyconv_work( int matrix_layout, char uplo, char way, lapack_int n, float* a, lapack_int lda, - const lapack_int* ipiv, float* work ); + const lapack_int* ipiv, float* e ); lapack_int LAPACKE_ssyswapr( int matrix_layout, char uplo, lapack_int n, - float* a, lapack_int i1, lapack_int i2 ); + float* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_ssyswapr_work( int matrix_layout, char uplo, lapack_int n, - float* a, lapack_int i1, lapack_int i2 ); + float* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_ssytri2( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv ); lapack_int LAPACKE_ssytri2_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_float* work, lapack_int lwork ); + float* work, lapack_int lwork ); lapack_int LAPACKE_ssytri2x( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, lapack_int nb ); @@ -10813,11 +10817,11 @@ lapack_int LAPACKE_zbbcsd_work( int matrix_layout, char jobu1, char jobu2, double* b22d, double* b22e, double* rwork, lapack_int lrwork ); lapack_int LAPACKE_zheswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_zheswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_zhetri2( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv ); @@ -10843,17 +10847,17 @@ lapack_int LAPACKE_zhetrs2_work( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* work ); lapack_int LAPACKE_zsyconv( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_double* a, lapack_int lda, - const lapack_int* ipiv, lapack_complex_double* work ); + const lapack_int* ipiv, lapack_complex_double* e ); lapack_int LAPACKE_zsyconv_work( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_double* work ); + lapack_complex_double* e ); lapack_int LAPACKE_zsyswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_zsyswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ); + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_zsytri2( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv ); @@ -10931,17 +10935,17 @@ lapack_int LAPACKE_zuncsd2by1( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_double* x11, lapack_int ldx11, lapack_complex_double* x21, lapack_int ldx21, - lapack_complex_double* theta, lapack_complex_double* u1, + double* theta, lapack_complex_double* u1, lapack_int ldu1, lapack_complex_double* u2, lapack_int ldu2, lapack_complex_double* v1t, lapack_int ldv1t ); lapack_int LAPACKE_zuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_double* x11, lapack_int ldx11, lapack_complex_double* x21, lapack_int ldx21, - lapack_complex_double* theta, lapack_complex_double* u1, - lapack_int ldu1, lapack_complex_double* u2, + double* theta, lapack_complex_double* u1, + lapack_int ldu1, lapack_complex_double* u2, lapack_int ldu2, lapack_complex_double* v1t, - lapack_int ldv1t, lapack_complex_double* work, + lapack_int ldv1t, lapack_complex_double* work, lapack_int lwork, double* rwork, lapack_int lrwork, lapack_int* iwork ); @@ -11243,7 +11247,7 @@ lapack_int LAPACKE_stprfb_work( int matrix_layout, char side, char trans, lapack_int n, lapack_int k, lapack_int l, const float* v, lapack_int ldv, const float* t, lapack_int ldt, float* a, lapack_int lda, - float* b, lapack_int ldb, const float* work, + float* b, lapack_int ldb, float* work, lapack_int ldwork ); lapack_int LAPACKE_dtprfb_work( int matrix_layout, char side, char trans, char direct, char storev, lapack_int m, @@ -11251,7 +11255,7 @@ lapack_int LAPACKE_dtprfb_work( int matrix_layout, char side, char trans, const double* v, lapack_int ldv, const double* t, lapack_int ldt, double* a, lapack_int lda, double* b, lapack_int ldb, - const double* work, lapack_int ldwork ); + double* work, lapack_int ldwork ); lapack_int LAPACKE_ctprfb_work( int matrix_layout, char side, char trans, char direct, char storev, lapack_int m, lapack_int n, lapack_int k, lapack_int l, @@ -11283,7 +11287,7 @@ lapack_int LAPACKE_zsysv_rook( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, lapack_complex_double* a, lapack_int lda, lapack_int* ipiv, lapack_complex_double* b, lapack_int ldb ); - + lapack_int LAPACKE_ssytrf_rook( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int* ipiv ); lapack_int LAPACKE_dsytrf_rook( int matrix_layout, char uplo, lapack_int n, double* a, @@ -11355,7 +11359,7 @@ lapack_int LAPACKE_zsysv_rook_work( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* b, lapack_int ldb, lapack_complex_double* work, lapack_int lwork ); - + lapack_int LAPACKE_ssytrf_rook_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int* ipiv, float* work, lapack_int lwork ); @@ -11417,167 +11421,1108 @@ lapack_int LAPACKE_zsyr_work( int matrix_layout, char uplo, lapack_int n, const lapack_complex_double* x, lapack_int incx, lapack_complex_double* a, lapack_int lda ); -void LAPACKE_ilaver( const lapack_int* vers_major, - const lapack_int* vers_minor, - const lapack_int* vers_patch ); +void LAPACKE_ilaver( lapack_int* vers_major, + lapack_int* vers_minor, + lapack_int* vers_patch ); +// LAPACK 3.7.0 +lapack_int LAPACKE_ssysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_ssysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_dsysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_csysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zsysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zsysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_chesv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_chesv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zhesv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zhesv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_ssytrf_aa( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, lapack_int* ipiv ); +lapack_int LAPACKE_dsytrf_aa( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, lapack_int* ipiv ); +lapack_int LAPACKE_csytrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv ); +lapack_int LAPACKE_zsytrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv ); +lapack_int LAPACKE_chetrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv ); +lapack_int LAPACKE_zhetrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv ); -#define LAPACK_sgetrf LAPACK_GLOBAL(sgetrf,SGETRF) -#define LAPACK_dgetrf LAPACK_GLOBAL(dgetrf,DGETRF) -#define LAPACK_cgetrf LAPACK_GLOBAL(cgetrf,CGETRF) -#define LAPACK_zgetrf LAPACK_GLOBAL(zgetrf,ZGETRF) -#define LAPACK_sgetrf2 LAPACK_GLOBAL(sgetrf2,SGETRF2) -#define LAPACK_dgetrf2 LAPACK_GLOBAL(dgetrf2,DGETRF2) -#define LAPACK_cgetrf2 LAPACK_GLOBAL(cgetrf2,CGETRF2) -#define LAPACK_zgetrf2 LAPACK_GLOBAL(zgetrf2,ZGETRF2) -#define LAPACK_sgbtrf LAPACK_GLOBAL(sgbtrf,SGBTRF) -#define LAPACK_dgbtrf LAPACK_GLOBAL(dgbtrf,DGBTRF) -#define LAPACK_cgbtrf LAPACK_GLOBAL(cgbtrf,CGBTRF) -#define LAPACK_zgbtrf LAPACK_GLOBAL(zgbtrf,ZGBTRF) -#define LAPACK_sgttrf LAPACK_GLOBAL(sgttrf,SGTTRF) -#define LAPACK_dgttrf LAPACK_GLOBAL(dgttrf,DGTTRF) -#define LAPACK_cgttrf LAPACK_GLOBAL(cgttrf,CGTTRF) -#define LAPACK_zgttrf LAPACK_GLOBAL(zgttrf,ZGTTRF) -#define LAPACK_spotrf LAPACK_GLOBAL(spotrf,SPOTRF) -#define LAPACK_dpotrf LAPACK_GLOBAL(dpotrf,DPOTRF) -#define LAPACK_cpotrf LAPACK_GLOBAL(cpotrf,CPOTRF) -#define LAPACK_zpotrf LAPACK_GLOBAL(zpotrf,ZPOTRF) -#define LAPACK_spotrf2 LAPACK_GLOBAL(spotrf2,SPOTRF2) -#define LAPACK_dpotrf2 LAPACK_GLOBAL(dpotrf2,DPOTRF2) -#define LAPACK_cpotrf2 LAPACK_GLOBAL(cpotrf2,CPOTRF2) -#define LAPACK_zpotrf2 LAPACK_GLOBAL(zpotrf2,ZPOTRF2) -#define LAPACK_dpstrf LAPACK_GLOBAL(dpstrf,DPSTRF) -#define LAPACK_spstrf LAPACK_GLOBAL(spstrf,SPSTRF) -#define LAPACK_zpstrf LAPACK_GLOBAL(zpstrf,ZPSTRF) -#define LAPACK_cpstrf LAPACK_GLOBAL(cpstrf,CPSTRF) -#define LAPACK_dpftrf LAPACK_GLOBAL(dpftrf,DPFTRF) -#define LAPACK_spftrf LAPACK_GLOBAL(spftrf,SPFTRF) -#define LAPACK_zpftrf LAPACK_GLOBAL(zpftrf,ZPFTRF) -#define LAPACK_cpftrf LAPACK_GLOBAL(cpftrf,CPFTRF) -#define LAPACK_spptrf LAPACK_GLOBAL(spptrf,SPPTRF) -#define LAPACK_dpptrf LAPACK_GLOBAL(dpptrf,DPPTRF) -#define LAPACK_cpptrf LAPACK_GLOBAL(cpptrf,CPPTRF) -#define LAPACK_zpptrf LAPACK_GLOBAL(zpptrf,ZPPTRF) -#define LAPACK_spbtrf LAPACK_GLOBAL(spbtrf,SPBTRF) -#define LAPACK_dpbtrf LAPACK_GLOBAL(dpbtrf,DPBTRF) -#define LAPACK_cpbtrf LAPACK_GLOBAL(cpbtrf,CPBTRF) -#define LAPACK_zpbtrf LAPACK_GLOBAL(zpbtrf,ZPBTRF) -#define LAPACK_spttrf LAPACK_GLOBAL(spttrf,SPTTRF) -#define LAPACK_dpttrf LAPACK_GLOBAL(dpttrf,DPTTRF) -#define LAPACK_cpttrf LAPACK_GLOBAL(cpttrf,CPTTRF) -#define LAPACK_zpttrf LAPACK_GLOBAL(zpttrf,ZPTTRF) -#define LAPACK_ssytrf LAPACK_GLOBAL(ssytrf,SSYTRF) -#define LAPACK_ssytrf_rook LAPACK_GLOBAL(ssytrf_rook,SSYTRF_ROOK) -#define LAPACK_dsytrf LAPACK_GLOBAL(dsytrf,DSYTRF) -#define LAPACK_dsytrf_rook LAPACK_GLOBAL(dsytrf_rook,DSYTRF_ROOK) -#define LAPACK_csytrf LAPACK_GLOBAL(csytrf,CSYTRF) -#define LAPACK_csytrf_rook LAPACK_GLOBAL(csytrf_rook,CSYTRF_ROOK) -#define LAPACK_zsytrf LAPACK_GLOBAL(zsytrf,ZSYTRF) -#define LAPACK_zsytrf_rook LAPACK_GLOBAL(zsytrf_rook,ZSYTRF_ROOK) -#define LAPACK_chetrf LAPACK_GLOBAL(chetrf,CHETRF) -#define LAPACK_chetrf_rook LAPACK_GLOBAL(chetrf_rook,CHETRF_ROOK) -#define LAPACK_zhetrf LAPACK_GLOBAL(zhetrf,ZHETRF) -#define LAPACK_zhetrf_rook LAPACK_GLOBAL(zhetrf_rook,ZHETRF_ROOK) -#define LAPACK_ssptrf LAPACK_GLOBAL(ssptrf,SSPTRF) -#define LAPACK_dsptrf LAPACK_GLOBAL(dsptrf,DSPTRF) -#define LAPACK_csptrf LAPACK_GLOBAL(csptrf,CSPTRF) -#define LAPACK_zsptrf LAPACK_GLOBAL(zsptrf,ZSPTRF) -#define LAPACK_chptrf LAPACK_GLOBAL(chptrf,CHPTRF) -#define LAPACK_zhptrf LAPACK_GLOBAL(zhptrf,ZHPTRF) -#define LAPACK_sgetrs LAPACK_GLOBAL(sgetrs,SGETRS) -#define LAPACK_dgetrs LAPACK_GLOBAL(dgetrs,DGETRS) -#define LAPACK_cgetrs LAPACK_GLOBAL(cgetrs,CGETRS) -#define LAPACK_zgetrs LAPACK_GLOBAL(zgetrs,ZGETRS) -#define LAPACK_sgbtrs LAPACK_GLOBAL(sgbtrs,SGBTRS) -#define LAPACK_dgbtrs LAPACK_GLOBAL(dgbtrs,DGBTRS) -#define LAPACK_cgbtrs LAPACK_GLOBAL(cgbtrs,CGBTRS) -#define LAPACK_zgbtrs LAPACK_GLOBAL(zgbtrs,ZGBTRS) -#define LAPACK_sgttrs LAPACK_GLOBAL(sgttrs,SGTTRS) -#define LAPACK_dgttrs LAPACK_GLOBAL(dgttrs,DGTTRS) -#define LAPACK_cgttrs LAPACK_GLOBAL(cgttrs,CGTTRS) -#define LAPACK_zgttrs LAPACK_GLOBAL(zgttrs,ZGTTRS) -#define LAPACK_spotrs LAPACK_GLOBAL(spotrs,SPOTRS) -#define LAPACK_dpotrs LAPACK_GLOBAL(dpotrs,DPOTRS) -#define LAPACK_cpotrs LAPACK_GLOBAL(cpotrs,CPOTRS) -#define LAPACK_zpotrs LAPACK_GLOBAL(zpotrs,ZPOTRS) -#define LAPACK_dpftrs LAPACK_GLOBAL(dpftrs,DPFTRS) -#define LAPACK_spftrs LAPACK_GLOBAL(spftrs,SPFTRS) -#define LAPACK_zpftrs LAPACK_GLOBAL(zpftrs,ZPFTRS) -#define LAPACK_cpftrs LAPACK_GLOBAL(cpftrs,CPFTRS) -#define LAPACK_spptrs LAPACK_GLOBAL(spptrs,SPPTRS) -#define LAPACK_dpptrs LAPACK_GLOBAL(dpptrs,DPPTRS) -#define LAPACK_cpptrs LAPACK_GLOBAL(cpptrs,CPPTRS) -#define LAPACK_zpptrs LAPACK_GLOBAL(zpptrs,ZPPTRS) -#define LAPACK_spbtrs LAPACK_GLOBAL(spbtrs,SPBTRS) -#define LAPACK_dpbtrs LAPACK_GLOBAL(dpbtrs,DPBTRS) -#define LAPACK_cpbtrs LAPACK_GLOBAL(cpbtrs,CPBTRS) -#define LAPACK_zpbtrs LAPACK_GLOBAL(zpbtrs,ZPBTRS) -#define LAPACK_spttrs LAPACK_GLOBAL(spttrs,SPTTRS) -#define LAPACK_dpttrs LAPACK_GLOBAL(dpttrs,DPTTRS) -#define LAPACK_cpttrs LAPACK_GLOBAL(cpttrs,CPTTRS) -#define LAPACK_zpttrs LAPACK_GLOBAL(zpttrs,ZPTTRS) -#define LAPACK_ssytrs LAPACK_GLOBAL(ssytrs,SSYTRS) -#define LAPACK_ssytrs_rook LAPACK_GLOBAL(ssytrs_rook,SSYTRS_ROOK) -#define LAPACK_dsytrs LAPACK_GLOBAL(dsytrs,DSYTRS) -#define LAPACK_dsytrs_rook LAPACK_GLOBAL(dsytrs_rook,DSYTRS_ROOK) -#define LAPACK_csytrs LAPACK_GLOBAL(csytrs,CSYTRS) -#define LAPACK_csytrs_rook LAPACK_GLOBAL(csytrs_rook,CSYTRS_ROOK) -#define LAPACK_zsytrs LAPACK_GLOBAL(zsytrs,ZSYTRS) -#define LAPACK_zsytrs_rook LAPACK_GLOBAL(zsytrs_rook,ZSYTRS_ROOK) -#define LAPACK_chetrs LAPACK_GLOBAL(chetrs,CHETRS) -#define LAPACK_chetrs_rook LAPACK_GLOBAL(chetrs_rook,CHETRS_ROOK) -#define LAPACK_zhetrs LAPACK_GLOBAL(zhetrs,ZHETRS) -#define LAPACK_zhetrs_rook LAPACK_GLOBAL(zhetrs_rook,ZHETRS_ROOK) -#define LAPACK_ssptrs LAPACK_GLOBAL(ssptrs,SSPTRS) -#define LAPACK_dsptrs LAPACK_GLOBAL(dsptrs,DSPTRS) -#define LAPACK_csptrs LAPACK_GLOBAL(csptrs,CSPTRS) -#define LAPACK_zsptrs LAPACK_GLOBAL(zsptrs,ZSPTRS) -#define LAPACK_chptrs LAPACK_GLOBAL(chptrs,CHPTRS) -#define LAPACK_zhptrs LAPACK_GLOBAL(zhptrs,ZHPTRS) -#define LAPACK_strtrs LAPACK_GLOBAL(strtrs,STRTRS) -#define LAPACK_dtrtrs LAPACK_GLOBAL(dtrtrs,DTRTRS) -#define LAPACK_ctrtrs LAPACK_GLOBAL(ctrtrs,CTRTRS) -#define LAPACK_ztrtrs LAPACK_GLOBAL(ztrtrs,ZTRTRS) -#define LAPACK_stptrs LAPACK_GLOBAL(stptrs,STPTRS) -#define LAPACK_dtptrs LAPACK_GLOBAL(dtptrs,DTPTRS) -#define LAPACK_ctptrs LAPACK_GLOBAL(ctptrs,CTPTRS) -#define LAPACK_ztptrs LAPACK_GLOBAL(ztptrs,ZTPTRS) -#define LAPACK_stbtrs LAPACK_GLOBAL(stbtrs,STBTRS) -#define LAPACK_dtbtrs LAPACK_GLOBAL(dtbtrs,DTBTRS) -#define LAPACK_ctbtrs LAPACK_GLOBAL(ctbtrs,CTBTRS) -#define LAPACK_ztbtrs LAPACK_GLOBAL(ztbtrs,ZTBTRS) -#define LAPACK_sgecon LAPACK_GLOBAL(sgecon,SGECON) -#define LAPACK_dgecon LAPACK_GLOBAL(dgecon,DGECON) -#define LAPACK_cgecon LAPACK_GLOBAL(cgecon,CGECON) -#define LAPACK_zgecon LAPACK_GLOBAL(zgecon,ZGECON) -#define LAPACK_sgbcon LAPACK_GLOBAL(sgbcon,SGBCON) -#define LAPACK_dgbcon LAPACK_GLOBAL(dgbcon,DGBCON) -#define LAPACK_cgbcon LAPACK_GLOBAL(cgbcon,CGBCON) -#define LAPACK_zgbcon LAPACK_GLOBAL(zgbcon,ZGBCON) -#define LAPACK_sgtcon LAPACK_GLOBAL(sgtcon,SGTCON) -#define LAPACK_dgtcon LAPACK_GLOBAL(dgtcon,DGTCON) -#define LAPACK_cgtcon LAPACK_GLOBAL(cgtcon,CGTCON) -#define LAPACK_zgtcon LAPACK_GLOBAL(zgtcon,ZGTCON) -#define LAPACK_spocon LAPACK_GLOBAL(spocon,SPOCON) -#define LAPACK_dpocon LAPACK_GLOBAL(dpocon,DPOCON) -#define LAPACK_cpocon LAPACK_GLOBAL(cpocon,CPOCON) -#define LAPACK_zpocon LAPACK_GLOBAL(zpocon,ZPOCON) -#define LAPACK_sppcon LAPACK_GLOBAL(sppcon,SPPCON) -#define LAPACK_dppcon LAPACK_GLOBAL(dppcon,DPPCON) -#define LAPACK_cppcon LAPACK_GLOBAL(cppcon,CPPCON) -#define LAPACK_zppcon LAPACK_GLOBAL(zppcon,ZPPCON) -#define LAPACK_spbcon LAPACK_GLOBAL(spbcon,SPBCON) -#define LAPACK_dpbcon LAPACK_GLOBAL(dpbcon,DPBCON) -#define LAPACK_cpbcon LAPACK_GLOBAL(cpbcon,CPBCON) -#define LAPACK_zpbcon LAPACK_GLOBAL(zpbcon,ZPBCON) -#define LAPACK_sptcon LAPACK_GLOBAL(sptcon,SPTCON) -#define LAPACK_dptcon LAPACK_GLOBAL(dptcon,DPTCON) -#define LAPACK_cptcon LAPACK_GLOBAL(cptcon,CPTCON) -#define LAPACK_zptcon LAPACK_GLOBAL(zptcon,ZPTCON) -#define LAPACK_ssycon LAPACK_GLOBAL(ssycon,SSYCON) -#define LAPACK_dsycon LAPACK_GLOBAL(dsycon,DSYCON) -#define LAPACK_csycon LAPACK_GLOBAL(csycon,CSYCON) -#define LAPACK_zsycon LAPACK_GLOBAL(zsycon,ZSYCON) +lapack_int LAPACKE_ssytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int* ipiv, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int* ipiv, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zsytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ); +lapack_int LAPACKE_chetrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zhetrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ); + + +lapack_int LAPACKE_csytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_csytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_chetrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_chetrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_dsytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_dsytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb, double* work, lapack_int lwork ); +lapack_int LAPACKE_ssytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_ssytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, + lapack_int ldb, float* work, lapack_int lwork ); +lapack_int LAPACKE_zsytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zsytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork); +lapack_int LAPACKE_zhetrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zhetrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork); + + +lapack_int LAPACKE_ssysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + float* e, lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_ssysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + float* e, lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + double* e, lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_dsysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + double* e, lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_csysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zsysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zsysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_chesv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_chesv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zhesv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zhesv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_ssytrf_rk( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, float* e, lapack_int* ipiv ); +lapack_int LAPACKE_dsytrf_rk( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, double* e, lapack_int* ipiv ); +lapack_int LAPACKE_csytrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, lapack_int* ipiv ); +lapack_int LAPACKE_zsytrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, lapack_int* ipiv ); +lapack_int LAPACKE_chetrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, lapack_int* ipiv ); +lapack_int LAPACKE_zhetrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, lapack_int* ipiv ); +lapack_int LAPACKE_ssytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, float* e, lapack_int* ipiv, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, double* e, lapack_int* ipiv, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zsytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ); +lapack_int LAPACKE_chetrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zhetrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ); + +lapack_int LAPACKE_csytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_csytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb); +lapack_int LAPACKE_chetrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_chetrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb); +lapack_int LAPACKE_dsytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const double* e, + const lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_dsytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const double* e, + const lapack_int* ipiv, + double* b, lapack_int ldb); +lapack_int LAPACKE_ssytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const float* e, + const lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_ssytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const float* e, const lapack_int* ipiv, float* b, + lapack_int ldb); +lapack_int LAPACKE_zsytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zsytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb); +lapack_int LAPACKE_zhetrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_zhetrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb); + +lapack_int LAPACKE_ssytri_3( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const float* e, const lapack_int* ipiv ); +lapack_int LAPACKE_dsytri_3( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, const double* e, const lapack_int* ipiv ); +lapack_int LAPACKE_csytri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv ); +lapack_int LAPACKE_zsytri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv ); +lapack_int LAPACKE_chetri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv ); +lapack_int LAPACKE_zhetri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv ); +lapack_int LAPACKE_ssytri_3_work( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const float* e, const lapack_int* ipiv, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsytri_3_work( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, const double* e, const lapack_int* ipiv, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csytri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zsytri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_chetri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zhetri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_ssycon_3( int matrix_layout, char uplo, lapack_int n, + const float* a, lapack_int lda, const float* e, + const lapack_int* ipiv, float anorm, float* rcond ); +lapack_int LAPACKE_dsycon_3( int matrix_layout, char uplo, lapack_int n, + const double* a, lapack_int lda, const double* e, + const lapack_int* ipiv, double anorm, + double* rcond ); +lapack_int LAPACKE_csycon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, float* rcond ); +lapack_int LAPACKE_zsycon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond ); +lapack_int LAPACKE_checon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, float* rcond ); +lapack_int LAPACKE_zhecon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond ); +lapack_int LAPACKE_ssycon_3_work( int matrix_layout, char uplo, lapack_int n, + const float* a, lapack_int lda, const float* e, + const lapack_int* ipiv, float anorm, + float* rcond, float* work, lapack_int* iwork ); +lapack_int LAPACKE_dsycon_3_work( int matrix_layout, char uplo, lapack_int n, + const double* a, lapack_int lda, const double* e, + const lapack_int* ipiv, double anorm, + double* rcond, double* work, + lapack_int* iwork ); +lapack_int LAPACKE_csycon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, + float* rcond, lapack_complex_float* work ); +lapack_int LAPACKE_zsycon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond, lapack_complex_double* work ); +lapack_int LAPACKE_checon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, + float* rcond, lapack_complex_float* work ); +lapack_int LAPACKE_zhecon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond, lapack_complex_double* work ); + +lapack_int LAPACKE_sgelq( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize ); +lapack_int LAPACKE_dgelq( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize ); +lapack_int LAPACKE_cgelq( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize ); +lapack_int LAPACKE_zgelq( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize ); + +lapack_int LAPACKE_sgelq_work( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgelq_work( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_sgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc ); +lapack_int LAPACKE_dgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc ); +lapack_int LAPACKE_cgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc ); +lapack_int LAPACKE_zgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc ); + +lapack_int LAPACKE_sgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_sgeqr( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize ); +lapack_int LAPACKE_dgeqr( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize ); +lapack_int LAPACKE_cgeqr( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize ); +lapack_int LAPACKE_zgeqr( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize ); + +lapack_int LAPACKE_sgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_sgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc ); +lapack_int LAPACKE_dgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc ); +lapack_int LAPACKE_cgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc ); +lapack_int LAPACKE_zgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc ); + +lapack_int LAPACKE_sgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_sgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, float* a, + lapack_int lda, float* b, lapack_int ldb ); +lapack_int LAPACKE_dgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, double* a, + lapack_int lda, double* b, lapack_int ldb ); +lapack_int LAPACKE_cgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_zgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ); + +lapack_int LAPACKE_sgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ); + +lapack_int LAPACKE_ssyev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ); +lapack_int LAPACKE_dsyev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ); + +lapack_int LAPACKE_ssyevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ); +lapack_int LAPACKE_dsyevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ); + +lapack_int LAPACKE_ssyevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, float* a, lapack_int lda, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* isuppz ); +lapack_int LAPACKE_dsyevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, double* a, lapack_int lda, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* isuppz ); + +lapack_int LAPACKE_ssyevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, float* a, lapack_int lda, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* ifail ); +lapack_int LAPACKE_dsyevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, double* a, lapack_int lda, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* ifail ); + +lapack_int LAPACKE_ssyev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, float* w, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsyev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork ); + +lapack_int LAPACKE_ssyevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, + float* w, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_dsyevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); + +lapack_int LAPACKE_ssyevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, float* a, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, lapack_int* isuppz, float* work, + lapack_int lwork, lapack_int* iwork, + lapack_int liwork ); +lapack_int LAPACKE_dsyevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, double* a, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* isuppz, + double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); + +lapack_int LAPACKE_ssyevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, float* a, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ); +lapack_int LAPACKE_dsyevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, double* a, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ); + +lapack_int LAPACKE_cheev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, float* w ); +lapack_int LAPACKE_zheev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, double* w ); + +lapack_int LAPACKE_cheevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, float* w ); +lapack_int LAPACKE_zheevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + double* w ); + +lapack_int LAPACKE_cheevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, float* w, + lapack_complex_float* z, lapack_int ldz, + lapack_int* isuppz ); +lapack_int LAPACKE_zheevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, lapack_int ldz, + lapack_int* isuppz ); + +lapack_int LAPACKE_cheevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, float* w, + lapack_complex_float* z, lapack_int ldz, + lapack_int* ifail ); +lapack_int LAPACKE_zheevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, lapack_int ldz, + lapack_int* ifail ); + +lapack_int LAPACKE_cheev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork ); +lapack_int LAPACKE_zheev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double* w, + lapack_complex_double* work, lapack_int lwork, + double* rwork ); + +lapack_int LAPACKE_cheevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_zheevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double* w, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); + +lapack_int LAPACKE_cheevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_int* isuppz, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_zheevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_int* isuppz, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); + +lapack_int LAPACKE_cheevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, + lapack_int* iwork, lapack_int* ifail ); +lapack_int LAPACKE_zheevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, + lapack_int* iwork, lapack_int* ifail ); + +lapack_int LAPACKE_ssbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, float* ab, lapack_int ldab, float* w, + float* z, lapack_int ldz ); +lapack_int LAPACKE_dsbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, double* ab, lapack_int ldab, double* w, + double* z, lapack_int ldz ); + +lapack_int LAPACKE_ssbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, float* ab, lapack_int ldab, float* w, + float* z, lapack_int ldz ); +lapack_int LAPACKE_dsbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, double* ab, lapack_int ldab, + double* w, double* z, lapack_int ldz ); + +lapack_int LAPACKE_ssbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* q, lapack_int ldq, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* ifail ); +lapack_int LAPACKE_dsbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* q, lapack_int ldq, + double vl, double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* ifail ); + +lapack_int LAPACKE_ssbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork ); +lapack_int LAPACKE_dsbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork ); + +lapack_int LAPACKE_ssbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_dsbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); + +lapack_int LAPACKE_ssbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + float* ab, lapack_int ldab, float* q, + lapack_int ldq, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, lapack_int* iwork, + lapack_int* ifail ); +lapack_int LAPACKE_dsbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + double* ab, lapack_int ldab, double* q, + lapack_int ldq, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, lapack_int* iwork, + lapack_int* ifail ); + +lapack_int LAPACKE_chbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_float* ab, + lapack_int ldab, float* w, lapack_complex_float* z, + lapack_int ldz ); +lapack_int LAPACKE_zhbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_double* ab, + lapack_int ldab, double* w, lapack_complex_double* z, + lapack_int ldz ); + +lapack_int LAPACKE_chbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_float* ab, + lapack_int ldab, float* w, lapack_complex_float* z, + lapack_int ldz ); +lapack_int LAPACKE_zhbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_double* ab, + lapack_int ldab, double* w, lapack_complex_double* z, + lapack_int ldz ); + +lapack_int LAPACKE_chbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + lapack_complex_float* q, lapack_int ldq, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, lapack_complex_float* z, + lapack_int ldz, lapack_int* ifail ); +lapack_int LAPACKE_zhbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + lapack_complex_double* q, lapack_int ldq, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, + lapack_complex_double* z, lapack_int ldz, + lapack_int* ifail ); + +lapack_int LAPACKE_chbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork ); +lapack_int LAPACKE_zhbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork ); + +lapack_int LAPACKE_chbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, + lapack_int lrwork, lapack_int* iwork, + lapack_int liwork ); +lapack_int LAPACKE_zhbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, + lapack_int lrwork, lapack_int* iwork, + lapack_int liwork ); + +lapack_int LAPACKE_chbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + lapack_complex_float* q, lapack_int ldq, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, lapack_int* iwork, + lapack_int* ifail ); +lapack_int LAPACKE_zhbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + lapack_complex_double* q, lapack_int ldq, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, lapack_int* iwork, + lapack_int* ifail ); + +lapack_int LAPACKE_ssygv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, float* w ); +lapack_int LAPACKE_dsygv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, double* w ); +lapack_int LAPACKE_ssygv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* w, float* work, lapack_int lwork ); +lapack_int LAPACKE_dsygv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* w, double* work, lapack_int lwork ); + +lapack_int LAPACKE_chegv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* b, + lapack_int ldb, float* w ); +lapack_int LAPACKE_zhegv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* b, + lapack_int ldb, double* w ); +lapack_int LAPACKE_chegv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* b, + lapack_int ldb, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork ); +lapack_int LAPACKE_zhegv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + double* w, lapack_complex_double* work, + lapack_int lwork, double* rwork ); + +#define LAPACK_sgetrf LAPACK_GLOBAL(sgetrf,SGETRF) +#define LAPACK_dgetrf LAPACK_GLOBAL(dgetrf,DGETRF) +#define LAPACK_cgetrf LAPACK_GLOBAL(cgetrf,CGETRF) +#define LAPACK_zgetrf LAPACK_GLOBAL(zgetrf,ZGETRF) +#define LAPACK_sgetrf2 LAPACK_GLOBAL(sgetrf2,SGETRF2) +#define LAPACK_dgetrf2 LAPACK_GLOBAL(dgetrf2,DGETRF2) +#define LAPACK_cgetrf2 LAPACK_GLOBAL(cgetrf2,CGETRF2) +#define LAPACK_zgetrf2 LAPACK_GLOBAL(zgetrf2,ZGETRF2) +#define LAPACK_sgbtrf LAPACK_GLOBAL(sgbtrf,SGBTRF) +#define LAPACK_dgbtrf LAPACK_GLOBAL(dgbtrf,DGBTRF) +#define LAPACK_cgbtrf LAPACK_GLOBAL(cgbtrf,CGBTRF) +#define LAPACK_zgbtrf LAPACK_GLOBAL(zgbtrf,ZGBTRF) +#define LAPACK_sgttrf LAPACK_GLOBAL(sgttrf,SGTTRF) +#define LAPACK_dgttrf LAPACK_GLOBAL(dgttrf,DGTTRF) +#define LAPACK_cgttrf LAPACK_GLOBAL(cgttrf,CGTTRF) +#define LAPACK_zgttrf LAPACK_GLOBAL(zgttrf,ZGTTRF) +#define LAPACK_spotrf LAPACK_GLOBAL(spotrf,SPOTRF) +#define LAPACK_dpotrf LAPACK_GLOBAL(dpotrf,DPOTRF) +#define LAPACK_cpotrf LAPACK_GLOBAL(cpotrf,CPOTRF) +#define LAPACK_zpotrf LAPACK_GLOBAL(zpotrf,ZPOTRF) +#define LAPACK_spotrf2 LAPACK_GLOBAL(spotrf2,SPOTRF2) +#define LAPACK_dpotrf2 LAPACK_GLOBAL(dpotrf2,DPOTRF2) +#define LAPACK_cpotrf2 LAPACK_GLOBAL(cpotrf2,CPOTRF2) +#define LAPACK_zpotrf2 LAPACK_GLOBAL(zpotrf2,ZPOTRF2) +#define LAPACK_dpstrf LAPACK_GLOBAL(dpstrf,DPSTRF) +#define LAPACK_spstrf LAPACK_GLOBAL(spstrf,SPSTRF) +#define LAPACK_zpstrf LAPACK_GLOBAL(zpstrf,ZPSTRF) +#define LAPACK_cpstrf LAPACK_GLOBAL(cpstrf,CPSTRF) +#define LAPACK_dpftrf LAPACK_GLOBAL(dpftrf,DPFTRF) +#define LAPACK_spftrf LAPACK_GLOBAL(spftrf,SPFTRF) +#define LAPACK_zpftrf LAPACK_GLOBAL(zpftrf,ZPFTRF) +#define LAPACK_cpftrf LAPACK_GLOBAL(cpftrf,CPFTRF) +#define LAPACK_spptrf LAPACK_GLOBAL(spptrf,SPPTRF) +#define LAPACK_dpptrf LAPACK_GLOBAL(dpptrf,DPPTRF) +#define LAPACK_cpptrf LAPACK_GLOBAL(cpptrf,CPPTRF) +#define LAPACK_zpptrf LAPACK_GLOBAL(zpptrf,ZPPTRF) +#define LAPACK_spbtrf LAPACK_GLOBAL(spbtrf,SPBTRF) +#define LAPACK_dpbtrf LAPACK_GLOBAL(dpbtrf,DPBTRF) +#define LAPACK_cpbtrf LAPACK_GLOBAL(cpbtrf,CPBTRF) +#define LAPACK_zpbtrf LAPACK_GLOBAL(zpbtrf,ZPBTRF) +#define LAPACK_spttrf LAPACK_GLOBAL(spttrf,SPTTRF) +#define LAPACK_dpttrf LAPACK_GLOBAL(dpttrf,DPTTRF) +#define LAPACK_cpttrf LAPACK_GLOBAL(cpttrf,CPTTRF) +#define LAPACK_zpttrf LAPACK_GLOBAL(zpttrf,ZPTTRF) +#define LAPACK_ssytrf LAPACK_GLOBAL(ssytrf,SSYTRF) +#define LAPACK_ssytrf_rook LAPACK_GLOBAL(ssytrf_rook,SSYTRF_ROOK) +#define LAPACK_dsytrf LAPACK_GLOBAL(dsytrf,DSYTRF) +#define LAPACK_dsytrf_rook LAPACK_GLOBAL(dsytrf_rook,DSYTRF_ROOK) +#define LAPACK_csytrf LAPACK_GLOBAL(csytrf,CSYTRF) +#define LAPACK_csytrf_rook LAPACK_GLOBAL(csytrf_rook,CSYTRF_ROOK) +#define LAPACK_zsytrf LAPACK_GLOBAL(zsytrf,ZSYTRF) +#define LAPACK_zsytrf_rook LAPACK_GLOBAL(zsytrf_rook,ZSYTRF_ROOK) +#define LAPACK_chetrf LAPACK_GLOBAL(chetrf,CHETRF) +#define LAPACK_chetrf_rook LAPACK_GLOBAL(chetrf_rook,CHETRF_ROOK) +#define LAPACK_zhetrf LAPACK_GLOBAL(zhetrf,ZHETRF) +#define LAPACK_zhetrf_rook LAPACK_GLOBAL(zhetrf_rook,ZHETRF_ROOK) +#define LAPACK_ssptrf LAPACK_GLOBAL(ssptrf,SSPTRF) +#define LAPACK_dsptrf LAPACK_GLOBAL(dsptrf,DSPTRF) +#define LAPACK_csptrf LAPACK_GLOBAL(csptrf,CSPTRF) +#define LAPACK_zsptrf LAPACK_GLOBAL(zsptrf,ZSPTRF) +#define LAPACK_chptrf LAPACK_GLOBAL(chptrf,CHPTRF) +#define LAPACK_zhptrf LAPACK_GLOBAL(zhptrf,ZHPTRF) +#define LAPACK_sgetrs LAPACK_GLOBAL(sgetrs,SGETRS) +#define LAPACK_dgetrs LAPACK_GLOBAL(dgetrs,DGETRS) +#define LAPACK_cgetrs LAPACK_GLOBAL(cgetrs,CGETRS) +#define LAPACK_zgetrs LAPACK_GLOBAL(zgetrs,ZGETRS) +#define LAPACK_sgbtrs LAPACK_GLOBAL(sgbtrs,SGBTRS) +#define LAPACK_dgbtrs LAPACK_GLOBAL(dgbtrs,DGBTRS) +#define LAPACK_cgbtrs LAPACK_GLOBAL(cgbtrs,CGBTRS) +#define LAPACK_zgbtrs LAPACK_GLOBAL(zgbtrs,ZGBTRS) +#define LAPACK_sgttrs LAPACK_GLOBAL(sgttrs,SGTTRS) +#define LAPACK_dgttrs LAPACK_GLOBAL(dgttrs,DGTTRS) +#define LAPACK_cgttrs LAPACK_GLOBAL(cgttrs,CGTTRS) +#define LAPACK_zgttrs LAPACK_GLOBAL(zgttrs,ZGTTRS) +#define LAPACK_spotrs LAPACK_GLOBAL(spotrs,SPOTRS) +#define LAPACK_dpotrs LAPACK_GLOBAL(dpotrs,DPOTRS) +#define LAPACK_cpotrs LAPACK_GLOBAL(cpotrs,CPOTRS) +#define LAPACK_zpotrs LAPACK_GLOBAL(zpotrs,ZPOTRS) +#define LAPACK_dpftrs LAPACK_GLOBAL(dpftrs,DPFTRS) +#define LAPACK_spftrs LAPACK_GLOBAL(spftrs,SPFTRS) +#define LAPACK_zpftrs LAPACK_GLOBAL(zpftrs,ZPFTRS) +#define LAPACK_cpftrs LAPACK_GLOBAL(cpftrs,CPFTRS) +#define LAPACK_spptrs LAPACK_GLOBAL(spptrs,SPPTRS) +#define LAPACK_dpptrs LAPACK_GLOBAL(dpptrs,DPPTRS) +#define LAPACK_cpptrs LAPACK_GLOBAL(cpptrs,CPPTRS) +#define LAPACK_zpptrs LAPACK_GLOBAL(zpptrs,ZPPTRS) +#define LAPACK_spbtrs LAPACK_GLOBAL(spbtrs,SPBTRS) +#define LAPACK_dpbtrs LAPACK_GLOBAL(dpbtrs,DPBTRS) +#define LAPACK_cpbtrs LAPACK_GLOBAL(cpbtrs,CPBTRS) +#define LAPACK_zpbtrs LAPACK_GLOBAL(zpbtrs,ZPBTRS) +#define LAPACK_spttrs LAPACK_GLOBAL(spttrs,SPTTRS) +#define LAPACK_dpttrs LAPACK_GLOBAL(dpttrs,DPTTRS) +#define LAPACK_cpttrs LAPACK_GLOBAL(cpttrs,CPTTRS) +#define LAPACK_zpttrs LAPACK_GLOBAL(zpttrs,ZPTTRS) +#define LAPACK_ssytrs LAPACK_GLOBAL(ssytrs,SSYTRS) +#define LAPACK_ssytrs_rook LAPACK_GLOBAL(ssytrs_rook,SSYTRS_ROOK) +#define LAPACK_dsytrs LAPACK_GLOBAL(dsytrs,DSYTRS) +#define LAPACK_dsytrs_rook LAPACK_GLOBAL(dsytrs_rook,DSYTRS_ROOK) +#define LAPACK_csytrs LAPACK_GLOBAL(csytrs,CSYTRS) +#define LAPACK_csytrs_rook LAPACK_GLOBAL(csytrs_rook,CSYTRS_ROOK) +#define LAPACK_zsytrs LAPACK_GLOBAL(zsytrs,ZSYTRS) +#define LAPACK_zsytrs_rook LAPACK_GLOBAL(zsytrs_rook,ZSYTRS_ROOK) +#define LAPACK_chetrs LAPACK_GLOBAL(chetrs,CHETRS) +#define LAPACK_chetrs_rook LAPACK_GLOBAL(chetrs_rook,CHETRS_ROOK) +#define LAPACK_zhetrs LAPACK_GLOBAL(zhetrs,ZHETRS) +#define LAPACK_zhetrs_rook LAPACK_GLOBAL(zhetrs_rook,ZHETRS_ROOK) +#define LAPACK_ssptrs LAPACK_GLOBAL(ssptrs,SSPTRS) +#define LAPACK_dsptrs LAPACK_GLOBAL(dsptrs,DSPTRS) +#define LAPACK_csptrs LAPACK_GLOBAL(csptrs,CSPTRS) +#define LAPACK_zsptrs LAPACK_GLOBAL(zsptrs,ZSPTRS) +#define LAPACK_chptrs LAPACK_GLOBAL(chptrs,CHPTRS) +#define LAPACK_zhptrs LAPACK_GLOBAL(zhptrs,ZHPTRS) +#define LAPACK_strtrs LAPACK_GLOBAL(strtrs,STRTRS) +#define LAPACK_dtrtrs LAPACK_GLOBAL(dtrtrs,DTRTRS) +#define LAPACK_ctrtrs LAPACK_GLOBAL(ctrtrs,CTRTRS) +#define LAPACK_ztrtrs LAPACK_GLOBAL(ztrtrs,ZTRTRS) +#define LAPACK_stptrs LAPACK_GLOBAL(stptrs,STPTRS) +#define LAPACK_dtptrs LAPACK_GLOBAL(dtptrs,DTPTRS) +#define LAPACK_ctptrs LAPACK_GLOBAL(ctptrs,CTPTRS) +#define LAPACK_ztptrs LAPACK_GLOBAL(ztptrs,ZTPTRS) +#define LAPACK_stbtrs LAPACK_GLOBAL(stbtrs,STBTRS) +#define LAPACK_dtbtrs LAPACK_GLOBAL(dtbtrs,DTBTRS) +#define LAPACK_ctbtrs LAPACK_GLOBAL(ctbtrs,CTBTRS) +#define LAPACK_ztbtrs LAPACK_GLOBAL(ztbtrs,ZTBTRS) +#define LAPACK_sgecon LAPACK_GLOBAL(sgecon,SGECON) +#define LAPACK_dgecon LAPACK_GLOBAL(dgecon,DGECON) +#define LAPACK_cgecon LAPACK_GLOBAL(cgecon,CGECON) +#define LAPACK_zgecon LAPACK_GLOBAL(zgecon,ZGECON) +#define LAPACK_sgbcon LAPACK_GLOBAL(sgbcon,SGBCON) +#define LAPACK_dgbcon LAPACK_GLOBAL(dgbcon,DGBCON) +#define LAPACK_cgbcon LAPACK_GLOBAL(cgbcon,CGBCON) +#define LAPACK_zgbcon LAPACK_GLOBAL(zgbcon,ZGBCON) +#define LAPACK_sgtcon LAPACK_GLOBAL(sgtcon,SGTCON) +#define LAPACK_dgtcon LAPACK_GLOBAL(dgtcon,DGTCON) +#define LAPACK_cgtcon LAPACK_GLOBAL(cgtcon,CGTCON) +#define LAPACK_zgtcon LAPACK_GLOBAL(zgtcon,ZGTCON) +#define LAPACK_spocon LAPACK_GLOBAL(spocon,SPOCON) +#define LAPACK_dpocon LAPACK_GLOBAL(dpocon,DPOCON) +#define LAPACK_cpocon LAPACK_GLOBAL(cpocon,CPOCON) +#define LAPACK_zpocon LAPACK_GLOBAL(zpocon,ZPOCON) +#define LAPACK_sppcon LAPACK_GLOBAL(sppcon,SPPCON) +#define LAPACK_dppcon LAPACK_GLOBAL(dppcon,DPPCON) +#define LAPACK_cppcon LAPACK_GLOBAL(cppcon,CPPCON) +#define LAPACK_zppcon LAPACK_GLOBAL(zppcon,ZPPCON) +#define LAPACK_spbcon LAPACK_GLOBAL(spbcon,SPBCON) +#define LAPACK_dpbcon LAPACK_GLOBAL(dpbcon,DPBCON) +#define LAPACK_cpbcon LAPACK_GLOBAL(cpbcon,CPBCON) +#define LAPACK_zpbcon LAPACK_GLOBAL(zpbcon,ZPBCON) +#define LAPACK_sptcon LAPACK_GLOBAL(sptcon,SPTCON) +#define LAPACK_dptcon LAPACK_GLOBAL(dptcon,DPTCON) +#define LAPACK_cptcon LAPACK_GLOBAL(cptcon,CPTCON) +#define LAPACK_zptcon LAPACK_GLOBAL(zptcon,ZPTCON) +#define LAPACK_ssycon LAPACK_GLOBAL(ssycon,SSYCON) +#define LAPACK_dsycon LAPACK_GLOBAL(dsycon,DSYCON) +#define LAPACK_csycon LAPACK_GLOBAL(csycon,CSYCON) +#define LAPACK_zsycon LAPACK_GLOBAL(zsycon,ZSYCON) #define LAPACK_checon LAPACK_GLOBAL(checon,CHECON) #define LAPACK_zhecon LAPACK_GLOBAL(zhecon,ZHECON) #define LAPACK_sspcon LAPACK_GLOBAL(sspcon,SSPCON) @@ -12146,18 +13091,34 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dsyev LAPACK_GLOBAL(dsyev,DSYEV) #define LAPACK_cheev LAPACK_GLOBAL(cheev,CHEEV) #define LAPACK_zheev LAPACK_GLOBAL(zheev,ZHEEV) +#define LAPACK_ssyev_2stage LAPACK_GLOBAL(ssyev_2stage,SSYEV_2STAGE) +#define LAPACK_dsyev_2stage LAPACK_GLOBAL(dsyev_2stage,DSYEV_2STAGE) +#define LAPACK_cheev_2stage LAPACK_GLOBAL(cheev_2stage,CHEEV_2STAGE) +#define LAPACK_zheev_2stage LAPACK_GLOBAL(zheev_2stage,ZHEEV_2STAGE) #define LAPACK_ssyevd LAPACK_GLOBAL(ssyevd,SSYEVD) #define LAPACK_dsyevd LAPACK_GLOBAL(dsyevd,DSYEVD) #define LAPACK_cheevd LAPACK_GLOBAL(cheevd,CHEEVD) #define LAPACK_zheevd LAPACK_GLOBAL(zheevd,ZHEEVD) +#define LAPACK_ssyevd_2stage LAPACK_GLOBAL(ssyevd_2stage,SSYEVD_2STAGE) +#define LAPACK_dsyevd_2stage LAPACK_GLOBAL(dsyevd_2stage,DSYEVD_2STAGE) +#define LAPACK_cheevd_2stage LAPACK_GLOBAL(cheevd_2stage,CHEEVD_2STAGE) +#define LAPACK_zheevd_2stage LAPACK_GLOBAL(zheevd_2stage,ZHEEVD_2STAGE) #define LAPACK_ssyevx LAPACK_GLOBAL(ssyevx,SSYEVX) #define LAPACK_dsyevx LAPACK_GLOBAL(dsyevx,DSYEVX) #define LAPACK_cheevx LAPACK_GLOBAL(cheevx,CHEEVX) #define LAPACK_zheevx LAPACK_GLOBAL(zheevx,ZHEEVX) +#define LAPACK_ssyevx_2stage LAPACK_GLOBAL(ssyevx_2stage,SSYEVX_2STAGE) +#define LAPACK_dsyevx_2stage LAPACK_GLOBAL(dsyevx_2stage,DSYEVX_2STAGE) +#define LAPACK_cheevx_2stage LAPACK_GLOBAL(cheevx_2stage,CHEEVX_2STAGE) +#define LAPACK_zheevx_2stage LAPACK_GLOBAL(zheevx_2stage,ZHEEVX_2STAGE) #define LAPACK_ssyevr LAPACK_GLOBAL(ssyevr,SSYEVR) #define LAPACK_dsyevr LAPACK_GLOBAL(dsyevr,DSYEVR) #define LAPACK_cheevr LAPACK_GLOBAL(cheevr,CHEEVR) #define LAPACK_zheevr LAPACK_GLOBAL(zheevr,ZHEEVR) +#define LAPACK_ssyevr_2stage LAPACK_GLOBAL(ssyevr_2stage,SSYEVR_2STAGE) +#define LAPACK_dsyevr_2stage LAPACK_GLOBAL(dsyevr_2stage,DSYEVR_2STAGE) +#define LAPACK_cheevr_2stage LAPACK_GLOBAL(cheevr_2stage,CHEEVR_2STAGE) +#define LAPACK_zheevr_2stage LAPACK_GLOBAL(zheevr_2stage,ZHEEVR_2STAGE) #define LAPACK_sspev LAPACK_GLOBAL(sspev,SSPEV) #define LAPACK_dspev LAPACK_GLOBAL(dspev,DSPEV) #define LAPACK_chpev LAPACK_GLOBAL(chpev,CHPEV) @@ -12174,14 +13135,26 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dsbev LAPACK_GLOBAL(dsbev,DSBEV) #define LAPACK_chbev LAPACK_GLOBAL(chbev,CHBEV) #define LAPACK_zhbev LAPACK_GLOBAL(zhbev,ZHBEV) +#define LAPACK_ssbev_2stage LAPACK_GLOBAL(ssbev_2stage,SSBEV_2STAGE) +#define LAPACK_dsbev_2stage LAPACK_GLOBAL(dsbev_2stage,DSBEV_2STAGE) +#define LAPACK_chbev_2stage LAPACK_GLOBAL(chbev_2stage,CHBEV_2STAGE) +#define LAPACK_zhbev_2stage LAPACK_GLOBAL(zhbev_2stage,ZHBEV_2STAGE) #define LAPACK_ssbevd LAPACK_GLOBAL(ssbevd,SSBEVD) #define LAPACK_dsbevd LAPACK_GLOBAL(dsbevd,DSBEVD) #define LAPACK_chbevd LAPACK_GLOBAL(chbevd,CHBEVD) #define LAPACK_zhbevd LAPACK_GLOBAL(zhbevd,ZHBEVD) +#define LAPACK_ssbevd_2stage LAPACK_GLOBAL(ssbevd_2stage,SSBEVD_2STAGE) +#define LAPACK_dsbevd_2stage LAPACK_GLOBAL(dsbevd_2stage,DSBEVD_2STAGE) +#define LAPACK_chbevd_2stage LAPACK_GLOBAL(chbevd_2stage,CHBEVD_2STAGE) +#define LAPACK_zhbevd_2stage LAPACK_GLOBAL(zhbevd_2stage,ZHBEVD_2STAGE) #define LAPACK_ssbevx LAPACK_GLOBAL(ssbevx,SSBEVX) #define LAPACK_dsbevx LAPACK_GLOBAL(dsbevx,DSBEVX) #define LAPACK_chbevx LAPACK_GLOBAL(chbevx,CHBEVX) #define LAPACK_zhbevx LAPACK_GLOBAL(zhbevx,ZHBEVX) +#define LAPACK_ssbevx_2stage LAPACK_GLOBAL(ssbevx_2stage,SSBEVX_2STAGE) +#define LAPACK_dsbevx_2stage LAPACK_GLOBAL(dsbevx_2stage,DSBEVX_2STAGE) +#define LAPACK_chbevx_2stage LAPACK_GLOBAL(chbevx_2stage,CHBEVX_2STAGE) +#define LAPACK_zhbevx_2stage LAPACK_GLOBAL(zhbevx_2stage,ZHBEVX_2STAGE) #define LAPACK_sstev LAPACK_GLOBAL(sstev,SSTEV) #define LAPACK_dstev LAPACK_GLOBAL(dstev,DSTEV) #define LAPACK_sstevd LAPACK_GLOBAL(sstevd,SSTEVD) @@ -12234,6 +13207,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dsygv LAPACK_GLOBAL(dsygv,DSYGV) #define LAPACK_chegv LAPACK_GLOBAL(chegv,CHEGV) #define LAPACK_zhegv LAPACK_GLOBAL(zhegv,ZHEGV) +#define LAPACK_ssygv_2stage LAPACK_GLOBAL(ssygv_2stage,SSYGV_2STAGE) +#define LAPACK_dsygv_2stage LAPACK_GLOBAL(dsygv_2stage,DSYGV_2STAGE) +#define LAPACK_chegv_2stage LAPACK_GLOBAL(chegv_2stage,CHEGV_2STAGE) +#define LAPACK_zhegv_2stage LAPACK_GLOBAL(zhegv_2stage,ZHEGV_2STAGE) #define LAPACK_ssygvd LAPACK_GLOBAL(ssygvd,SSYGVD) #define LAPACK_dsygvd LAPACK_GLOBAL(dsygvd,DSYGVD) #define LAPACK_chegvd LAPACK_GLOBAL(chegvd,CHEGVD) @@ -12529,7 +13506,76 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dggsvd3 LAPACK_GLOBAL(dggsvd3,DGGSVD3) #define LAPACK_cggsvd3 LAPACK_GLOBAL(cggsvd3,CGGSVD3) #define LAPACK_zggsvd3 LAPACK_GLOBAL(zggsvd3,ZGGSVD3) - +// LAPACK 3.7.0 +#define LAPACK_ssysv_aa LAPACK_GLOBAL(ssysv_aa,SSYSV_AA) +#define LAPACK_dsysv_aa LAPACK_GLOBAL(dsysv_aa,DSYSV_AA) +#define LAPACK_chesv_aa LAPACK_GLOBAL(chesv_aa,CHESV_AA) +#define LAPACK_zsysv_aa LAPACK_GLOBAL(zsysv_aa,ZSYSV_AA) +#define LAPACK_csysv_aa LAPACK_GLOBAL(csysv_aa,CSYSV_AA) +#define LAPACK_zhesv_aa LAPACK_GLOBAL(zhesv_aa,ZHESV_AA) +#define LAPACK_ssytrs_aa LAPACK_GLOBAL(ssytrs_aa,SSYTRS_AA) +#define LAPACK_dsytrs_aa LAPACK_GLOBAL(dsytrs_aa,DSYTRS_AA) +#define LAPACK_csytrs_aa LAPACK_GLOBAL(csytrs_aa,CSYTRS_AA) +#define LAPACK_zsytrs_aa LAPACK_GLOBAL(zsytrs_aa,ZSYTRS_AA) +#define LAPACK_chetrs_aa LAPACK_GLOBAL(chetrs_aa,CHETRS_AA) +#define LAPACK_zhetrs_aa LAPACK_GLOBAL(zhetrs_aa,ZHETRS_AA) +#define LAPACK_ssytrf_aa LAPACK_GLOBAL(ssytrf_aa,SSYTRF_AA) +#define LAPACK_dsytrf_aa LAPACK_GLOBAL(dsytrf_aa,DSYTRF_AA) +#define LAPACK_csytrf_aa LAPACK_GLOBAL(csytrf_aa,CSYTRF_AA) +#define LAPACK_zsytrf_aa LAPACK_GLOBAL(zsytrf_aa,ZSYTRF_AA) +#define LAPACK_chetrf_aa LAPACK_GLOBAL(chetrf_aa,CHETRF_AA) +#define LAPACK_zhetrf_aa LAPACK_GLOBAL(zhetrf_aa,ZHETRF_AA) + +#define LAPACK_ssysv_rk LAPACK_GLOBAL(ssysv_rk,SSYSV_RK) +#define LAPACK_dsysv_rk LAPACK_GLOBAL(dsysv_rk,DSYSV_RK) +#define LAPACK_chesv_rk LAPACK_GLOBAL(chesv_rk,CHESV_RK) +#define LAPACK_zsysv_rk LAPACK_GLOBAL(zsysv_rk,ZSYSV_RK) +#define LAPACK_csysv_rk LAPACK_GLOBAL(csysv_rk,CSYSV_RK) +#define LAPACK_zhesv_rk LAPACK_GLOBAL(zhesv_rk,ZHESV_RK) +#define LAPACK_ssytrf_rk LAPACK_GLOBAL(ssytrf_rk,SSYTRF_RK) +#define LAPACK_dsytrf_rk LAPACK_GLOBAL(dsytrf_rk,DSYTRF_RK) +#define LAPACK_csytrf_rk LAPACK_GLOBAL(csytrf_rk,CSYTRF_RK) +#define LAPACK_zsytrf_rk LAPACK_GLOBAL(zsytrf_rk,ZSYTRF_RK) +#define LAPACK_chetrf_rk LAPACK_GLOBAL(chetrf_rk,CHETRF_RK) +#define LAPACK_zhetrf_rk LAPACK_GLOBAL(zhetrf_rk,ZHETRF_RK) +#define LAPACK_ssytrs_3 LAPACK_GLOBAL(ssytrs_3,SSYTRS_3) +#define LAPACK_dsytrs_3 LAPACK_GLOBAL(dsytrs_3,DSYTRS_3) +#define LAPACK_csytrs_3 LAPACK_GLOBAL(csytrs_3,CSYTRS_3) +#define LAPACK_zsytrs_3 LAPACK_GLOBAL(zsytrs_3,ZSYTRS_3) +#define LAPACK_chetrs_3 LAPACK_GLOBAL(chetrs_3,CHETRS_3) +#define LAPACK_zhetrs_3 LAPACK_GLOBAL(zhetrs_3,ZHETRS_3) +#define LAPACK_ssytri_3 LAPACK_GLOBAL(ssytri_3,SSYTRI_3) +#define LAPACK_dsytri_3 LAPACK_GLOBAL(dsytri_3,DSYTRI_3) +#define LAPACK_csytri_3 LAPACK_GLOBAL(csytri_3,CSYTRI_3) +#define LAPACK_zsytri_3 LAPACK_GLOBAL(zsytri_3,ZSYTRI_3) +#define LAPACK_chetri_3 LAPACK_GLOBAL(chetri_3,CHETRI_3) +#define LAPACK_zhetri_3 LAPACK_GLOBAL(zhetri_3,ZHETRI_3) +#define LAPACK_ssycon_3 LAPACK_GLOBAL(ssycon_3,SSYCON_3) +#define LAPACK_dsycon_3 LAPACK_GLOBAL(dsycon_3,DSYCON_3) +#define LAPACK_csycon_3 LAPACK_GLOBAL(csycon_3,CSYCON_3) +#define LAPACK_zsycon_3 LAPACK_GLOBAL(zsycon_3,ZSYCON_3) +#define LAPACK_checon_3 LAPACK_GLOBAL(checon_3,CHECON_3) +#define LAPACK_zhecon_3 LAPACK_GLOBAL(zhecon_3,ZHECON_3) +#define LAPACK_sgelq LAPACK_GLOBAL(sgelq,SGELQ) +#define LAPACK_dgelq LAPACK_GLOBAL(dgelq,DGELQ) +#define LAPACK_cgelq LAPACK_GLOBAL(cgelq,CGELQ) +#define LAPACK_zgelq LAPACK_GLOBAL(zgelq,ZGELQ) +#define LAPACK_sgemlq LAPACK_GLOBAL(sgemlq,SGEMLQ) +#define LAPACK_dgemlq LAPACK_GLOBAL(dgemlq,DGEMLQ) +#define LAPACK_cgemlq LAPACK_GLOBAL(cgemlq,CGEMLQ) +#define LAPACK_zgemlq LAPACK_GLOBAL(zgemlq,ZGEMLQ) +#define LAPACK_sgeqr LAPACK_GLOBAL(sgeqr,SGEQR) +#define LAPACK_dgeqr LAPACK_GLOBAL(dgeqr,DGEQR) +#define LAPACK_cgeqr LAPACK_GLOBAL(cgeqr,CGEQR) +#define LAPACK_zgeqr LAPACK_GLOBAL(zgeqr,ZGEQR) +#define LAPACK_sgemqr LAPACK_GLOBAL(sgemqr,SGEMQR) +#define LAPACK_dgemqr LAPACK_GLOBAL(dgemqr,DGEMQR) +#define LAPACK_cgemqr LAPACK_GLOBAL(cgemqr,CGEMQR) +#define LAPACK_zgemqr LAPACK_GLOBAL(zgemqr,ZGEMQR) +#define LAPACK_sgetsls LAPACK_GLOBAL(sgetsls,SGETSLS) +#define LAPACK_dgetsls LAPACK_GLOBAL(dgetsls,DGETSLS) +#define LAPACK_cgetsls LAPACK_GLOBAL(cgetsls,CGETSLS) +#define LAPACK_zgetsls LAPACK_GLOBAL(zgetsls,ZGETSLS) void LAPACK_sgetrf( lapack_int* m, lapack_int* n, float* a, lapack_int* lda, @@ -14784,13 +15830,13 @@ void LAPACK_dbdsdc( char* uplo, char* compq, lapack_int* n, double* d, lapack_int* iwork, lapack_int *info ); void LAPACK_sbdsvdx( char* uplo, char* jobz, char* range, lapack_int* n, float* d, float* e, - lapack_int* vl, lapack_int* vu, + float* vl, float* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, float* s, float* z, lapack_int* ldz, float* work, lapack_int *iwork, lapack_int *info ); void LAPACK_dbdsvdx( char* uplo, char* jobz, char* range, lapack_int* n, double* d, double* e, - lapack_int* vl, lapack_int* vu, + double* vl, double* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, double* s, double* z, lapack_int* ldz, double* work, lapack_int *iwork, lapack_int *info ); @@ -15941,28 +16987,28 @@ void LAPACK_ssbevx( char* jobz, char* range, char* uplo, lapack_int* n, lapack_int* kd, float* ab, lapack_int* ldab, float* q, lapack_int* ldq, float* vl, float* vu, lapack_int* il, lapack_int* iu, float* abstol, lapack_int* m, float* w, - float* z, lapack_int* ldz, float* work, lapack_int* iwork, - lapack_int* ifail, lapack_int *info ); + float* z, lapack_int* ldz, float* work, + lapack_int* iwork, lapack_int* ifail, lapack_int *info ); void LAPACK_dsbevx( char* jobz, char* range, char* uplo, lapack_int* n, lapack_int* kd, double* ab, lapack_int* ldab, double* q, lapack_int* ldq, double* vl, double* vu, lapack_int* il, lapack_int* iu, double* abstol, lapack_int* m, double* w, - double* z, lapack_int* ldz, double* work, lapack_int* iwork, - lapack_int* ifail, lapack_int *info ); + double* z, lapack_int* ldz, double* work, + lapack_int* iwork, lapack_int* ifail, lapack_int *info ); void LAPACK_chbevx( char* jobz, char* range, char* uplo, lapack_int* n, lapack_int* kd, lapack_complex_float* ab, lapack_int* ldab, lapack_complex_float* q, lapack_int* ldq, float* vl, float* vu, lapack_int* il, lapack_int* iu, float* abstol, lapack_int* m, float* w, lapack_complex_float* z, - lapack_int* ldz, lapack_complex_float* work, float* rwork, - lapack_int* iwork, lapack_int* ifail, lapack_int *info ); + lapack_int* ldz, lapack_complex_float* work, + float* rwork, lapack_int* iwork, lapack_int* ifail, lapack_int *info ); void LAPACK_zhbevx( char* jobz, char* range, char* uplo, lapack_int* n, lapack_int* kd, lapack_complex_double* ab, lapack_int* ldab, lapack_complex_double* q, lapack_int* ldq, double* vl, double* vu, lapack_int* il, lapack_int* iu, double* abstol, lapack_int* m, double* w, lapack_complex_double* z, - lapack_int* ldz, lapack_complex_double* work, double* rwork, - lapack_int* iwork, lapack_int* ifail, lapack_int *info ); + lapack_int* ldz, lapack_complex_double* work, + double* rwork, lapack_int* iwork, lapack_int* ifail, lapack_int *info ); void LAPACK_sstev( char* jobz, lapack_int* n, float* d, float* e, float* z, lapack_int* ldz, float* work, lapack_int *info ); void LAPACK_dstev( char* jobz, lapack_int* n, double* d, double* e, double* z, @@ -16115,29 +17161,29 @@ void LAPACK_zgesvd( char* jobu, char* jobvt, lapack_int* m, lapack_int* n, lapack_complex_double* work, lapack_int* lwork, double* rwork, lapack_int *info ); void LAPACK_sgesvdx( char* jobu, char* jobvt, char* range, lapack_int* m, lapack_int* n, - float* a, lapack_int* lda, lapack_int* vl, lapack_int* vu, + float* a, lapack_int* lda, float* vl, float* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, float* s, float* u, lapack_int* ldu, float* vt, lapack_int* ldvt, float* work, lapack_int* lwork, lapack_int *iwork, lapack_int *info ); void LAPACK_dgesvdx( char* jobu, char* jobvt, char* range, lapack_int* m, lapack_int* n, - double* a, lapack_int* lda, lapack_int* vl, lapack_int* vu, + double* a, lapack_int* lda, double* vl, double* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, double* s, double* u, lapack_int* ldu, double* vt, lapack_int* ldvt, double* work, lapack_int* lwork, lapack_int *iwork, lapack_int *info ); void LAPACK_cgesvdx( char* jobu, char* jobvt, char* range, lapack_int* m, lapack_int* n, - lapack_complex_float* a, lapack_int* lda, lapack_int* vl, lapack_int* vu, + lapack_complex_float* a, lapack_int* lda, float* vl, float* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, float* s, lapack_complex_float* u, lapack_int* ldu, lapack_complex_float* vt, lapack_int* ldvt, lapack_complex_float* work, lapack_int* lwork, float* rwork, lapack_int *iwork, lapack_int *info ); void LAPACK_zgesvdx( char* jobu, char* jobvt, char* range, lapack_int* m, lapack_int* n, - lapack_complex_double* a, lapack_int* lda, lapack_int* vl, lapack_int* vu, + lapack_complex_double* a, lapack_int* lda, double* vl, double* vu, lapack_int* il, lapack_int* iu, lapack_int* ns, double* s, lapack_complex_double* u, lapack_int* ldu, lapack_complex_double* vt, lapack_int* ldvt, lapack_complex_double* work, lapack_int* lwork, - double* rwork, lapack_int *iwork, lapack_int *info ); + double* rwork, lapack_int *iwork, lapack_int *info ); void LAPACK_sgesdd( char* jobz, lapack_int* m, lapack_int* n, float* a, lapack_int* lda, float* s, float* u, lapack_int* ldu, float* vt, lapack_int* ldvt, float* work, lapack_int* lwork, @@ -16171,13 +17217,13 @@ void LAPACK_sgejsv( char* joba, char* jobu, char* jobv, char* jobr, char* jobt, void LAPACK_cgejsv( char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, lapack_int* m, lapack_int* n, lapack_complex_float* a, lapack_int* lda, float* sva, lapack_complex_float* u, lapack_int* ldu, - lapack_complex_float* v, lapack_int* ldv, lapack_complex_float* cwork, + lapack_complex_float* v, lapack_int* ldv, lapack_complex_float* cwork, lapack_int* lwork, float* work, lapack_int* lrwork, lapack_int* iwork, lapack_int *info ); void LAPACK_zgejsv( char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, double* sva, lapack_complex_double* u, lapack_int* ldu, - lapack_complex_double* v, lapack_int* ldv, lapack_complex_double* cwork, + lapack_complex_double* v, lapack_int* ldv, lapack_complex_double* cwork, lapack_int* lwork, double* work, lapack_int* lrwork, lapack_int* iwork, lapack_int *info ); void LAPACK_dgesvj( char* joba, char* jobu, char* jobv, lapack_int* m, @@ -16190,12 +17236,12 @@ void LAPACK_sgesvj( char* joba, char* jobu, char* jobv, lapack_int* m, lapack_int* lwork, lapack_int *info ); void LAPACK_cgesvj( char* joba, char* jobu, char* jobv, lapack_int* m, lapack_int* n, lapack_complex_float* a, lapack_int* lda, float* sva, - lapack_int* mv, lapack_complex_float* v, lapack_int* ldv, - lapack_complex_float* cwork, lapack_int* lwork, float* rwork, + lapack_int* mv, lapack_complex_float* v, lapack_int* ldv, + lapack_complex_float* cwork, lapack_int* lwork, float* rwork, lapack_int* lrwork, lapack_int *info ); void LAPACK_zgesvj( char* joba, char* jobu, char* jobv, lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, double* sva, - lapack_int* mv, lapack_complex_double* v, lapack_int* ldv, + lapack_int* mv, lapack_complex_double* v, lapack_int* ldv, lapack_complex_double* cwork, lapack_int* lwork, double* rwork, lapack_int* lrwork, lapack_int *info ); void LAPACK_sggsvd( char* jobu, char* jobv, char* jobq, lapack_int* m, @@ -16979,16 +18025,16 @@ void LAPACK_zlagge( lapack_int* m, lapack_int* n, lapack_int* kl, lapack_int* lda, lapack_int* iseed, lapack_complex_double* work, lapack_int *info ); void LAPACK_slascl( char* type, lapack_int* kl, lapack_int* ku, float* cfrom, - float* cto, lapack_int* m, lapack_int* n, float* a, + float* cto, lapack_int* m, lapack_int* n, float* a, lapack_int* lda, lapack_int *info ); void LAPACK_dlascl( char* type, lapack_int* kl, lapack_int* ku, double* cfrom, - double* cto, lapack_int* m, lapack_int* n, double* a, + double* cto, lapack_int* m, lapack_int* n, double* a, lapack_int* lda, lapack_int *info ); void LAPACK_clascl( char* type, lapack_int* kl, lapack_int* ku, float* cfrom, - float* cto, lapack_int* m, lapack_int* n, lapack_complex_float* a, + float* cto, lapack_int* m, lapack_int* n, lapack_complex_float* a, lapack_int* lda, lapack_int *info ); void LAPACK_zlascl( char* type, lapack_int* kl, lapack_int* ku, double* cfrom, - double* cto, lapack_int* m, lapack_int* n, lapack_complex_double* a, + double* cto, lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, lapack_int *info ); void LAPACK_slaset( char* uplo, lapack_int* m, lapack_int* n, float* alpha, float* beta, float* a, lapack_int* lda ); @@ -17060,9 +18106,8 @@ void LAPACK_cbbcsd( char* jobu1, char* jobu2, float* b12e, float* b21d, float* b21e, float* b22d, float* b22e, float* rwork, lapack_int* lrwork , lapack_int *info ); -void LAPACK_cheswapr( char* uplo, lapack_int* n, - lapack_complex_float* a, lapack_int* i1, - lapack_int* i2 ); +void LAPACK_cheswapr( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_int* i1, lapack_int* i2 ); void LAPACK_chetri2( char* uplo, lapack_int* n, lapack_complex_float* a, lapack_int* lda, const lapack_int* ipiv, @@ -17079,10 +18124,10 @@ void LAPACK_chetrs2( char* uplo, lapack_int* n, void LAPACK_csyconv( char* uplo, char* way, lapack_int* n, lapack_complex_float* a, lapack_int* lda, const lapack_int* ipiv, - lapack_complex_float* work , lapack_int *info ); + lapack_complex_float* e , lapack_int *info ); void LAPACK_csyswapr( char* uplo, lapack_int* n, - lapack_complex_float* a, lapack_int* i1, - lapack_int* i2 ); + lapack_complex_float* a, lapack_int* lda, + lapack_int* i1, lapack_int* i2 ); void LAPACK_csytri2( char* uplo, lapack_int* n, lapack_complex_float* a, lapack_int* lda, const lapack_int* ipiv, @@ -17127,7 +18172,7 @@ void LAPACK_cuncsd2by1( char* jobu1, char* jobu2, char* jobv1t, lapack_int* m, lapack_int* p, lapack_int* q, lapack_complex_float* x11, lapack_int* ldx11, lapack_complex_float* x21, - lapack_int* ldx21, lapack_complex_float* theta, + lapack_int* ldx21, float* theta, lapack_complex_float* u1, lapack_int* ldu1, lapack_complex_float* u2, lapack_int* ldu2, lapack_complex_float* v1t, lapack_int* ldv1t, @@ -17173,13 +18218,13 @@ void LAPACK_dorcsd2by1( char* jobu1, char* jobu2, lapack_int* iwork , lapack_int *info ); void LAPACK_dsyconv( char* uplo, char* way, lapack_int* n, double* a, lapack_int* lda, - const lapack_int* ipiv, double* work , lapack_int *info ); -void LAPACK_dsyswapr( char* uplo, lapack_int* n, - double* a, lapack_int* i1, lapack_int* i2 ); + const lapack_int* ipiv, double* e , lapack_int *info ); +void LAPACK_dsyswapr( char* uplo, lapack_int* n, double* a, + lapack_int* lda, lapack_int* i1, lapack_int* i2 ); void LAPACK_dsytri2( char* uplo, lapack_int* n, double* a, lapack_int* lda, const lapack_int* ipiv, - lapack_complex_double* work, lapack_int* lwork , lapack_int *info ); + double* work, lapack_int* lwork , lapack_int *info ); void LAPACK_dsytri2x( char* uplo, lapack_int* n, double* a, lapack_int* lda, const lapack_int* ipiv, double* work, @@ -17227,13 +18272,13 @@ void LAPACK_sorcsd2by1( char* jobu1, char* jobu2, lapack_int* iwork , lapack_int *info ); void LAPACK_ssyconv( char* uplo, char* way, lapack_int* n, float* a, lapack_int* lda, - const lapack_int* ipiv, float* work , lapack_int *info ); -void LAPACK_ssyswapr( char* uplo, lapack_int* n, - float* a, lapack_int* i1, lapack_int* i2 ); + const lapack_int* ipiv, float* e , lapack_int *info ); +void LAPACK_ssyswapr( char* uplo, lapack_int* n, float* a, + lapack_int* lda, lapack_int* i1, lapack_int* i2 ); void LAPACK_ssytri2( char* uplo, lapack_int* n, float* a, lapack_int* lda, const lapack_int* ipiv, - lapack_complex_float* work, lapack_int* lwork , lapack_int *info ); + float* work, lapack_int* lwork , lapack_int *info ); void LAPACK_ssytri2x( char* uplo, lapack_int* n, float* a, lapack_int* lda, const lapack_int* ipiv, float* work, @@ -17254,9 +18299,8 @@ void LAPACK_zbbcsd( char* jobu1, char* jobu2, double* b12e, double* b21d, double* b21e, double* b22d, double* b22e, double* rwork, lapack_int* lrwork , lapack_int *info ); -void LAPACK_zheswapr( char* uplo, lapack_int* n, - lapack_complex_double* a, lapack_int* i1, - lapack_int* i2 ); +void LAPACK_zheswapr( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_int* i1, lapack_int* i2 ); void LAPACK_zhetri2( char* uplo, lapack_int* n, lapack_complex_double* a, lapack_int* lda, const lapack_int* ipiv, @@ -17274,9 +18318,9 @@ void LAPACK_zhetrs2( char* uplo, lapack_int* n, void LAPACK_zsyconv( char* uplo, char* way, lapack_int* n, lapack_complex_double* a, lapack_int* lda, const lapack_int* ipiv, - lapack_complex_double* work , lapack_int *info ); -void LAPACK_zsyswapr( char* uplo, lapack_int* n, - lapack_complex_double* a, lapack_int* i1, + lapack_complex_double* e , lapack_int *info ); +void LAPACK_zsyswapr( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_int* i1, lapack_int* i2 ); void LAPACK_zsytri2( char* uplo, lapack_int* n, lapack_complex_double* a, lapack_int* lda, @@ -17323,7 +18367,7 @@ void LAPACK_zuncsd2by1( char* jobu1, char* jobu2, char* jobv1t, lapack_int* m, lapack_int* p, lapack_int* q, lapack_complex_double* x11, lapack_int* ldx11, lapack_complex_double* x21, - lapack_int* ldx21, lapack_complex_double* theta, + lapack_int* ldx21, double* theta, lapack_complex_double* u1, lapack_int* ldu1, lapack_complex_double* u2, lapack_int* ldu2, lapack_complex_double* v1t, lapack_int* ldv1t, @@ -17497,54 +18541,518 @@ void LAPACK_csytrf_rook( char* uplo, lapack_int* n, lapack_complex_float* a, lapack_int* lda, lapack_int* ipiv, lapack_complex_float* work, lapack_int* lwork, lapack_int *info ); -void LAPACK_zsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, - lapack_complex_double* a, lapack_int* lda, - lapack_int* ipiv, lapack_complex_double* b, - lapack_int* ldb, lapack_complex_double* work, - lapack_int* lwork, lapack_int *info ); -void LAPACK_zsytrf_rook( char* uplo, lapack_int* n, lapack_complex_double* a, +void LAPACK_zsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, + lapack_int* ipiv, lapack_complex_double* b, + lapack_int* ldb, lapack_complex_double* work, + lapack_int* lwork, lapack_int *info ); +void LAPACK_zsytrf_rook( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_ssytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, const float* a, + lapack_int* lda, const lapack_int* ipiv, float* b, + lapack_int* ldb, lapack_int *info ); +void LAPACK_dsytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const double* a, lapack_int* lda, const lapack_int* ipiv, + double* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_csytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const lapack_complex_float* a, lapack_int* lda, + const lapack_int* ipiv, lapack_complex_float* b, + lapack_int* ldb, lapack_int *info ); +void LAPACK_zsytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_int* ipiv, lapack_complex_double* b, + lapack_int* ldb, lapack_int *info ); +void LAPACK_chetrf_rook( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zhetrf_rook( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_chetrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const lapack_complex_float* a, lapack_int* lda, + const lapack_int* ipiv, lapack_complex_float* b, + lapack_int* ldb, lapack_int *info ); +void LAPACK_zhetrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_int* ipiv, lapack_complex_double* b, + lapack_int* ldb, lapack_int *info ); + +void LAPACK_csyr( char* uplo, lapack_int* n, lapack_complex_float* alpha, + const lapack_complex_float* x, lapack_int* incx, + lapack_complex_float* a, lapack_int* lda ); +void LAPACK_zsyr( char* uplo, lapack_int* n, lapack_complex_double* alpha, + const lapack_complex_double* x, lapack_int* incx, + lapack_complex_double* a, lapack_int* lda ); +void LAPACK_ilaver( const lapack_int* vers_major, const lapack_int* vers_minor, + const lapack_int* vers_patch ); + +// LAPACK 3.7.0 +void LAPACK_ssysv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, float* a, + lapack_int* lda, lapack_int* ipiv, float* b, lapack_int* ldb, + float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsysv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, double* a, + lapack_int* lda, lapack_int* ipiv, double* b, + lapack_int* ldb, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_csysv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zsysv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_chesv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zhesv_aa( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); + +void LAPACK_ssytrf_aa( char* uplo, lapack_int* n, float* a, lapack_int* lda, + lapack_int* ipiv, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dsytrf_aa( char* uplo, lapack_int* n, double* a, lapack_int* lda, + lapack_int* ipiv, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_csytrf_aa( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zsytrf_aa( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_chetrf_aa( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zhetrf_aa( char* uplo, lapack_int* n, lapack_complex_double* a, lapack_int* lda, lapack_int* ipiv, lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); -void LAPACK_ssytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, const float* a, - lapack_int* lda, const lapack_int* ipiv, float* b, - lapack_int* ldb, lapack_int *info ); -void LAPACK_dsytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, - const double* a, lapack_int* lda, const lapack_int* ipiv, - double* b, lapack_int* ldb, lapack_int *info ); -void LAPACK_csytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, - const lapack_complex_float* a, lapack_int* lda, - const lapack_int* ipiv, lapack_complex_float* b, - lapack_int* ldb, lapack_int *info ); -void LAPACK_zsytrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, - const lapack_complex_double* a, lapack_int* lda, - const lapack_int* ipiv, lapack_complex_double* b, - lapack_int* ldb, lapack_int *info ); -void LAPACK_chetrf_rook( char* uplo, lapack_int* n, lapack_complex_float* a, - lapack_int* lda, lapack_int* ipiv, + +void LAPACK_ssytrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, const float* a, + lapack_int* lda, const lapack_int* ipiv, + float* b, lapack_int* ldb, float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsytrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, const double* a, + lapack_int* lda, const lapack_int* ipiv, + double* b, lapack_int* ldb, double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_csytrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, const lapack_complex_float* a, + lapack_int* lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work , lapack_int* lwork, lapack_int *info ); +void LAPACK_zsytrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_chetrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, const lapack_complex_float* a, + lapack_int* lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work , lapack_int* lwork, lapack_int *info ); +void LAPACK_zhetrs_aa( char* uplo, lapack_int* n, + lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); + +void LAPACK_ssysv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, float* a, + lapack_int* lda, float* e, lapack_int* ipiv, float* b, lapack_int* ldb, + float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsysv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, double* a, + lapack_int* lda, double* e, lapack_int* ipiv, double* b, + lapack_int* ldb, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_csysv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zsysv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_chesv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zhesv_rk( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); + +void LAPACK_ssytrf_rk( char* uplo, lapack_int* n, float* a, lapack_int* lda, + float* e, lapack_int* ipiv, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dsytrf_rk( char* uplo, lapack_int* n, double* a, lapack_int* lda, + double* e, lapack_int* ipiv, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_csytrf_rk( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_complex_float* e, lapack_int* ipiv, lapack_complex_float* work, lapack_int* lwork, lapack_int *info ); -void LAPACK_zhetrf_rook( char* uplo, lapack_int* n, lapack_complex_double* a, - lapack_int* lda, lapack_int* ipiv, +void LAPACK_zsytrf_rk( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_complex_double* e, lapack_int* ipiv, lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); -void LAPACK_chetrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, +void LAPACK_chetrf_rk( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, lapack_complex_float* e, lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zhetrf_rk( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); + +void LAPACK_ssytrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, const float* a, + lapack_int* lda, const float* e, const lapack_int* ipiv, + float* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_dsytrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, const double* a, + lapack_int* lda, const double* e, const lapack_int* ipiv, + double* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_csytrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, const lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_zsytrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_chetrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, const lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int* ldb, lapack_int *info ); +void LAPACK_zhetrs_3( char* uplo, lapack_int* n, + lapack_int* nrhs, + const lapack_complex_double* a, lapack_int* lda, + const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int* ldb, lapack_int *info ); + +void LAPACK_ssytri_3( char* uplo, lapack_int* n, float* a, lapack_int* lda, const float* e, + const lapack_int* ipiv, float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsytri_3( char* uplo, lapack_int* n, double* a, lapack_int* lda, const double* e, + const lapack_int* ipiv, double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_csytri_3( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_zsytri_3( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_chetri_3( char* uplo, lapack_int* n, lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_zhetri_3( char* uplo, lapack_int* n, lapack_complex_double* a, + lapack_int* lda, const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int* lwork, lapack_int *info ); + +void LAPACK_ssycon_3( char* uplo, lapack_int* n, const float* a, lapack_int* lda, const float* e, + const lapack_int* ipiv, float* anorm, float* rcond, + float* work, lapack_int* iwork, lapack_int *info ); +void LAPACK_dsycon_3( char* uplo, lapack_int* n, const double* a, lapack_int* lda, const double* e, + const lapack_int* ipiv, double* anorm, double* rcond, + double* work, lapack_int* iwork, lapack_int *info ); +void LAPACK_csycon_3( char* uplo, lapack_int* n, const lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, const lapack_int* ipiv, float* anorm, + float* rcond, lapack_complex_float* work, + lapack_int *info ); +void LAPACK_zsycon_3( char* uplo, lapack_int* n, const lapack_complex_double* a, + lapack_int* lda, const lapack_complex_double* e, const lapack_int* ipiv, double* anorm, + double* rcond, lapack_complex_double* work, + lapack_int *info ); +void LAPACK_checon_3( char* uplo, lapack_int* n, const lapack_complex_float* a, + lapack_int* lda, const lapack_complex_float* e, const lapack_int* ipiv, float* anorm, + float* rcond, lapack_complex_float* work, + lapack_int *info ); +void LAPACK_zhecon_3( char* uplo, lapack_int* n, const lapack_complex_double* a, + lapack_int* lda, const lapack_complex_double* e, const lapack_int* ipiv, double* anorm, + double* rcond, lapack_complex_double* work, + lapack_int *info ); + +void LAPACK_sgelq( lapack_int* m, lapack_int* n, float* a, lapack_int* lda, + float* t, lapack_int* tsize, float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_dgelq( lapack_int* m, lapack_int* n, double* a, lapack_int* lda, + double* t, lapack_int* tsize, double* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_cgelq( lapack_int* m, lapack_int* n, lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* t, lapack_int* tsize, lapack_complex_float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_zgelq( lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* t, lapack_int* tsize, lapack_complex_double* work, lapack_int* lwork, + lapack_int* info ); + +void LAPACK_sgemlq( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const float* a, lapack_int* lda, + const float* t, lapack_int* tsize, + float* c, lapack_int* ldc, + float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_dgemlq( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const double* a, lapack_int* lda, + const double* t, lapack_int* tsize, + double* c, lapack_int* ldc, + double* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_cgemlq( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, const lapack_complex_float* a, lapack_int* lda, - const lapack_int* ipiv, lapack_complex_float* b, - lapack_int* ldb, lapack_int *info ); -void LAPACK_zhetrs_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + const lapack_complex_float* t, lapack_int* tsize, + lapack_complex_float* c, lapack_int* ldc, + lapack_complex_float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_zgemlq( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, const lapack_complex_double* a, lapack_int* lda, - const lapack_int* ipiv, lapack_complex_double* b, - lapack_int* ldb, lapack_int *info ); + const lapack_complex_double* t, lapack_int* tsize, + lapack_complex_double* c, lapack_int* ldc, + lapack_complex_double* work, lapack_int* lwork, + lapack_int* info ); + +void LAPACK_sgeqr( lapack_int* m, lapack_int* n, float* a, lapack_int* lda, + float* t, lapack_int* tsize, float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_dgeqr( lapack_int* m, lapack_int* n, double* a, lapack_int* lda, + double* t, lapack_int* tsize, double* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_cgeqr( lapack_int* m, lapack_int* n, lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* t, lapack_int* tsize, lapack_complex_float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_zgeqr( lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* t, lapack_int* tsize, lapack_complex_double* work, lapack_int* lwork, + lapack_int* info ); + +void LAPACK_sgemqr( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const float* a, lapack_int* lda, + const float* t, lapack_int* tsize, + float* c, lapack_int* ldc, + float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_dgemqr( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const double* a, lapack_int* lda, + const double* t, lapack_int* tsize, + double* c, lapack_int* ldc, + double* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_cgemqr( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const lapack_complex_float* a, lapack_int* lda, + const lapack_complex_float* t, lapack_int* tsize, + lapack_complex_float* c, lapack_int* ldc, + lapack_complex_float* work, lapack_int* lwork, + lapack_int* info ); +void LAPACK_zgemqr( char* side, char* trans, lapack_int* m, lapack_int* n, lapack_int* k, + const lapack_complex_double* a, lapack_int* lda, + const lapack_complex_double* t, lapack_int* tsize, + lapack_complex_double* c, lapack_int* ldc, + lapack_complex_double* work, lapack_int* lwork, + lapack_int* info ); -void LAPACK_csyr( char* uplo, lapack_int* n, lapack_complex_float* alpha, - const lapack_complex_float* x, lapack_int* incx, - lapack_complex_float* a, lapack_int* lda ); -void LAPACK_zsyr( char* uplo, lapack_int* n, lapack_complex_double* alpha, - const lapack_complex_double* x, lapack_int* incx, - lapack_complex_double* a, lapack_int* lda ); -void LAPACK_ilaver( const lapack_int* vers_major, const lapack_int* vers_minor, - const lapack_int* vers_patch ); +void LAPACK_sgetsls( char* trans, lapack_int* m, lapack_int* n, lapack_int* nrhs, + float* a, lapack_int* lda, float* b, lapack_int* ldb, + float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dgetsls( char* trans, lapack_int* m, lapack_int* n, lapack_int* nrhs, + double* a, lapack_int* lda, double* b, lapack_int* ldb, + double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_cgetsls( char* trans, lapack_int* m, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zgetsls( char* trans, lapack_int* m, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); + +void LAPACK_ssyev_2stage( char* jobz, char* uplo, lapack_int* n, float* a, + lapack_int* lda, float* w, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dsyev_2stage( char* jobz, char* uplo, lapack_int* n, double* a, + lapack_int* lda, double* w, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_cheev_2stage( char* jobz, char* uplo, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, float* w, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int *info ); +void LAPACK_zheev_2stage( char* jobz, char* uplo, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, double* w, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int *info ); +void LAPACK_ssyevd_2stage( char* jobz, char* uplo, lapack_int* n, float* a, + lapack_int* lda, float* w, float* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_dsyevd_2stage( char* jobz, char* uplo, lapack_int* n, double* a, + lapack_int* lda, double* w, double* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_cheevd_2stage( char* jobz, char* uplo, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, float* w, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int* lrwork, lapack_int* iwork, lapack_int* liwork, + lapack_int *info ); +void LAPACK_zheevd_2stage( char* jobz, char* uplo, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, double* w, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int* lrwork, lapack_int* iwork, + lapack_int* liwork, lapack_int *info ); +void LAPACK_ssyevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + float* a, lapack_int* lda, float* vl, float* vu, + lapack_int* il, lapack_int* iu, float* abstol, + lapack_int* m, float* w, float* z, lapack_int* ldz, + float* work, lapack_int* lwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_dsyevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + double* a, lapack_int* lda, double* vl, double* vu, + lapack_int* il, lapack_int* iu, double* abstol, + lapack_int* m, double* w, double* z, lapack_int* ldz, + double* work, lapack_int* lwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_cheevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, float* vl, + float* vu, lapack_int* il, lapack_int* iu, float* abstol, + lapack_int* m, float* w, lapack_complex_float* z, + lapack_int* ldz, lapack_complex_float* work, + lapack_int* lwork, float* rwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_zheevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, double* vl, + double* vu, lapack_int* il, lapack_int* iu, double* abstol, + lapack_int* m, double* w, lapack_complex_double* z, + lapack_int* ldz, lapack_complex_double* work, + lapack_int* lwork, double* rwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_ssyevr_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + float* a, lapack_int* lda, float* vl, float* vu, + lapack_int* il, lapack_int* iu, float* abstol, + lapack_int* m, float* w, float* z, lapack_int* ldz, + lapack_int* isuppz, float* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_dsyevr_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + double* a, lapack_int* lda, double* vl, double* vu, + lapack_int* il, lapack_int* iu, double* abstol, + lapack_int* m, double* w, double* z, lapack_int* ldz, + lapack_int* isuppz, double* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_cheevr_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, float* vl, + float* vu, lapack_int* il, lapack_int* iu, float* abstol, + lapack_int* m, float* w, lapack_complex_float* z, + lapack_int* ldz, lapack_int* isuppz, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int* lrwork, lapack_int* iwork, lapack_int* liwork, + lapack_int *info ); +void LAPACK_zheevr_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, double* vl, + double* vu, lapack_int* il, lapack_int* iu, double* abstol, + lapack_int* m, double* w, lapack_complex_double* z, + lapack_int* ldz, lapack_int* isuppz, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int* lrwork, lapack_int* iwork, + lapack_int* liwork, lapack_int *info ); +void LAPACK_ssbev_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + float* ab, lapack_int* ldab, float* w, float* z, + lapack_int* ldz, float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsbev_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + double* ab, lapack_int* ldab, double* w, double* z, + lapack_int* ldz, double* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_chbev_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + lapack_complex_float* ab, lapack_int* ldab, float* w, + lapack_complex_float* z, lapack_int* ldz, + lapack_complex_float* work, lapack_int* lwork, float* rwork, lapack_int *info ); +void LAPACK_zhbev_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + lapack_complex_double* ab, lapack_int* ldab, double* w, + lapack_complex_double* z, lapack_int* ldz, + lapack_complex_double* work, lapack_int* lwork, double* rwork, + lapack_int *info ); +void LAPACK_ssbevd_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + float* ab, lapack_int* ldab, float* w, float* z, + lapack_int* ldz, float* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_dsbevd_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + double* ab, lapack_int* ldab, double* w, double* z, + lapack_int* ldz, double* work, lapack_int* lwork, + lapack_int* iwork, lapack_int* liwork, lapack_int *info ); +void LAPACK_chbevd_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + lapack_complex_float* ab, lapack_int* ldab, float* w, + lapack_complex_float* z, lapack_int* ldz, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int* lrwork, lapack_int* iwork, lapack_int* liwork, + lapack_int *info ); +void LAPACK_zhbevd_2stage( char* jobz, char* uplo, lapack_int* n, lapack_int* kd, + lapack_complex_double* ab, lapack_int* ldab, double* w, + lapack_complex_double* z, lapack_int* ldz, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int* lrwork, lapack_int* iwork, + lapack_int* liwork, lapack_int *info ); +void LAPACK_ssbevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_int* kd, float* ab, lapack_int* ldab, float* q, + lapack_int* ldq, float* vl, float* vu, lapack_int* il, + lapack_int* iu, float* abstol, lapack_int* m, float* w, + float* z, lapack_int* ldz, float* work, lapack_int* lwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_dsbevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_int* kd, double* ab, lapack_int* ldab, double* q, + lapack_int* ldq, double* vl, double* vu, lapack_int* il, + lapack_int* iu, double* abstol, lapack_int* m, double* w, + double* z, lapack_int* ldz, double* work, lapack_int* lwork, lapack_int* iwork, + lapack_int* ifail, lapack_int *info ); +void LAPACK_chbevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_int* kd, lapack_complex_float* ab, lapack_int* ldab, + lapack_complex_float* q, lapack_int* ldq, float* vl, + float* vu, lapack_int* il, lapack_int* iu, float* abstol, + lapack_int* m, float* w, lapack_complex_float* z, + lapack_int* ldz, lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int* iwork, lapack_int* ifail, lapack_int *info ); +void LAPACK_zhbevx_2stage( char* jobz, char* range, char* uplo, lapack_int* n, + lapack_int* kd, lapack_complex_double* ab, lapack_int* ldab, + lapack_complex_double* q, lapack_int* ldq, double* vl, + double* vu, lapack_int* il, lapack_int* iu, double* abstol, + lapack_int* m, double* w, lapack_complex_double* z, + lapack_int* ldz, lapack_complex_double* work, lapack_int* lwork, double* rwork, + lapack_int* iwork, lapack_int* ifail, lapack_int *info ); +void LAPACK_ssygv_2stage( lapack_int* itype, char* jobz, char* uplo, lapack_int* n, + float* a, lapack_int* lda, float* b, lapack_int* ldb, + float* w, float* work, lapack_int* lwork, lapack_int *info ); +void LAPACK_dsygv_2stage( lapack_int* itype, char* jobz, char* uplo, lapack_int* n, + double* a, lapack_int* lda, double* b, lapack_int* ldb, + double* w, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_chegv_2stage( lapack_int* itype, char* jobz, char* uplo, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* b, lapack_int* ldb, float* w, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int *info ); +void LAPACK_zhegv_2stage( lapack_int* itype, char* jobz, char* uplo, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* b, lapack_int* ldb, double* w, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int *info ); #ifdef __cplusplus } diff --git a/lapack-netlib/LAPACKE/include/lapacke_config.h b/lapack-netlib/LAPACKE/include/lapacke_config.h index 8262c3488b..1e2509bf01 100644 --- a/lapack-netlib/LAPACKE/include/lapacke_config.h +++ b/lapack-netlib/LAPACKE/include/lapacke_config.h @@ -34,13 +34,6 @@ #ifndef _LAPACKE_CONFIG_H_ #define _LAPACKE_CONFIG_H_ -// For Android prior to API 21 (no include) -#if defined(__ANDROID__) -#if __ANDROID_API__ < 21 -#define LAPACK_COMPLEX_STRUCTURE -#endif -#endif - #ifdef __cplusplus #if defined(LAPACK_COMPLEX_CPP) #include diff --git a/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h b/lapack-netlib/LAPACKE/include/lapacke_mangling.h similarity index 100% rename from lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h rename to lapack-netlib/LAPACKE/include/lapacke_mangling.h diff --git a/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h.in b/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h.in new file mode 100644 index 0000000000..6211fd144d --- /dev/null +++ b/lapack-netlib/LAPACKE/include/lapacke_mangling_with_flags.h.in @@ -0,0 +1,17 @@ +#ifndef LAPACK_HEADER_INCLUDED +#define LAPACK_HEADER_INCLUDED + +#ifndef LAPACK_GLOBAL +#if defined(LAPACK_GLOBAL_PATTERN_LC) || defined(ADD_) +#define LAPACK_GLOBAL(lcname,UCNAME) lcname##_ +#elif defined(LAPACK_GLOBAL_PATTERN_UC) || defined(UPPER) +#define LAPACK_GLOBAL(lcname,UCNAME) UCNAME +#elif defined(LAPACK_GLOBAL_PATTERN_MC) || defined(NOCHANGE) +#define LAPACK_GLOBAL(lcname,UCNAME) lcname +#else +#define LAPACK_GLOBAL(lcname,UCNAME) lcname##_ +#endif +#endif + +#endif + diff --git a/lapack-netlib/LAPACKE/lapacke.pc.in b/lapack-netlib/LAPACKE/lapacke.pc.in index 75e687198c..028f8da6db 100644 --- a/lapack-netlib/LAPACKE/lapacke.pc.in +++ b/lapack-netlib/LAPACKE/lapacke.pc.in @@ -1,9 +1,9 @@ prefix=@prefix@ libdir=@libdir@ -Name: lapacke +Name: LAPACKE Description: C Standard Interface to LAPACK Linear Algebra PACKage Version: @LAPACK_VERSION@ -URL: http://www.netlib.org/lapack/ +URL: http://www.netlib.org/lapack/#_standard_c_language_apis_for_lapack Libs: -L${libdir} -llapacke Requires: lapack blas diff --git a/lapack-netlib/LAPACKE/src/CMakeLists.txt b/lapack-netlib/LAPACKE/src/CMakeLists.txt index 59da093008..1144e977c7 100644 --- a/lapack-netlib/LAPACKE/src/CMakeLists.txt +++ b/lapack-netlib/LAPACKE/src/CMakeLists.txt @@ -1,6 +1,6 @@ -#AUX_SOURCE_DIRECTORY(${CMAKE_CURRENT_SOURCE_DIR} SRC_OBJ) +#aux_source_directory(${CMAKE_CURRENT_SOURCE_DIR} SRC_OBJ) -SET (SRC_OBJ +set(SRC_OBJ lapacke_cbbcsd.c lapacke_cbbcsd_work.c lapacke_cbdsqr.c @@ -59,6 +59,8 @@ lapacke_cgelss.c lapacke_cgelss_work.c lapacke_cgelsy.c lapacke_cgelsy_work.c +lapacke_cgemqr.c +lapacke_cgemqr_work.c lapacke_cgemqrt.c lapacke_cgemqrt_work.c lapacke_cgeqlf.c @@ -103,6 +105,8 @@ lapacke_cgetri.c lapacke_cgetri_work.c lapacke_cgetrs.c lapacke_cgetrs_work.c +lapacke_cgetsls.c +lapacke_cgetsls_work.c lapacke_cggbak.c lapacke_cggbak_work.c lapacke_cggbal.c @@ -153,6 +157,12 @@ lapacke_chbevd.c lapacke_chbevd_work.c lapacke_chbevx.c lapacke_chbevx_work.c +lapacke_chbev_2stage.c +lapacke_chbev_2stage_work.c +lapacke_chbevd_2stage.c +lapacke_chbevd_2stage_work.c +lapacke_chbevx_2stage.c +lapacke_chbevx_2stage_work.c lapacke_chbgst.c lapacke_chbgst_work.c lapacke_chbgv.c @@ -165,6 +175,8 @@ lapacke_chbtrd.c lapacke_chbtrd_work.c lapacke_checon.c lapacke_checon_work.c +lapacke_checon_3.c +lapacke_checon_3_work.c lapacke_cheequb.c lapacke_cheequb_work.c lapacke_cheev.c @@ -175,10 +187,20 @@ lapacke_cheevr.c lapacke_cheevr_work.c lapacke_cheevx.c lapacke_cheevx_work.c +lapacke_cheev_2stage.c +lapacke_cheev_2stage_work.c +lapacke_cheevd_2stage.c +lapacke_cheevd_2stage_work.c +lapacke_cheevr_2stage.c +lapacke_cheevr_2stage_work.c +lapacke_cheevx_2stage.c +lapacke_cheevx_2stage_work.c lapacke_chegst.c lapacke_chegst_work.c lapacke_chegv.c lapacke_chegv_work.c +lapacke_chegv_2stage.c +lapacke_chegv_2stage_work.c lapacke_chegvd.c lapacke_chegvd_work.c lapacke_chegvx.c @@ -187,6 +209,10 @@ lapacke_cherfs.c lapacke_cherfs_work.c lapacke_chesv.c lapacke_chesv_work.c +lapacke_chesv_aa.c +lapacke_chesv_aa_work.c +lapacke_chesv_rk.c +lapacke_chesv_rk_work.c lapacke_chesvx.c lapacke_chesvx_work.c lapacke_cheswapr.c @@ -197,9 +223,15 @@ lapacke_chetrf.c lapacke_chetrf_rook.c lapacke_chetrf_work.c lapacke_chetrf_rook_work.c +lapacke_chetrf_aa.c +lapacke_chetrf_aa_work.c +lapacke_chetrf_rk.c +lapacke_chetrf_rk_work.c lapacke_chetri.c lapacke_chetri2.c lapacke_chetri2_work.c +lapacke_chetri_3.c +lapacke_chetri_3_work.c lapacke_chetri2x.c lapacke_chetri2x_work.c lapacke_chetri_work.c @@ -209,6 +241,10 @@ lapacke_chetrs2.c lapacke_chetrs2_work.c lapacke_chetrs_work.c lapacke_chetrs_rook_work.c +lapacke_chetrs_aa.c +lapacke_chetrs_aa_work.c +lapacke_chetrs_3.c +lapacke_chetrs_3_work.c lapacke_chfrk.c lapacke_chfrk_work.c lapacke_chgeqz.c @@ -387,6 +423,8 @@ lapacke_csteqr.c lapacke_csteqr_work.c lapacke_csycon.c lapacke_csycon_work.c +lapacke_csycon_3.c +lapacke_csycon_3_work.c lapacke_csyconv.c lapacke_csyconv_work.c lapacke_csyequb.c @@ -397,6 +435,10 @@ lapacke_csysv.c lapacke_csysv_rook.c lapacke_csysv_rook_work.c lapacke_csysv_work.c +lapacke_csysv_aa.c +lapacke_csysv_aa_work.c +lapacke_csysv_rk.c +lapacke_csysv_rk_work.c lapacke_csysvx.c lapacke_csysvx_work.c lapacke_csyswapr.c @@ -405,9 +447,15 @@ lapacke_csytrf.c lapacke_csytrf_work.c lapacke_csytrf_rook.c lapacke_csytrf_rook_work.c +lapacke_csytrf_aa.c +lapacke_csytrf_aa_work.c +lapacke_csytrf_rk.c +lapacke_csytrf_rk_work.c lapacke_csytri.c lapacke_csytri2.c lapacke_csytri2_work.c +lapacke_csytri_3.c +lapacke_csytri_3_work.c lapacke_csytri2x.c lapacke_csytri2x_work.c lapacke_csytri_work.c @@ -417,6 +465,10 @@ lapacke_csytrs2.c lapacke_csytrs2_work.c lapacke_csytrs_work.c lapacke_csytrs_rook_work.c +lapacke_csytrs_aa.c +lapacke_csytrs_aa_work.c +lapacke_csytrs_3.c +lapacke_csytrs_3_work.c lapacke_ctbcon.c lapacke_ctbcon_work.c lapacke_ctbrfs.c @@ -591,6 +643,8 @@ lapacke_dgelss.c lapacke_dgelss_work.c lapacke_dgelsy.c lapacke_dgelsy_work.c +lapacke_dgemqr.c +lapacke_dgemqr_work.c lapacke_dgemqrt.c lapacke_dgemqrt_work.c lapacke_dgeqlf.c @@ -635,6 +689,8 @@ lapacke_dgetri.c lapacke_dgetri_work.c lapacke_dgetrs.c lapacke_dgetrs_work.c +lapacke_dgetsls.c +lapacke_dgetsls_work.c lapacke_dggbak.c lapacke_dggbak_work.c lapacke_dggbal.c @@ -851,6 +907,12 @@ lapacke_dsbevd.c lapacke_dsbevd_work.c lapacke_dsbevx.c lapacke_dsbevx_work.c +lapacke_dsbev_2stage.c +lapacke_dsbev_2stage_work.c +lapacke_dsbevd_2stage.c +lapacke_dsbevd_2stage_work.c +lapacke_dsbevx_2stage.c +lapacke_dsbevx_2stage_work.c lapacke_dsbgst.c lapacke_dsbgst_work.c lapacke_dsbgv.c @@ -921,6 +983,8 @@ lapacke_dstevx.c lapacke_dstevx_work.c lapacke_dsycon.c lapacke_dsycon_work.c +lapacke_dsycon_3.c +lapacke_dsycon_3_work.c lapacke_dsyconv.c lapacke_dsyconv_work.c lapacke_dsyequb.c @@ -933,10 +997,20 @@ lapacke_dsyevr.c lapacke_dsyevr_work.c lapacke_dsyevx.c lapacke_dsyevx_work.c +lapacke_dsyev_2stage.c +lapacke_dsyev_2stage_work.c +lapacke_dsyevd_2stage.c +lapacke_dsyevd_2stage_work.c +lapacke_dsyevr_2stage.c +lapacke_dsyevr_2stage_work.c +lapacke_dsyevx_2stage.c +lapacke_dsyevx_2stage_work.c lapacke_dsygst.c lapacke_dsygst_work.c lapacke_dsygv.c lapacke_dsygv_work.c +lapacke_dsygv_2stage.c +lapacke_dsygv_2stage_work.c lapacke_dsygvd.c lapacke_dsygvd_work.c lapacke_dsygvx.c @@ -947,6 +1021,10 @@ lapacke_dsysv.c lapacke_dsysv_rook.c lapacke_dsysv_rook_work.c lapacke_dsysv_work.c +lapacke_dsysv_aa.c +lapacke_dsysv_aa_work.c +lapacke_dsysv_rk.c +lapacke_dsysv_rk_work.c lapacke_dsysvx.c lapacke_dsysvx_work.c lapacke_dsyswapr.c @@ -957,9 +1035,15 @@ lapacke_dsytrf.c lapacke_dsytrf_work.c lapacke_dsytrf_rook.c lapacke_dsytrf_rook_work.c +lapacke_dsytrf_aa.c +lapacke_dsytrf_aa_work.c +lapacke_dsytrf_rk.c +lapacke_dsytrf_rk_work.c lapacke_dsytri.c lapacke_dsytri2.c lapacke_dsytri2_work.c +lapacke_dsytri_3.c +lapacke_dsytri_3_work.c lapacke_dsytri2x.c lapacke_dsytri2x_work.c lapacke_dsytri_work.c @@ -967,6 +1051,10 @@ lapacke_dsytrs.c lapacke_dsytrs_rook.c lapacke_dsytrs2.c lapacke_dsytrs2_work.c +lapacke_dsytrs_aa.c +lapacke_dsytrs_aa_work.c +lapacke_dsytrs_3.c +lapacke_dsytrs_3_work.c lapacke_dsytrs_work.c lapacke_dsytrs_rook_work.c lapacke_dtbcon.c @@ -1103,6 +1191,8 @@ lapacke_sgelss.c lapacke_sgelss_work.c lapacke_sgelsy.c lapacke_sgelsy_work.c +lapacke_sgemqr.c +lapacke_sgemqr_work.c lapacke_sgemqrt.c lapacke_sgemqrt_work.c lapacke_sgeqlf.c @@ -1147,6 +1237,8 @@ lapacke_sgetri.c lapacke_sgetri_work.c lapacke_sgetrs.c lapacke_sgetrs_work.c +lapacke_sgetsls.c +lapacke_sgetsls_work.c lapacke_sggbak.c lapacke_sggbak_work.c lapacke_sggbal.c @@ -1363,6 +1455,12 @@ lapacke_ssbevd.c lapacke_ssbevd_work.c lapacke_ssbevx.c lapacke_ssbevx_work.c +lapacke_ssbev_2stage.c +lapacke_ssbev_2stage_work.c +lapacke_ssbevd_2stage.c +lapacke_ssbevd_2stage_work.c +lapacke_ssbevx_2stage.c +lapacke_ssbevx_2stage_work.c lapacke_ssbgst.c lapacke_ssbgst_work.c lapacke_ssbgv.c @@ -1429,6 +1527,8 @@ lapacke_sstevx.c lapacke_sstevx_work.c lapacke_ssycon.c lapacke_ssycon_work.c +lapacke_ssycon_3.c +lapacke_ssycon_3_work.c lapacke_ssyconv.c lapacke_ssyconv_work.c lapacke_ssyequb.c @@ -1441,10 +1541,20 @@ lapacke_ssyevr.c lapacke_ssyevr_work.c lapacke_ssyevx.c lapacke_ssyevx_work.c +lapacke_ssyev_2stage.c +lapacke_ssyev_2stage_work.c +lapacke_ssyevd_2stage.c +lapacke_ssyevd_2stage_work.c +lapacke_ssyevr_2stage.c +lapacke_ssyevr_2stage_work.c +lapacke_ssyevx_2stage.c +lapacke_ssyevx_2stage_work.c lapacke_ssygst.c lapacke_ssygst_work.c lapacke_ssygv.c lapacke_ssygv_work.c +lapacke_ssygv_2stage.c +lapacke_ssygv_2stage_work.c lapacke_ssygvd.c lapacke_ssygvd_work.c lapacke_ssygvx.c @@ -1455,6 +1565,10 @@ lapacke_ssysv.c lapacke_ssysv_rook.c lapacke_ssysv_rook_work.c lapacke_ssysv_work.c +lapacke_ssysv_aa.c +lapacke_ssysv_aa_work.c +lapacke_ssysv_rk.c +lapacke_ssysv_rk_work.c lapacke_ssysvx.c lapacke_ssysvx_work.c lapacke_ssyswapr.c @@ -1465,9 +1579,15 @@ lapacke_ssytrf.c lapacke_ssytrf_work.c lapacke_ssytrf_rook.c lapacke_ssytrf_rook_work.c +lapacke_ssytrf_aa.c +lapacke_ssytrf_aa_work.c +lapacke_ssytrf_rk.c +lapacke_ssytrf_rk_work.c lapacke_ssytri.c lapacke_ssytri2.c lapacke_ssytri2_work.c +lapacke_ssytri_3.c +lapacke_ssytri_3_work.c lapacke_ssytri2x.c lapacke_ssytri2x_work.c lapacke_ssytri_work.c @@ -1475,6 +1595,10 @@ lapacke_ssytrs.c lapacke_ssytrs_rook.c lapacke_ssytrs2.c lapacke_ssytrs2_work.c +lapacke_ssytrs_aa.c +lapacke_ssytrs_aa_work.c +lapacke_ssytrs_3.c +lapacke_ssytrs_3_work.c lapacke_ssytrs_work.c lapacke_ssytrs_rook_work.c lapacke_stbcon.c @@ -1609,6 +1733,8 @@ lapacke_zgelss.c lapacke_zgelss_work.c lapacke_zgelsy.c lapacke_zgelsy_work.c +lapacke_zgemqr.c +lapacke_zgemqr_work.c lapacke_zgemqrt.c lapacke_zgemqrt_work.c lapacke_zgeqlf.c @@ -1653,6 +1779,8 @@ lapacke_zgetri.c lapacke_zgetri_work.c lapacke_zgetrs.c lapacke_zgetrs_work.c +lapacke_zgetsls.c +lapacke_zgetsls_work.c lapacke_zggbak.c lapacke_zggbak_work.c lapacke_zggbal.c @@ -1715,6 +1843,8 @@ lapacke_zhbtrd.c lapacke_zhbtrd_work.c lapacke_zhecon.c lapacke_zhecon_work.c +lapacke_zhecon_3.c +lapacke_zhecon_3_work.c lapacke_zheequb.c lapacke_zheequb_work.c lapacke_zheev.c @@ -1725,10 +1855,20 @@ lapacke_zheevr.c lapacke_zheevr_work.c lapacke_zheevx.c lapacke_zheevx_work.c +lapacke_zheev_2stage.c +lapacke_zheev_2stage_work.c +lapacke_zheevd_2stage.c +lapacke_zheevd_2stage_work.c +lapacke_zheevr_2stage.c +lapacke_zheevr_2stage_work.c +lapacke_zheevx_2stage.c +lapacke_zheevx_2stage_work.c lapacke_zhegst.c lapacke_zhegst_work.c lapacke_zhegv.c lapacke_zhegv_work.c +lapacke_zhegv_2stage.c +lapacke_zhegv_2stage_work.c lapacke_zhegvd.c lapacke_zhegvd_work.c lapacke_zhegvx.c @@ -1737,6 +1877,10 @@ lapacke_zherfs.c lapacke_zherfs_work.c lapacke_zhesv.c lapacke_zhesv_work.c +lapacke_zhesv_aa.c +lapacke_zhesv_aa_work.c +lapacke_zhesv_rk.c +lapacke_zhesv_rk_work.c lapacke_zhesvx.c lapacke_zhesvx_work.c lapacke_zheswapr.c @@ -1747,9 +1891,15 @@ lapacke_zhetrf.c lapacke_zhetrf_rook.c lapacke_zhetrf_work.c lapacke_zhetrf_rook_work.c +lapacke_zhetrf_aa.c +lapacke_zhetrf_aa_work.c +lapacke_zhetrf_rk.c +lapacke_zhetrf_rk_work.c lapacke_zhetri.c lapacke_zhetri2.c lapacke_zhetri2_work.c +lapacke_zhetri_3.c +lapacke_zhetri_3_work.c lapacke_zhetri2x.c lapacke_zhetri2x_work.c lapacke_zhetri_work.c @@ -1758,6 +1908,10 @@ lapacke_zhetrs_rook.c lapacke_zhetrs2.c lapacke_zhetrs2_work.c lapacke_zhetrs_work.c +lapacke_zhetrs_aa.c +lapacke_zhetrs_aa_work.c +lapacke_zhetrs_3.c +lapacke_zhetrs_3_work.c lapacke_zhetrs_rook_work.c lapacke_zhfrk.c lapacke_zhfrk_work.c @@ -1937,6 +2091,8 @@ lapacke_zsteqr.c lapacke_zsteqr_work.c lapacke_zsycon.c lapacke_zsycon_work.c +lapacke_zsycon_3.c +lapacke_zsycon_3_work.c lapacke_zsyconv.c lapacke_zsyconv_work.c lapacke_zsyequb.c @@ -1947,6 +2103,10 @@ lapacke_zsysv.c lapacke_zsysv_rook.c lapacke_zsysv_rook_work.c lapacke_zsysv_work.c +lapacke_zsysv_aa.c +lapacke_zsysv_aa_work.c +lapacke_zsysv_rk.c +lapacke_zsysv_rk_work.c lapacke_zsysvx.c lapacke_zsysvx_work.c lapacke_zsyswapr.c @@ -1955,9 +2115,15 @@ lapacke_zsytrf.c lapacke_zsytrf_work.c lapacke_zsytrf_rook.c lapacke_zsytrf_rook_work.c +lapacke_zsytrf_aa.c +lapacke_zsytrf_aa_work.c +lapacke_zsytrf_rk.c +lapacke_zsytrf_rk_work.c lapacke_zsytri.c lapacke_zsytri2.c lapacke_zsytri2_work.c +lapacke_zsytri_3.c +lapacke_zsytri_3_work.c lapacke_zsytri2x.c lapacke_zsytri2x_work.c lapacke_zsytri_work.c @@ -1967,6 +2133,10 @@ lapacke_zsytrs2.c lapacke_zsytrs2_work.c lapacke_zsytrs_work.c lapacke_zsytrs_rook_work.c +lapacke_zsytrs_aa.c +lapacke_zsytrs_aa_work.c +lapacke_zsytrs_3.c +lapacke_zsytrs_3_work.c lapacke_ztbcon.c lapacke_ztbcon_work.c lapacke_ztbrfs.c @@ -2085,7 +2255,7 @@ lapacke_ilaver.c ) if(BUILD_DEPRECATED) - LIST(APPEND SRC_OBJ + list(APPEND SRC_OBJ lapacke_cggsvp.c lapacke_cggsvp_work.c lapacke_dggsvp.c @@ -2113,7 +2283,7 @@ if(BUILD_DEPRECATED) message(STATUS "Building LAPACKE deprecated routines") endif() -SET(SRCX_OBJ +set(SRCX_OBJ lapacke_cgbrfsx.c lapacke_cporfsx.c lapacke_dgerfsx.c lapacke_sgbrfsx.c lapacke_ssyrfsx.c lapacke_zherfsx.c lapacke_cgbrfsx_work.c lapacke_cporfsx_work.c lapacke_dgerfsx_work.c lapacke_sgbrfsx_work.c lapacke_ssyrfsx_work.c lapacke_zherfsx_work.c lapacke_cgerfsx.c lapacke_csyrfsx.c lapacke_dporfsx.c lapacke_sgerfsx.c lapacke_zgbrfsx.c lapacke_zporfsx.c @@ -2128,8 +2298,8 @@ lapacke_chesvxx.c lapacke_dgbsvxx.c lapacke_dsysvxx.c lapacke_ lapacke_chesvxx_work.c lapacke_dgbsvxx_work.c lapacke_dsysvxx_work.c lapacke_sposvxx_work.c lapacke_zgesvxx_work.c lapacke_zsysvxx_work.c ) -# FILE PARTS OF TMGLIB -SET (MATGEN_OBJ +# FILE PARTS OF TMGLIB +set(MATGEN_OBJ lapacke_clatms.c lapacke_clatms_work.c lapacke_dlatms.c diff --git a/lapack-netlib/LAPACKE/src/Makefile b/lapack-netlib/LAPACKE/src/Makefile index 636ca35b6b..c899c631a2 100644 --- a/lapack-netlib/LAPACKE/src/Makefile +++ b/lapack-netlib/LAPACKE/src/Makefile @@ -93,6 +93,8 @@ lapacke_cgelss.o \ lapacke_cgelss_work.o \ lapacke_cgelsy.o \ lapacke_cgelsy_work.o \ +lapacke_cgemqr.o \ +lapacke_cgemqr_work.o \ lapacke_cgemqrt.o \ lapacke_cgemqrt_work.o \ lapacke_cgeqlf.o \ @@ -137,6 +139,8 @@ lapacke_cgetri.o \ lapacke_cgetri_work.o \ lapacke_cgetrs.o \ lapacke_cgetrs_work.o \ +lapacke_cgetsls.o \ +lapacke_cgetsls_work.o \ lapacke_cggbak.o \ lapacke_cggbak_work.o \ lapacke_cggbal.o \ @@ -187,6 +191,12 @@ lapacke_chbevd.o \ lapacke_chbevd_work.o \ lapacke_chbevx.o \ lapacke_chbevx_work.o \ +lapacke_chbev_2stage.o \ +lapacke_chbev_2stage_work.o \ +lapacke_chbevd_2stage.o \ +lapacke_chbevd_2stage_work.o \ +lapacke_chbevx_2stage.o \ +lapacke_chbevx_2stage_work.o \ lapacke_chbgst.o \ lapacke_chbgst_work.o \ lapacke_chbgv.o \ @@ -199,6 +209,8 @@ lapacke_chbtrd.o \ lapacke_chbtrd_work.o \ lapacke_checon.o \ lapacke_checon_work.o \ +lapacke_checon_3.o \ +lapacke_checon_3_work.o \ lapacke_cheequb.o \ lapacke_cheequb_work.o \ lapacke_cheev.o \ @@ -209,10 +221,20 @@ lapacke_cheevr.o \ lapacke_cheevr_work.o \ lapacke_cheevx.o \ lapacke_cheevx_work.o \ +lapacke_cheev_2stage.o \ +lapacke_cheev_2stage_work.o \ +lapacke_cheevd_2stage.o \ +lapacke_cheevd_2stage_work.o \ +lapacke_cheevr_2stage.o \ +lapacke_cheevr_2stage_work.o \ +lapacke_cheevx_2stage.o \ +lapacke_cheevx_2stage_work.o \ lapacke_chegst.o \ lapacke_chegst_work.o \ lapacke_chegv.o \ lapacke_chegv_work.o \ +lapacke_chegv_2stage.o \ +lapacke_chegv_2stage_work.o \ lapacke_chegvd.o \ lapacke_chegvd_work.o \ lapacke_chegvx.o \ @@ -221,6 +243,10 @@ lapacke_cherfs.o \ lapacke_cherfs_work.o \ lapacke_chesv.o \ lapacke_chesv_work.o \ +lapacke_chesv_aa.o \ +lapacke_chesv_aa_work.o \ +lapacke_chesv_rk.o \ +lapacke_chesv_rk_work.o \ lapacke_chesvx.o \ lapacke_chesvx_work.o \ lapacke_cheswapr.o \ @@ -231,9 +257,15 @@ lapacke_chetrf.o \ lapacke_chetrf_rook.o \ lapacke_chetrf_work.o \ lapacke_chetrf_rook_work.o \ +lapacke_chetrf_aa.o \ +lapacke_chetrf_aa_work.o \ +lapacke_chetrf_rk.o \ +lapacke_chetrf_rk_work.o \ lapacke_chetri.o \ lapacke_chetri2.o \ lapacke_chetri2_work.o \ +lapacke_chetri_3.o \ +lapacke_chetri_3_work.o \ lapacke_chetri2x.o \ lapacke_chetri2x_work.o \ lapacke_chetri_work.o \ @@ -243,6 +275,10 @@ lapacke_chetrs2.o \ lapacke_chetrs2_work.o \ lapacke_chetrs_work.o \ lapacke_chetrs_rook_work.o \ +lapacke_chetrs_aa.o \ +lapacke_chetrs_aa_work.o \ +lapacke_chetrs_3.o \ +lapacke_chetrs_3_work.o \ lapacke_chfrk.o \ lapacke_chfrk_work.o \ lapacke_chgeqz.o \ @@ -421,6 +457,8 @@ lapacke_csteqr.o \ lapacke_csteqr_work.o \ lapacke_csycon.o \ lapacke_csycon_work.o \ +lapacke_csycon_3.o \ +lapacke_csycon_3_work.o \ lapacke_csyconv.o \ lapacke_csyconv_work.o \ lapacke_csyequb.o \ @@ -431,6 +469,10 @@ lapacke_csysv.o \ lapacke_csysv_rook.o \ lapacke_csysv_rook_work.o \ lapacke_csysv_work.o \ +lapacke_csysv_aa.o \ +lapacke_csysv_aa_work.o \ +lapacke_csysv_rk.o \ +lapacke_csysv_rk_work.o \ lapacke_csysvx.o \ lapacke_csysvx_work.o \ lapacke_csyswapr.o \ @@ -439,9 +481,15 @@ lapacke_csytrf.o \ lapacke_csytrf_work.o \ lapacke_csytrf_rook.o \ lapacke_csytrf_rook_work.o \ +lapacke_csytrf_aa.o \ +lapacke_csytrf_aa_work.o \ +lapacke_csytrf_rk.o \ +lapacke_csytrf_rk_work.o \ lapacke_csytri.o \ lapacke_csytri2.o \ lapacke_csytri2_work.o \ +lapacke_csytri_3.o \ +lapacke_csytri_3_work.o \ lapacke_csytri2x.o \ lapacke_csytri2x_work.o \ lapacke_csytri_work.o \ @@ -451,6 +499,10 @@ lapacke_csytrs2.o \ lapacke_csytrs2_work.o \ lapacke_csytrs_work.o \ lapacke_csytrs_rook_work.o \ +lapacke_csytrs_aa.o \ +lapacke_csytrs_aa_work.o \ +lapacke_csytrs_3.o \ +lapacke_csytrs_3_work.o \ lapacke_ctbcon.o \ lapacke_ctbcon_work.o \ lapacke_ctbrfs.o \ @@ -625,6 +677,8 @@ lapacke_dgelss.o \ lapacke_dgelss_work.o \ lapacke_dgelsy.o \ lapacke_dgelsy_work.o \ +lapacke_dgemqr.o \ +lapacke_dgemqr_work.o \ lapacke_dgemqrt.o \ lapacke_dgemqrt_work.o \ lapacke_dgeqlf.o \ @@ -669,6 +723,8 @@ lapacke_dgetri.o \ lapacke_dgetri_work.o \ lapacke_dgetrs.o \ lapacke_dgetrs_work.o \ +lapacke_dgetsls.o \ +lapacke_dgetsls_work.o \ lapacke_dggbak.o \ lapacke_dggbak_work.o \ lapacke_dggbal.o \ @@ -885,6 +941,12 @@ lapacke_dsbevd.o \ lapacke_dsbevd_work.o \ lapacke_dsbevx.o \ lapacke_dsbevx_work.o \ +lapacke_dsbev_2stage.o \ +lapacke_dsbev_2stage_work.o \ +lapacke_dsbevd_2stage.o \ +lapacke_dsbevd_2stage_work.o \ +lapacke_dsbevx_2stage.o \ +lapacke_dsbevx_2stage_work.o \ lapacke_dsbgst.o \ lapacke_dsbgst_work.o \ lapacke_dsbgv.o \ @@ -955,6 +1017,8 @@ lapacke_dstevx.o \ lapacke_dstevx_work.o \ lapacke_dsycon.o \ lapacke_dsycon_work.o \ +lapacke_dsycon_3.o \ +lapacke_dsycon_3_work.o \ lapacke_dsyconv.o \ lapacke_dsyconv_work.o \ lapacke_dsyequb.o \ @@ -967,10 +1031,20 @@ lapacke_dsyevr.o \ lapacke_dsyevr_work.o \ lapacke_dsyevx.o \ lapacke_dsyevx_work.o \ +lapacke_dsyev_2stage.o \ +lapacke_dsyev_2stage_work.o \ +lapacke_dsyevd_2stage.o \ +lapacke_dsyevd_2stage_work.o \ +lapacke_dsyevr_2stage.o \ +lapacke_dsyevr_2stage_work.o \ +lapacke_dsyevx_2stage.o \ +lapacke_dsyevx_2stage_work.o \ lapacke_dsygst.o \ lapacke_dsygst_work.o \ lapacke_dsygv.o \ lapacke_dsygv_work.o \ +lapacke_dsygv_2stage.o \ +lapacke_dsygv_2stage_work.o \ lapacke_dsygvd.o \ lapacke_dsygvd_work.o \ lapacke_dsygvx.o \ @@ -981,6 +1055,10 @@ lapacke_dsysv.o \ lapacke_dsysv_rook.o \ lapacke_dsysv_rook_work.o \ lapacke_dsysv_work.o \ +lapacke_dsysv_aa.o \ +lapacke_dsysv_aa_work.o \ +lapacke_dsysv_rk.o \ +lapacke_dsysv_rk_work.o \ lapacke_dsysvx.o \ lapacke_dsysvx_work.o \ lapacke_dsyswapr.o \ @@ -991,12 +1069,18 @@ lapacke_dsytrf.o \ lapacke_dsytrf_work.o \ lapacke_dsytrf_rook.o \ lapacke_dsytrf_rook_work.o \ +lapacke_dsytrf_aa.o \ +lapacke_dsytrf_aa_work.o \ +lapacke_dsytrf_rk.o \ +lapacke_dsytrf_rk_work.o \ lapacke_dsytri.o \ lapacke_dsytri2.o \ lapacke_dsytri2_work.o \ +lapacke_dsytri_3.o \ +lapacke_dsytri_3_work.o \ lapacke_dsytri2x.o \ lapacke_dsytri2x_work.o \ -lapacke_dsytri_work.o +lapacke_dsytri_work.o SRC_OBJB = \ lapacke_dsytrs.o \ @@ -1005,6 +1089,10 @@ lapacke_dsytrs2.o \ lapacke_dsytrs2_work.o \ lapacke_dsytrs_work.o \ lapacke_dsytrs_rook_work.o \ +lapacke_dsytrs_aa.o \ +lapacke_dsytrs_aa_work.o \ +lapacke_dsytrs_3.o \ +lapacke_dsytrs_3_work.o \ lapacke_dtbcon.o \ lapacke_dtbcon_work.o \ lapacke_dtbrfs.o \ @@ -1139,6 +1227,8 @@ lapacke_sgelss.o \ lapacke_sgelss_work.o \ lapacke_sgelsy.o \ lapacke_sgelsy_work.o \ +lapacke_sgemqr.o \ +lapacke_sgemqr_work.o \ lapacke_sgemqrt.o \ lapacke_sgemqrt_work.o \ lapacke_sgeqlf.o \ @@ -1183,6 +1273,8 @@ lapacke_sgetri.o \ lapacke_sgetri_work.o \ lapacke_sgetrs.o \ lapacke_sgetrs_work.o \ +lapacke_sgetsls.o \ +lapacke_sgetsls_work.o \ lapacke_sggbak.o \ lapacke_sggbak_work.o \ lapacke_sggbal.o \ @@ -1399,6 +1491,12 @@ lapacke_ssbevd.o \ lapacke_ssbevd_work.o \ lapacke_ssbevx.o \ lapacke_ssbevx_work.o \ +lapacke_ssbev_2stage.o \ +lapacke_ssbev_2stage_work.o \ +lapacke_ssbevd_2stage.o \ +lapacke_ssbevd_2stage_work.o \ +lapacke_ssbevx_2stage.o \ +lapacke_ssbevx_2stage_work.o \ lapacke_ssbgst.o \ lapacke_ssbgst_work.o \ lapacke_ssbgv.o \ @@ -1465,6 +1563,8 @@ lapacke_sstevx.o \ lapacke_sstevx_work.o \ lapacke_ssycon.o \ lapacke_ssycon_work.o \ +lapacke_ssycon_3.o \ +lapacke_ssycon_3_work.o \ lapacke_ssyconv.o \ lapacke_ssyconv_work.o \ lapacke_ssyequb.o \ @@ -1477,10 +1577,20 @@ lapacke_ssyevr.o \ lapacke_ssyevr_work.o \ lapacke_ssyevx.o \ lapacke_ssyevx_work.o \ +lapacke_ssyev_2stage.o \ +lapacke_ssyev_2stage_work.o \ +lapacke_ssyevd_2stage.o \ +lapacke_ssyevd_2stage_work.o \ +lapacke_ssyevr_2stage.o \ +lapacke_ssyevr_2stage_work.o \ +lapacke_ssyevx_2stage.o \ +lapacke_ssyevx_2stage_work.o \ lapacke_ssygst.o \ lapacke_ssygst_work.o \ lapacke_ssygv.o \ lapacke_ssygv_work.o \ +lapacke_ssygv_2stage.o \ +lapacke_ssygv_2stage_work.o \ lapacke_ssygvd.o \ lapacke_ssygvd_work.o \ lapacke_ssygvx.o \ @@ -1491,6 +1601,10 @@ lapacke_ssysv.o \ lapacke_ssysv_rook.o \ lapacke_ssysv_rook_work.o \ lapacke_ssysv_work.o \ +lapacke_ssysv_aa.o \ +lapacke_ssysv_aa_work.o \ +lapacke_ssysv_rk.o \ +lapacke_ssysv_rk_work.o \ lapacke_ssysvx.o \ lapacke_ssysvx_work.o \ lapacke_ssyswapr.o \ @@ -1501,9 +1615,15 @@ lapacke_ssytrf.o \ lapacke_ssytrf_work.o \ lapacke_ssytrf_rook.o \ lapacke_ssytrf_rook_work.o \ +lapacke_ssytrf_aa.o \ +lapacke_ssytrf_aa_work.o \ +lapacke_ssytrf_rk.o \ +lapacke_ssytrf_rk_work.o \ lapacke_ssytri.o \ lapacke_ssytri2.o \ lapacke_ssytri2_work.o \ +lapacke_ssytri_3.o \ +lapacke_ssytri_3_work.o \ lapacke_ssytri2x.o \ lapacke_ssytri2x_work.o \ lapacke_ssytri_work.o \ @@ -1513,6 +1633,10 @@ lapacke_ssytrs2.o \ lapacke_ssytrs2_work.o \ lapacke_ssytrs_work.o \ lapacke_ssytrs_rook_work.o \ +lapacke_ssytrs_aa.o \ +lapacke_ssytrs_aa_work.o \ +lapacke_ssytrs_3.o \ +lapacke_ssytrs_3_work.o \ lapacke_stbcon.o \ lapacke_stbcon_work.o \ lapacke_stbrfs.o \ @@ -1645,6 +1769,8 @@ lapacke_zgelss.o \ lapacke_zgelss_work.o \ lapacke_zgelsy.o \ lapacke_zgelsy_work.o \ +lapacke_zgemqr.o \ +lapacke_zgemqr_work.o \ lapacke_zgemqrt.o \ lapacke_zgemqrt_work.o \ lapacke_zgeqlf.o \ @@ -1689,6 +1815,8 @@ lapacke_zgetri.o \ lapacke_zgetri_work.o \ lapacke_zgetrs.o \ lapacke_zgetrs_work.o \ +lapacke_zgetsls.o \ +lapacke_zgetsls_work.o \ lapacke_zggbak.o \ lapacke_zggbak_work.o \ lapacke_zggbal.o \ @@ -1739,6 +1867,12 @@ lapacke_zhbevd.o \ lapacke_zhbevd_work.o \ lapacke_zhbevx.o \ lapacke_zhbevx_work.o \ +lapacke_zhbev_2stage.o \ +lapacke_zhbev_2stage_work.o \ +lapacke_zhbevd_2stage.o \ +lapacke_zhbevd_2stage_work.o \ +lapacke_zhbevx_2stage.o \ +lapacke_zhbevx_2stage_work.o \ lapacke_zhbgst.o \ lapacke_zhbgst_work.o \ lapacke_zhbgv.o \ @@ -1751,6 +1885,8 @@ lapacke_zhbtrd.o \ lapacke_zhbtrd_work.o \ lapacke_zhecon.o \ lapacke_zhecon_work.o \ +lapacke_zhecon_3.o \ +lapacke_zhecon_3_work.o \ lapacke_zheequb.o \ lapacke_zheequb_work.o \ lapacke_zheev.o \ @@ -1761,10 +1897,20 @@ lapacke_zheevr.o \ lapacke_zheevr_work.o \ lapacke_zheevx.o \ lapacke_zheevx_work.o \ +lapacke_zheev_2stage.o \ +lapacke_zheev_2stage_work.o \ +lapacke_zheevd_2stage.o \ +lapacke_zheevd_2stage_work.o \ +lapacke_zheevr_2stage.o \ +lapacke_zheevr_2stage_work.o \ +lapacke_zheevx_2stage.o \ +lapacke_zheevx_2stage_work.o \ lapacke_zhegst.o \ lapacke_zhegst_work.o \ lapacke_zhegv.o \ lapacke_zhegv_work.o \ +lapacke_zhegv_2stage.o \ +lapacke_zhegv_2stage_work.o \ lapacke_zhegvd.o \ lapacke_zhegvd_work.o \ lapacke_zhegvx.o \ @@ -1773,6 +1919,10 @@ lapacke_zherfs.o \ lapacke_zherfs_work.o \ lapacke_zhesv.o \ lapacke_zhesv_work.o \ +lapacke_zhesv_aa.o \ +lapacke_zhesv_aa_work.o \ +lapacke_zhesv_rk.o \ +lapacke_zhesv_rk_work.o \ lapacke_zhesvx.o \ lapacke_zhesvx_work.o \ lapacke_zheswapr.o \ @@ -1783,9 +1933,15 @@ lapacke_zhetrf.o \ lapacke_zhetrf_rook.o \ lapacke_zhetrf_work.o \ lapacke_zhetrf_rook_work.o \ +lapacke_zhetrf_aa.o \ +lapacke_zhetrf_aa_work.o \ +lapacke_zhetrf_rk.o \ +lapacke_zhetrf_rk_work.o \ lapacke_zhetri.o \ lapacke_zhetri2.o \ lapacke_zhetri2_work.o \ +lapacke_zhetri_3.o \ +lapacke_zhetri_3_work.o \ lapacke_zhetri2x.o \ lapacke_zhetri2x_work.o \ lapacke_zhetri_work.o \ @@ -1795,6 +1951,10 @@ lapacke_zhetrs2.o \ lapacke_zhetrs2_work.o \ lapacke_zhetrs_work.o \ lapacke_zhetrs_rook_work.o \ +lapacke_zhetrs_aa.o \ +lapacke_zhetrs_aa_work.o \ +lapacke_zhetrs_3.o \ +lapacke_zhetrs_3_work.o \ lapacke_zhfrk.o \ lapacke_zhfrk_work.o \ lapacke_zhgeqz.o \ @@ -1973,6 +2133,8 @@ lapacke_zsteqr.o \ lapacke_zsteqr_work.o \ lapacke_zsycon.o \ lapacke_zsycon_work.o \ +lapacke_zsycon_3.o \ +lapacke_zsycon_3_work.o \ lapacke_zsyconv.o \ lapacke_zsyconv_work.o \ lapacke_zsyequb.o \ @@ -1983,6 +2145,10 @@ lapacke_zsysv.o \ lapacke_zsysv_rook.o \ lapacke_zsysv_rook_work.o \ lapacke_zsysv_work.o \ +lapacke_zsysv_aa.o \ +lapacke_zsysv_aa_work.o \ +lapacke_zsysv_rk.o \ +lapacke_zsysv_rk_work.o \ lapacke_zsysvx.o \ lapacke_zsysvx_work.o \ lapacke_zsyswapr.o \ @@ -1991,9 +2157,15 @@ lapacke_zsytrf.o \ lapacke_zsytrf_work.o \ lapacke_zsytrf_rook.o \ lapacke_zsytrf_rook_work.o \ +lapacke_zsytrf_aa.o \ +lapacke_zsytrf_aa_work.o \ +lapacke_zsytrf_rk.o \ +lapacke_zsytrf_rk_work.o \ lapacke_zsytri.o \ lapacke_zsytri2.o \ lapacke_zsytri2_work.o \ +lapacke_zsytri_3.o \ +lapacke_zsytri_3_work.o \ lapacke_zsytri2x.o \ lapacke_zsytri2x_work.o \ lapacke_zsytri_work.o \ @@ -2003,6 +2175,10 @@ lapacke_zsytrs2.o \ lapacke_zsytrs2_work.o \ lapacke_zsytrs_work.o \ lapacke_zsytrs_rook_work.o \ +lapacke_zsytrs_aa.o \ +lapacke_zsytrs_aa_work.o \ +lapacke_zsytrs_3.o \ +lapacke_zsytrs_3_work.o \ lapacke_ztbcon.o \ lapacke_ztbcon_work.o \ lapacke_ztbrfs.o \ @@ -2160,7 +2336,7 @@ lapacke_chesvxx.o lapacke_dgbsvxx.o lapacke_dsysvxx.o lapacke_ lapacke_chesvxx_work.o lapacke_dgbsvxx_work.o lapacke_dsysvxx_work.o lapacke_sposvxx_work.o lapacke_zgesvxx_work.o lapacke_zsysvxx_work.o -# FILE PARTS OF TMGLIB +# FILE PARTS OF TMGLIB MATGEN_OBJ = \ lapacke_clatms.o \ lapacke_clatms_work.o \ @@ -2202,17 +2378,15 @@ ifdef BUILD_DEPRECATED DEPRECATED = $(DEPRECSRC) endif -OBJ_FILES := $(C_FILES:.o=.o) - all: ../../$(LAPACKELIB) ../../$(LAPACKELIB): $(ALLOBJA) $(ALLOBJB) $(ALLXOBJ) $(DEPRECATED) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ALLOBJA) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ALLOBJB) $(ALLXOBJ) $(DEPRECATED) - $(RANLIB) ../../$(LAPACKELIB) + $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJA) + $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJB) $(ALLXOBJ) $(DEPRECATED) + $(RANLIB) $@ .c.o: - $(CC) -c $(CFLAGS) -I ../include -o $@ $< + $(CC) $(CFLAGS) -I../include -c -o $@ $< clean: rm -f *.o diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgejsv.c b/lapack-netlib/LAPACKE/src/lapacke_cgejsv.c index 32143ae6e8..fbf8d11c37 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgejsv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgejsv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,10 +41,10 @@ lapack_int LAPACKE_cgejsv( int matrix_layout, char joba, char jobu, char jobv, { lapack_int info = 0; lapack_int lwork = ( - // 1.1 + // 1.1 ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? 2*n+1 : - + //1.2 ( ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? n*n+3*n : @@ -53,38 +53,38 @@ lapack_int LAPACKE_cgejsv( int matrix_layout, char joba, char jobu, char jobv, ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - + + //2.2 ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - //3.1 + + //3.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - //3.2 + + //3.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !(LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && !(LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - + //4.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 5*n+2*n*n : - + //4.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && - ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 4*n*n: - 1) ) ) ) ) ) ) ); + ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 4*n*n: + 1) ) ) ) ) ) ) ); lapack_int lrwork = ( - // 1.1 + // 1.1 ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? MAX(7,n+2*m) : - + //1.2 ( ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? MAX(7,2*n) : @@ -93,33 +93,33 @@ lapack_int LAPACKE_cgejsv( int matrix_layout, char joba, char jobu, char jobv, ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - - + + //2.2 ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - - //3.1 + + //3.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - - //3.2 + + //3.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !(LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && !(LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - + //4.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - + //4.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - 1 )))))))); + 7 )))))))); lapack_int* iwork = NULL; float* rwork = NULL; lapack_complex_float* cwork = NULL; @@ -136,30 +136,29 @@ lapack_int LAPACKE_cgejsv( int matrix_layout, char joba, char jobu, char jobv, if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { return -10; } - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - if( LAPACKE_cge_nancheck( matrix_layout, nu, n, u, ldu ) ) { - return -13; - } - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - if( LAPACKE_cge_nancheck( matrix_layout, nv, n, v, ldv ) ) { - return -15; - } - } #endif /* Allocate memory for working array(s) */ - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,m+3*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(3,m+2*n) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } + lwork = MAX( lwork, 1 ); + { /* FIXUP LWORK */ + int want_u = LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ); + int want_v = LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ); + int want_sce = LAPACKE_lsame( joba, 'e' ) || LAPACKE_lsame( joba, 'g' ); + if( !want_u && !want_v && !want_sce ) lwork = MAX( lwork, 2*n+1 ); // 1.1 + if( !want_u && !want_v && want_sce ) lwork = MAX( lwork, n*n+3*n ); // 1.2 + if( want_u && LAPACKE_lsame( jobv, 'v' ) ) lwork = MAX( lwork, 5*n+2*n*n ); // 4.1 + if( want_u && LAPACKE_lsame( jobv, 'j' ) ) lwork = MAX( lwork, 4*n+n*n ); // 4.2 + } cwork = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); if( cwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } + lrwork = MAX3( lrwork, 7, n+2*m ); rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); if( rwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgejsv_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgejsv_work.c index 72c3ddce72..1311ab93e1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgejsv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgejsv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cgejsv * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -46,7 +46,7 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_cgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, - &lda, sva, u, &ldu, v, &ldv, cwork, &lwork, rwork, &lwork, + &lda, sva, u, &ldu, v, &ldv, cwork, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -54,6 +54,8 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, } else if( matrix_layout == LAPACK_ROW_MAJOR ) { lapack_int nu = LAPACKE_lsame( jobu, 'n' ) ? 1 : m; lapack_int nv = LAPACKE_lsame( jobv, 'n' ) ? 1 : n; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'n' ) ? 1 : + LAPACKE_lsame( jobu, 'f' ) ? m : n; lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nu); lapack_int ldv_t = MAX(1,nv); @@ -66,7 +68,7 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, LAPACKE_xerbla( "LAPACKE_cgejsv_work", info ); return info; } - if( ldu < n ) { + if( ldu < ncols_u ) { info = -14; LAPACKE_xerbla( "LAPACKE_cgejsv_work", info ); return info; @@ -86,7 +88,7 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { u_t = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * ldu_t * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_float) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_1; @@ -103,14 +105,6 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, } /* Transpose input matrices */ LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_cge_trans( matrix_layout, nu, n, u, ldu, u_t, ldu_t ); - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - LAPACKE_cge_trans( matrix_layout, nv, n, v, ldv, v_t, ldv_t ); - } /* Call LAPACK function and adjust info */ LAPACK_cgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a_t, &lda_t, sva, u_t, &ldu_t, v_t, &ldv_t, cwork, &lwork, @@ -121,7 +115,7 @@ lapack_int LAPACKE_cgejsv_work( int matrix_layout, char joba, char jobu, /* Transpose output matrices */ if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_cge_trans( LAPACK_COL_MAJOR, nu, n, u_t, ldu_t, u, ldu ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, nu, ncols_u, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'w' ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgelq.c b/lapack-netlib/LAPACKE/src/lapacke_cgelq.c new file mode 100644 index 0000000000..df1d4882ce --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgelq.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgelq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgelq_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_cgelq_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgelq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgelq_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgelq_work.c new file mode 100644 index 0000000000..6f6e425b60 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgelq_work.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgelq( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_cgelq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_cgelq( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgelq( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgelq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgelq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgemlq.c b/lapack-netlib/LAPACKE/src/lapacke_cgemlq.c new file mode 100644 index 0000000000..ae39111083 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgemlq.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgemlq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgemlq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, k, m, a, lda ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_d_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_cgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgemlq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgemlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgemlq_work.c new file mode 100644 index 0000000000..e2f7fc9181 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgemlq_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgemlq +* Author: Intel Corporation +* Generated June 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + lapack_complex_float *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgemlq( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, + c, &ldc, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,k); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < r ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_cgemlq_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_cgemlq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cgemlq( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,m) ); + } else { + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + } + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgemlq( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgemlq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgemlq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgemqr.c b/lapack-netlib/LAPACKE/src/lapacke_cgemqr.c new file mode 100644 index 0000000000..229a413271 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgemqr.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + lapack_int r; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgemqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_cge_nancheck( matrix_layout, r, k, a, lda ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_c_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_cgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgemqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgemqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgemqr_work.c new file mode 100644 index 0000000000..9b9e5a442e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgemqr_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + lapack_complex_float *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgemqr( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, c, &ldc, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,r); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < k ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_cgemqr_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_cgemqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cgemqr( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,k) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, r, k, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgemqr( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgemqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgemqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgemqrt.c b/lapack-netlib/LAPACKE/src/lapacke_cgemqrt.c index 5f539f3077..c0631af44b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgemqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgemqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function cgemqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,6 +40,7 @@ lapack_int LAPACKE_cgemqrt( int matrix_layout, char side, char trans, lapack_int ldt, lapack_complex_float* c, lapack_int ldc ) { + lapack_int nrows_v; lapack_int info = 0; lapack_complex_float* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -48,13 +49,15 @@ lapack_int LAPACKE_cgemqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) { return -12; } - if( LAPACKE_cge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -10; } - if( LAPACKE_cge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -8; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgeqr.c b/lapack-netlib/LAPACKE/src/lapacke_cgeqr.c new file mode 100644 index 0000000000..264b135684 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgeqr.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgeqr( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgeqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgeqr_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_cgeqr_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgeqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgeqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgeqr_work.c new file mode 100644 index 0000000000..ff5cc9bcbf --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgeqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* t, lapack_int tsize, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgeqr( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_cgeqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_cgeqr( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgeqr( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgeqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgeqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgesvdx.c b/lapack-netlib/LAPACKE/src/lapacke_cgesvdx.c index 56ee57f5bf..6882a8b8f6 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgesvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgesvdx.c @@ -28,15 +28,15 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cgesvdx * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_cgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, lapack_complex_float* u, lapack_int ldu, lapack_complex_float* vt, lapack_int ldvt, lapack_int* superb ) @@ -44,9 +44,9 @@ lapack_int LAPACKE_cgesvdx( int matrix_layout, char jobu, char jobvt, char range lapack_int info = 0; lapack_int lwork = -1; lapack_complex_float* work = NULL; - lapack_complex_float work_query; + lapack_complex_float work_query; float* rwork = NULL; - lapack_int lrwork = MIN(m,n)*(MIN(m,n)*2+15*MIN(m,n)); + lapack_int lrwork = MAX(1, MIN(m,n)*(MIN(m,n)*2+15*MIN(m,n))); lapack_int* iwork = NULL; lapack_int i; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -68,18 +68,18 @@ lapack_int LAPACKE_cgesvdx( int matrix_layout, char jobu, char jobvt, char range } lwork = LAPACK_C2INT (work_query); /* Allocate memory for work arrays */ - rwork = (float*)LAPACKE_malloc( sizeof(float) * lwork ); - if( work == NULL ) { - info = LAPACK_WORK_MEMORY_ERROR; - goto exit_level_0; - } work = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * lrwork ); + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*MIN(m,n)) ); + rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,(12*MIN(m,n))) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_2; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgesvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgesvdx_work.c index 614cdaef04..a5955ef465 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgesvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgesvdx_work.c @@ -28,17 +28,17 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, lapack_complex_float* u, lapack_int ldu, - lapack_complex_float* vt, lapack_int ldvt, + lapack_complex_float* vt, lapack_int ldvt, lapack_complex_float* work, lapack_int lwork, float* rwork, lapack_int* iwork ) { @@ -46,21 +46,23 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_cgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda, &vl, &vu, - &il, &iu, &ns, s, u, &ldu, vt, &ldvt, + &il, &iu, ns, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_u = ( LAPACKE_lsame( jobu, 'a' ) || - LAPACKE_lsame( jobu, 's' ) ) ? m : 1; - lapack_int ncols_u = LAPACKE_lsame( jobu, 'a' ) ? m : - ( LAPACKE_lsame( jobu, 's' ) ? MIN(m,n) : 1); - lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'a' ) ? n : - ( LAPACKE_lsame( jobvt, 's' ) ? MIN(m,n) : 1); + lapack_int nrows_u = LAPACKE_lsame( jobu, 'v' ) ? m : 0; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int ncols_vt = LAPACKE_lsame( jobvt, 'v' ) ? n : 0; + lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nrows_u); lapack_int ldvt_t = MAX(1,nrows_vt); + lapack_complex_float* a_t = NULL; lapack_complex_float* u_t = NULL; lapack_complex_float* vt_t = NULL; @@ -75,7 +77,7 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char LAPACKE_xerbla( "LAPACKE_cgesvdx_work", info ); return info; } - if( ldvt < n ) { + if( ldvt < ncols_vt ) { info = -18; LAPACKE_xerbla( "LAPACKE_cgesvdx_work", info ); return info; @@ -83,7 +85,7 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_cgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + &il, &iu, ns, s, u, &ldu_t, vt, &ldvt_t, work, &lwork, rwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -94,7 +96,7 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { u_t = (lapack_complex_float*) LAPACKE_malloc( sizeof(lapack_complex_float) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { @@ -102,7 +104,7 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char goto exit_level_1; } } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { vt_t = (lapack_complex_float*) LAPACKE_malloc( sizeof(lapack_complex_float) * ldvt_t * MAX(1,n) ); if( vt_t == NULL ) { @@ -113,28 +115,28 @@ lapack_int LAPACKE_cgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Transpose input matrices */ LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_cgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + LAPACK_cgesvdx( &jobu, &jobvt, &range, &m, &n, a_t, &lda_t, &vl, &vu, + &il, &iu, ns, s, u_t, &ldu_t, vt_t, &ldvt_t, work, &lwork, rwork, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_cge_trans( LAPACK_COL_MAJOR, nrows_u, ncols_u, u_t, ldu_t, u, ldu ); } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_cge_trans( LAPACK_COL_MAJOR, nrows_vt, n, vt_t, ldvt_t, vt, ldvt ); } /* Release memory and exit */ - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_free( vt_t ); } exit_level_2: - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_free( u_t ); } exit_level_1: diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgesvj.c b/lapack-netlib/LAPACKE/src/lapacke_cgesvj.c index 2f968af8b7..9d3b81e45b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgesvj.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgesvj.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cgesvj * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -52,8 +52,8 @@ lapack_int LAPACKE_cgesvj( int matrix_layout, char joba, char jobu, char jobv, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { return -7; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgesvj_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgesvj_work.c index d2f24d0c04..e2bbbfec78 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cgesvj_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cgesvj_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cgesvj * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_cgesvj_work( int matrix_layout, char joba, char jobu, - char jobv, lapack_int m, lapack_int n, - lapack_complex_float* a, lapack_int lda, + char jobv, lapack_int m, lapack_int n, + lapack_complex_float* a, lapack_int lda, float* sva, lapack_int mv, lapack_complex_float* v, lapack_int ldv, lapack_complex_float* cwork, lapack_int lwork, @@ -50,8 +50,8 @@ lapack_int LAPACKE_cgesvj_work( int matrix_layout, char joba, char jobu, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); lapack_int lda_t = MAX(1,m); lapack_int ldv_t = MAX(1,nrows_v); lapack_complex_float* a_t = NULL; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgetsls.c b/lapack-netlib/LAPACKE/src/lapacke_cgetsls.c new file mode 100644 index 0000000000..8b35c105f8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgetsls.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgetsls", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -6; + } + if( LAPACKE_cge_nancheck( matrix_layout, MAX(m,n), nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_cgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgetsls", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgetsls_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgetsls_work.c new file mode 100644 index 0000000000..8f2ed4d0e7 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgetsls_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgetsls( &trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,MAX(m,n)); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_cgetsls_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_cgetsls_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cgetsls( &trans, &m, &n, &nrhs, a, &lda_t, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, MAX(m,n), nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgetsls( &trans, &m, &n, &nrhs, a_t, &lda_t, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, MAX(m,n), nrhs, b_t, ldb_t, b, + ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgetsls_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgetsls_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cggsvd3_work.c b/lapack-netlib/LAPACKE/src/lapacke_cggsvd3_work.c index 652e8b72ca..8144b87125 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cggsvd3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cggsvd3_work.c @@ -93,9 +93,9 @@ lapack_int LAPACKE_cggsvd3_work( int matrix_layout, char jobu, char jobv, } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_cggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a_t, - &lda_t, b_t, &ldb_t, alpha, beta, u_t, &ldu_t, - v_t, &ldv_t, q_t, &ldq_t, work, &lwork, rwork, + LAPACK_cggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a, + &lda_t, b, &ldb_t, alpha, beta, u, &ldu_t, + v, &ldv_t, q, &ldq_t, work, &lwork, rwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_cggsvp3_work.c b/lapack-netlib/LAPACKE/src/lapacke_cggsvp3_work.c index d532391ccd..23fb4b3cf6 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cggsvp3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cggsvp3_work.c @@ -87,16 +87,16 @@ lapack_int LAPACKE_cggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_xerbla( "LAPACKE_cggsvp3_work", info ); return info; } - if( ldv < m ) { + if( ldv < p ) { info = -19; LAPACKE_xerbla( "LAPACKE_cggsvp3_work", info ); return info; } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_cggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a_t, &lda_t, b_t, - &ldb_t, &tola, &tolb, k, l, u_t, &ldu_t, v_t, &ldv_t, - q_t, &ldq_t, iwork, rwork, tau, work, &lwork, &info ); + LAPACK_cggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a, &lda_t, b, + &ldb_t, &tola, &tolb, k, l, u, &ldu_t, v, &ldv_t, + q, &ldq_t, iwork, rwork, tau, work, &lwork, &info ); return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ @@ -124,7 +124,7 @@ lapack_int LAPACKE_cggsvp3_work( int matrix_layout, char jobu, char jobv, if( LAPACKE_lsame( jobv, 'v' ) ) { v_t = (lapack_complex_float*) LAPACKE_malloc( sizeof(lapack_complex_float) * - ldv_t * MAX(1,m) ); + ldv_t * MAX(1,p) ); if( v_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_3; @@ -156,7 +156,7 @@ lapack_int LAPACKE_cggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, m, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'v' ) ) { - LAPACKE_cge_trans( LAPACK_COL_MAJOR, p, m, v_t, ldv_t, v, ldv ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, p, p, v_t, ldv_t, v, ldv ); } if( LAPACKE_lsame( jobq, 'q' ) ) { LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage.c new file mode 100644 index 0000000000..5be09b6e30 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_float* ab, + lapack_int ldab, float* w, lapack_complex_float* z, + lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chbev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_chb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for working array(s) */ + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_chbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage_work.c new file mode 100644 index 0000000000..075b853754 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbev_2stage_work.c @@ -0,0 +1,118 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chbev_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, + rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* ab_t = NULL; + lapack_complex_float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_chbev_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_chbev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_chb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_chb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chbev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage.c new file mode 100644 index 0000000000..293701bca2 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_float* ab, + lapack_int ldab, float* w, lapack_complex_float* z, + lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_int iwork_query; + float rwork_query; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chbevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_chb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_chbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, rwork, lrwork, iwork, + liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage_work.c new file mode 100644 index 0000000000..e0f0d92ba2 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbevd_2stage_work.c @@ -0,0 +1,121 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, + lapack_int lrwork, lapack_int* iwork, + lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* ab_t = NULL; + lapack_complex_float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_chbevd_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_chbevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_chbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab_t, w, z, &ldz_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_chb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chbevd_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_chb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chbevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage.c new file mode 100644 index 0000000000..9b64a8a534 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage.c @@ -0,0 +1,113 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + lapack_complex_float* q, lapack_int ldq, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, lapack_complex_float* z, + lapack_int ldz, lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chbevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_chb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -7; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -15; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -11; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -12; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, &work_query, lwork, rwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,7*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_chbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, work, lwork, rwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage_work.c new file mode 100644 index 0000000000..ac962eb130 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chbevx_2stage_work.c @@ -0,0 +1,152 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + lapack_complex_float* ab, lapack_int ldab, + lapack_complex_float* q, lapack_int ldq, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, lapack_int* iwork, + lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, + &vu, &il, &iu, &abstol, m, w, z, &ldz, work, &lwork, rwork, + iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* ab_t = NULL; + lapack_complex_float* q_t = NULL; + lapack_complex_float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_chbevx_2stage_work", info ); + return info; + } + if( ldq < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_chbevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -19; + LAPACKE_xerbla( "LAPACKE_chbevx_2stage_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + q_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, rwork, iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Transpose input matrices */ + LAPACKE_chb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, rwork, iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_chb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_2: + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( q_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chbevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chbevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chbtrd.c b/lapack-netlib/LAPACKE/src/lapacke_chbtrd.c index 83aa5df102..351382edae 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_chbtrd.c +++ b/lapack-netlib/LAPACKE/src/lapacke_chbtrd.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function chbtrd * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -49,7 +49,7 @@ lapack_int LAPACKE_chbtrd( int matrix_layout, char vect, char uplo, lapack_int n if( LAPACKE_chb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { return -6; } - if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) { + if( LAPACKE_lsame( vect, 'u' ) ) { if( LAPACKE_cge_nancheck( matrix_layout, n, n, q, ldq ) ) { return -10; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_checon_3.c b/lapack-netlib/LAPACKE/src/lapacke_checon_3.c new file mode 100644 index 0000000000..d96cb98644 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_checon_3.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function checon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_checon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, float* rcond ) +{ + lapack_int info = 0; + lapack_complex_float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_checon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_checon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_checon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_checon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_checon_3_work.c new file mode 100644 index 0000000000..ac4e8e9593 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_checon_3_work.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function checon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_checon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, + float* rcond, lapack_complex_float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_checon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_checon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_checon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_checon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_checon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage.c new file mode 100644 index 0000000000..52e6a300c4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cheev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cheev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_cheev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_cheev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage_work.c new file mode 100644 index 0000000000..c27f292213 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheev_2stage_work.c @@ -0,0 +1,93 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cheev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cheev_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_cheev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cheev_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, rwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cheev_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, rwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cheev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage.c new file mode 100644 index 0000000000..339d43db60 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage.c @@ -0,0 +1,100 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cheevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, float* w ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_int iwork_query; + float rwork_query; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cheevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cheevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_cheevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage_work.c new file mode 100644 index 0000000000..cb51f9ee48 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevd_2stage_work.c @@ -0,0 +1,94 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cheevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cheevd_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_cheevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_cheevd_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cheevd_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cheevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage.c new file mode 100644 index 0000000000..cb4c0b9a8e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage.c @@ -0,0 +1,119 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cheevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, float* w, + lapack_complex_float* z, lapack_int ldz, + lapack_int* isuppz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_int iwork_query; + float rwork_query; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cheevr_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cheevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, + &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_cheevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, work, + lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevr_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage_work.c new file mode 100644 index 0000000000..44ff104c35 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevr_2stage_work.c @@ -0,0 +1,128 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cheevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_int* isuppz, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cheevr_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, isuppz, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_cheevr_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_cheevr_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_cheevr_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, isuppz, work, &lwork, + rwork, &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cheevr_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, isuppz, work, &lwork, + rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevr_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cheevr_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage.c new file mode 100644 index 0000000000..5f3dafe6b8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage.c @@ -0,0 +1,113 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cheevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_float* a, + lapack_int lda, float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, float* w, + lapack_complex_float* z, lapack_int ldz, + lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cheevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,7*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Query optimal working array(s) size */ + info = LAPACKE_cheevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, &work_query, + lwork, rwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_2; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_cheevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, work, lwork, + rwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage_work.c new file mode 100644 index 0000000000..f9947b307b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cheevx_2stage_work.c @@ -0,0 +1,127 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cheevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cheevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + float vl, float vu, lapack_int il, + lapack_int iu, float abstol, lapack_int* m, + float* w, lapack_complex_float* z, + lapack_int ldz, lapack_complex_float* work, + lapack_int lwork, float* rwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cheevx_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, work, &lwork, rwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_cheevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_cheevx_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cheevx_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, work, &lwork, rwork, + iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cheevx_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, work, &lwork, rwork, + iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cheevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cheevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage.c new file mode 100644 index 0000000000..53a5d42521 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage.c @@ -0,0 +1,91 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chegv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chegv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* b, + lapack_int ldb, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chegv_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -6; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_chegv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_chegv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chegv_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage_work.c new file mode 100644 index 0000000000..910f96b3a5 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chegv_2stage_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chegv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chegv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* b, + lapack_int ldb, float* w, + lapack_complex_float* work, lapack_int lwork, + float* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chegv_2stage( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_chegv_2stage_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_chegv_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chegv_2stage( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, rwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chegv_2stage( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chegv_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chegv_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chegvx_work.c b/lapack-netlib/LAPACKE/src/lapacke_chegvx_work.c index cd8c5702e7..8251662fd8 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_chegvx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_chegvx_work.c @@ -110,7 +110,7 @@ lapack_int LAPACKE_chegvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose input matrices */ LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); - LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + LAPACKE_che_trans( matrix_layout, uplo, n, b, ldb, b_t, ldb_t ); /* Call LAPACK function and adjust info */ LAPACK_chegvx( &itype, &jobz, &range, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, @@ -120,7 +120,7 @@ lapack_int LAPACKE_chegvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose output matrices */ LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); - LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, b_t, ldb_t, b, ldb ); if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, ldz ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_chesv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_chesv_aa.c new file mode 100644 index 0000000000..2323bd2870 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chesv_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chesv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chesv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chesv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chesv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chesv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chesv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chesv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_chesv_aa_work.c new file mode 100644 index 0000000000..88513b1a13 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chesv_aa_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chesv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chesv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chesv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_chesv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_chesv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chesv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chesv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chesv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chesv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chesv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_chesv_rk.c new file mode 100644 index 0000000000..04b5f6a05f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chesv_rk.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chesv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chesv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, + lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chesv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_c_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -10; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chesv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chesv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chesv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chesv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_chesv_rk_work.c new file mode 100644 index 0000000000..10e0d1d515 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chesv_rk_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chesv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chesv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, + lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chesv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_chesv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_chesv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chesv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chesv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chesv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chesv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheswapr.c b/lapack-netlib/LAPACKE/src/lapacke_cheswapr.c index 7963eb3704..de512fda57 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cheswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cheswapr.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cheswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_cheswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_cheswapr", -1 ); @@ -43,9 +43,9 @@ lapack_int LAPACKE_cheswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_cheswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_cheswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_cheswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_cheswapr_work.c index e41b3a2c71..fe14cac5d9 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cheswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cheswapr_work.c @@ -28,38 +28,39 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cheswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_cheswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_cheswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_cheswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); lapack_complex_float* a_t = NULL; /* Allocate memory for temporary array(s) */ a_t = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * n * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_che_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_cheswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_cheswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa.c new file mode 100644 index 0000000000..4987481604 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chetrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chetrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chetrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa_work.c new file mode 100644 index 0000000000..b4a7595d8d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrf_aa_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chetrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chetrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_chetrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chetrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chetrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chetrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk.c new file mode 100644 index 0000000000..b9133e714c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chetrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chetrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chetrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk_work.c new file mode 100644 index 0000000000..1a7df7c22d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrf_rk_work.c @@ -0,0 +1,90 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chetrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chetrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_chetrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chetrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chetrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chetrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetri2x.c b/lapack-netlib/LAPACKE/src/lapacke_chetri2x.c index 1d97571b6c..23957f1fec 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_chetri2x.c +++ b/lapack-netlib/LAPACKE/src/lapacke_chetri2x.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function chetri2x * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -45,7 +45,7 @@ lapack_int LAPACKE_chetri2x( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_cge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { return -4; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetri_3.c b/lapack-netlib/LAPACKE/src/lapacke_chetri_3.c new file mode 100644 index 0000000000..8ce3ad3515 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetri_3.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chetri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chetri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chetri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for working array(s) */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chetri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_chetri_3_work.c new file mode 100644 index 0000000000..59ee0aa1fc --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetri_3_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chetri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chetri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_chetri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_chetri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chetri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_che_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chetri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_chetrs_3.c new file mode 100644 index 0000000000..77a5f24124 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrs_3.c @@ -0,0 +1,60 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chetrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chetrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_c_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_chetrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_chetrs_3_work.c new file mode 100644 index 0000000000..18e855f61f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrs_3_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chetrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chetrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_chetrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_chetrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chetrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chetrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa.c new file mode 100644 index 0000000000..6a635cf740 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function chetrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_chetrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_che_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_chetrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_chetrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa_work.c new file mode 100644 index 0000000000..ffd31ddf8c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_chetrs_aa_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function chetrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_chetrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_chetrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_chetrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_chetrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_che_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_chetrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_chetrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_chetrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_clantr.c b/lapack-netlib/LAPACKE/src/lapacke_clantr.c index 33e6e57ffc..5a38fb0d7c 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_clantr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_clantr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function clantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_clarfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_clarfb_work.c index ad386d0528..b1af49477b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_clarfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_clarfb_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function clarfb * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -44,7 +44,7 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans, lapack_int info = 0; lapack_int nrows_v, ncols_v; lapack_int ldc_t, ldt_t, ldv_t; - lapack_complex_float *v_t = NULL, *t_t = NULL, *c_t = NULL; + lapack_complex_float *v_t = NULL, *t_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_clarfb( &side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, @@ -123,7 +123,7 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans, LAPACKE_cge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv, &v_t[k*ldv_t], ldv_t ); } else if( LAPACKE_lsame( storev, 'r' ) && - LAPACKE_lsame( direct, 'f' ) ) { + LAPACKE_lsame( direct, 'b' ) ) { if( k > ncols_v ) { LAPACKE_xerbla( "LAPACKE_clarfb_work", -8 ); return -8; diff --git a/lapack-netlib/LAPACKE/src/lapacke_clascl.c b/lapack-netlib/LAPACKE/src/lapacke_clascl.c index c21ec3e06d..5e3169551a 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_clascl.c +++ b/lapack-netlib/LAPACKE/src/lapacke_clascl.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function slaswp * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_clascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, lapack_complex_float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, lapack_complex_float* a, lapack_int lda ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -46,50 +46,64 @@ lapack_int LAPACKE_clascl( int matrix_layout, char type, lapack_int kl, /* Optionally check input matrices for NaNs */ switch (type) { case 'G': - if( LAPACKE_cge_nancheck( matrix_layout, lda, n, a, lda ) ) { - return -9; - } + if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -9; + } break; case 'L': - // TYPE = 'L' - lower triangular matrix. - if( LAPACKE_ctr_nancheck( matrix_layout, 'L', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'L' - lower triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_cgb_nancheck( matrix_layout, m, n, m-1, 0, a, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_cgb_nancheck( LAPACK_COL_MAJOR, n, m, 0, m-1, a-m+1, lda+1 ) ) { + return -9; + } break; case 'U': - // TYPE = 'U' - upper triangular matrix - if( LAPACKE_ctr_nancheck( matrix_layout, 'U', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'U' - upper triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_cgb_nancheck( matrix_layout, m, n, 0, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_cgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 0, a, lda+1 ) ) { + return -9; + } break; case 'H': - // TYPE = 'H' - upper Hessenberg matrix - if( LAPACKE_chs_nancheck( matrix_layout, n, a, lda ) ) { - return -9; - } - break; + // TYPE = 'H' - part of upper Hessenberg matrix in general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_cgb_nancheck( matrix_layout, m, n, 1, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_cgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 1, a-1, lda+1 ) ) { + return -9; + } case 'B': - // TYPE = 'B' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the lower - // half stored. - if( LAPACKE_chb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { - return -9; - } - break; - case 'Q': - // TYPE = 'Q' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the upper - // half stored. - if( LAPACKE_chb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { - return -9; - } + // TYPE = 'B' - lower part of symmetric band matrix (assume m==n) + if( LAPACKE_chb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { + return -9; + } + break; + case 'Q': + // TYPE = 'Q' - upper part of symmetric band matrix (assume m==n) + if( LAPACKE_chb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { + return -9; + } break; case 'Z': - // TYPE = 'Z' - A is a band matrix with lower bandwidth KL and upper - // bandwidth KU. See DGBTRF for storage details. - if( LAPACKE_cgb_nancheck( matrix_layout, n, n, kl, kl+ku, a, lda ) ) { - return -6; - } + // TYPE = 'Z' - band matrix laid out for ?GBTRF + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_cgb_nancheck( matrix_layout, m, n, kl, ku, a+kl, lda ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_cgb_nancheck( matrix_layout, m, n, kl, ku, a+lda*kl, lda ) ) { + return -9; + } break; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_clascl_work.c b/lapack-netlib/LAPACKE/src/lapacke_clascl_work.c index 18ac1efafe..70a75f733f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_clascl_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_clascl_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function slaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_clascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, lapack_complex_float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, lapack_complex_float* a, lapack_int lda ) { lapack_int info = 0; @@ -46,7 +46,10 @@ lapack_int LAPACKE_clascl_work( int matrix_layout, char type, lapack_int kl, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int nrows_a = LAPACKE_lsame(type, 'b') ? kl + 1 : + LAPACKE_lsame(type, 'q') ? ku + 1 : + LAPACKE_lsame(type, 'z') ? 2 * kl + ku + 1 : m; + lapack_int lda_t = MAX(1,nrows_a); lapack_complex_float* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -62,12 +65,14 @@ lapack_int LAPACKE_clascl_work( int matrix_layout, char type, lapack_int kl, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_cge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, nrows_a, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_clascl( &type, &kl, &ku, &cfrom, &cto, &m, &n, a_t, &lda_t, &info); - info = 0; /* LAPACK call is ok! */ + if( info < 0 ) { + info = info - 1; + } /* Transpose output matrices */ - LAPACKE_cge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, nrows_a, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_claset.c b/lapack-netlib/LAPACKE/src/lapacke_claset.c index 5cf883928a..fd18fd127c 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_claset.c +++ b/lapack-netlib/LAPACKE/src/lapacke_claset.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function claset * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -45,8 +45,8 @@ lapack_int LAPACKE_claset( int matrix_layout, char uplo, lapack_int m, } /***************************************************************************** -* Note: we do not check NaNs in A since the goal of this subroutine is to -* initialized A. It is OK if A has NaNs in input. +* Note: we do not check NaNs in A since the goal of this subroutine is to +* initialized A. It is OK if A has NaNs in input. *****************************************************************************/ #ifndef LAPACK_DISABLE_NAN_CHECK diff --git a/lapack-netlib/LAPACKE/src/lapacke_claswp_work.c b/lapack-netlib/LAPACKE/src/lapacke_claswp_work.c index 582c6dbcd6..599e72fcfc 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_claswp_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_claswp_work.c @@ -46,7 +46,11 @@ lapack_int LAPACKE_claswp_work( int matrix_layout, lapack_int n, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int lda_t = MAX(1,k2); + lapack_int i; + for( i = k1; i <= k2; i++ ) { + lda_t = MAX( lda_t, ipiv[k1 + ( i - k1 ) * ABS( incx ) - 1] ); + } lapack_complex_float* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -62,12 +66,12 @@ lapack_int LAPACKE_claswp_work( int matrix_layout, lapack_int n, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_cge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, lda_t, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_claswp( &n, a_t, &lda_t, &k1, &k2, ipiv, &incx ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_cge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, lda_t, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_cstedc.c b/lapack-netlib/LAPACKE/src/lapacke_cstedc.c index ff8f996f22..22c4a354ef 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cstedc.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cstedc.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cstedc * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -58,7 +58,7 @@ lapack_int LAPACKE_cstedc( int matrix_layout, char compz, lapack_int n, float* d if( LAPACKE_s_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_cge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_csteqr.c b/lapack-netlib/LAPACKE/src/lapacke_csteqr.c index 8ea3b7ca96..57249e7dee 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_csteqr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_csteqr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function csteqr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -52,7 +52,7 @@ lapack_int LAPACKE_csteqr( int matrix_layout, char compz, lapack_int n, float* d if( LAPACKE_s_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_cge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_csycon_3.c b/lapack-netlib/LAPACKE/src/lapacke_csycon_3.c new file mode 100644 index 0000000000..6425d61ac0 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csycon_3.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csycon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, float* rcond ) +{ + lapack_int info = 0; + lapack_complex_float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csycon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csycon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csycon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csycon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_csycon_3_work.c new file mode 100644 index 0000000000..ec3a8ae664 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csycon_3_work.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csycon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, + const lapack_int* ipiv, float anorm, + float* rcond, lapack_complex_float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csycon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_csycon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csycon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csycon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csycon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csyconv.c b/lapack-netlib/LAPACKE/src/lapacke_csyconv.c index 47633a2639..cc1eb84afa 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_csyconv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_csyconv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function csyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,25 +36,18 @@ lapack_int LAPACKE_csyconv( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_float* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_float* work ) + lapack_complex_float* e ) { - lapack_int info = 0; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_csyconv", -1 ); return -1; } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_cge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { return -5; } #endif /* Call middle-level interface */ - info = LAPACKE_csyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, - work ); -exit_level_0: - if( info == LAPACK_WORK_MEMORY_ERROR ) { - LAPACKE_xerbla( "LAPACKE_csyconv", info ); - } - return info; + return LAPACKE_csyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, e ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_csyconv_work.c b/lapack-netlib/LAPACKE/src/lapacke_csyconv_work.c index 19e9abbd17..80a85179be 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_csyconv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_csyconv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function csyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,12 +36,12 @@ lapack_int LAPACKE_csyconv_work( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_float* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_float* work ) + lapack_complex_float* e ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_csyconv( &uplo, &way, &n, a, &lda, ipiv, work, &info ); + LAPACK_csyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } @@ -64,7 +64,7 @@ lapack_int LAPACKE_csyconv_work( int matrix_layout, char uplo, char way, /* Transpose input matrices */ LAPACKE_cge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_csyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, work, &info ); + LAPACK_csyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_csysv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_csysv_aa.c new file mode 100644 index 0000000000..579bfd8a4b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csysv_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csysv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally csyck input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csysv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_csysv_aa_work.c new file mode 100644 index 0000000000..e2f74464e1 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csysv_aa_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csysv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_csysv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_csysv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csysv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csysv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csysv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csysv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_csysv_rk.c new file mode 100644 index 0000000000..34e95f203d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csysv_rk.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, + lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_c_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csysv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_csysv_rk_work.c new file mode 100644 index 0000000000..f87f05175f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csysv_rk_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_complex_float* e, + lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csysv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_csysv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_csysv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csysv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csysv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csysv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csyswapr.c b/lapack-netlib/LAPACKE/src/lapacke_csyswapr.c index bb6992b0e1..78577aada1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_csyswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_csyswapr.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function csyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_csyswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_csyswapr", -1 ); @@ -43,9 +43,9 @@ lapack_int LAPACKE_csyswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_csyswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_csyswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_csyswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_csyswapr_work.c index ff8507bb29..ed215531bd 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_csyswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_csyswapr_work.c @@ -28,38 +28,39 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function csyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_csyswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_float* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_csyswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_csyswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); lapack_complex_float* a_t = NULL; /* Allocate memory for temporary array(s) */ a_t = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * n * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_csy_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_csyswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_csyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa.c new file mode 100644 index 0000000000..29d737cc00 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally csyck input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa_work.c new file mode 100644 index 0000000000..d4f24142ba --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrf_aa_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_csytrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csytrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk.c new file mode 100644 index 0000000000..eac1e6c45f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk_work.c new file mode 100644 index 0000000000..f98e8259be --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrf_rk_work.c @@ -0,0 +1,90 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* e, + lapack_int* ipiv, lapack_complex_float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csytrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_csytrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csytrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csytrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csytrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytri_3.c b/lapack-netlib/LAPACKE/src/lapacke_csytri_3.c new file mode 100644 index 0000000000..543d408de9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytri_3.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csytri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_c_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for working array(s) */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_csytri_3_work.c new file mode 100644 index 0000000000..b91d8a8554 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytri_3_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_float* a, lapack_int lda, + const lapack_complex_float* e, const lapack_int* ipiv, + lapack_complex_float* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csytri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_csytri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csytri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_csytrs_3.c new file mode 100644 index 0000000000..795fb2c9d9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrs_3.c @@ -0,0 +1,60 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csytrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_c_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_csytrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_csytrs_3_work.c new file mode 100644 index 0000000000..ef89b839dd --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrs_3_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_complex_float* e, + const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csytrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_csytrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_csytrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csytrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csytrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa.c new file mode 100644 index 0000000000..83ef44e110 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function csytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csytrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally csyck input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa_work.c new file mode 100644 index 0000000000..ad576b2363 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_csytrs_aa_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_float* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csytrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_csytrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_csytrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csytrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csytrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csytrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ctpmqrt.c b/lapack-netlib/LAPACKE/src/lapacke_ctpmqrt.c index bcb92a819a..b38fa0313c 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ctpmqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ctpmqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function ctpmqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,6 +41,9 @@ lapack_int LAPACKE_ctpmqrt( int matrix_layout, char side, char trans, lapack_complex_float* a, lapack_int lda, lapack_complex_float* b, lapack_int ldb ) { + lapack_int ncols_a, nrows_a; + lapack_int nrows_v; + lapack_int lwork; lapack_int info = 0; lapack_complex_float* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -49,22 +52,30 @@ lapack_int LAPACKE_ctpmqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_cge_nancheck( matrix_layout, k, m, a, lda ) ) { + ncols_a = LAPACKE_lsame( side, 'L' ) ? n : + ( LAPACKE_lsame( side, 'R' ) ? k : 0 ); + nrows_a = LAPACKE_lsame( side, 'L' ) ? k : + ( LAPACKE_lsame( side, 'R' ) ? m : 0 ); + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + if( LAPACKE_cge_nancheck( matrix_layout, nrows_a, ncols_a, a, lda ) ) { return -13; } if( LAPACKE_cge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -15; } - if( LAPACKE_cge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -11; } - if( LAPACKE_cge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -9; } #endif /* Allocate memory for working array(s) */ + lwork = LAPACKE_lsame( side, 'L' ) ? MAX(1,nb) * MAX(1,n) : + ( LAPACKE_lsame( side, 'R' ) ? MAX(1,m) * MAX(1,nb) : 0 ); work = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * MAX(1,m) * MAX(1,nb) ); + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_ctpqrt.c b/lapack-netlib/LAPACKE/src/lapacke_ctpqrt.c index e11ce784d9..6158f4a330 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ctpqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ctpqrt.c @@ -28,14 +28,14 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function ctpqrt * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_ctpqrt( int matrix_layout, lapack_int m, lapack_int n, - lapack_int l, lapack_int nb, - lapack_complex_float* a, lapack_int lda, + lapack_int l, lapack_int nb, + lapack_complex_float* a, lapack_int lda, lapack_complex_float* b, lapack_int ldb, lapack_complex_float* t, lapack_int ldt ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_ctprfb.c b/lapack-netlib/LAPACKE/src/lapacke_ctprfb.c index a007f924cb..f66469a2b7 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ctprfb.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ctprfb.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function ctprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,6 +41,7 @@ lapack_int LAPACKE_ctprfb( int matrix_layout, char side, char trans, char direct lapack_complex_float* a, lapack_int lda, lapack_complex_float* b, lapack_int ldb ) { + lapack_int ncols_v, nrows_v; lapack_int info = 0; lapack_int ldwork; lapack_int work_size; @@ -51,16 +52,28 @@ lapack_int LAPACKE_ctprfb( int matrix_layout, char side, char trans, char direct } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + if( LAPACKE_lsame( storev, 'C' ) ) { + ncols_v = k; + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + } else if( LAPACKE_lsame( storev, 'R' ) ) { + ncols_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + nrows_v = k; + } else { + ncols_v = 0; + nrows_v = 0; + } if( LAPACKE_cge_nancheck( matrix_layout, k, m, a, lda ) ) { return -14; } if( LAPACKE_cge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -16; } - if( LAPACKE_cge_nancheck( matrix_layout, ldt, k, t, ldt ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, k, k, t, ldt ) ) { return -12; } - if( LAPACKE_cge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, nrows_v, ncols_v, v, ldv ) ) { return -10; } #endif @@ -71,7 +84,7 @@ lapack_int LAPACKE_ctprfb( int matrix_layout, char side, char trans, char direct else { ldwork = m; work_size = MAX(1,ldwork) * MAX(1,k); - } + } /* Allocate memory for working array(s) */ work = (lapack_complex_float*) LAPACKE_malloc( sizeof(lapack_complex_float) * work_size ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_ctrexc_work.c b/lapack-netlib/LAPACKE/src/lapacke_ctrexc_work.c index 9501561e81..1d12d18ecf 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ctrexc_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ctrexc_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function ctrexc * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -51,7 +51,7 @@ lapack_int LAPACKE_ctrexc_work( int matrix_layout, char compq, lapack_int n, lapack_complex_float* t_t = NULL; lapack_complex_float* q_t = NULL; /* Check leading dimension(s) */ - if( ldq < n ) { + if( ldq < n && LAPACKE_lsame( compq, 'v' ) ) { info = -7; LAPACKE_xerbla( "LAPACKE_ctrexc_work", info ); return info; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1.c b/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1.c index 582ec7332c..e6749c1bc5 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function cuncsd2by1 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -37,7 +37,7 @@ lapack_int LAPACKE_cuncsd2by1( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_float* x11, lapack_int ldx11, lapack_complex_float* x21, lapack_int ldx21, - lapack_complex_float* theta, lapack_complex_float* u1, + float* theta, lapack_complex_float* u1, lapack_int ldu1, lapack_complex_float* u2, lapack_int ldu2, lapack_complex_float* v1t, lapack_int ldv1t ) { @@ -74,7 +74,7 @@ lapack_int LAPACKE_cuncsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_0; } /* Query optimal working array(s) size */ - info = LAPACKE_cuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_cuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, &work_query, lwork, &rwork_query, lrwork, iwork ); @@ -95,7 +95,7 @@ lapack_int LAPACKE_cuncsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_2; } /* Call middle-level interface */ - info = LAPACKE_cuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_cuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork ); /* Release memory and exit */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1_work.c b/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1_work.c index 6584673782..fb0a0f7ee6 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cuncsd2by1_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cuncsd2by1 * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -37,10 +37,10 @@ lapack_int LAPACKE_cuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_float* x11, lapack_int ldx11, lapack_complex_float* x21, lapack_int ldx21, - lapack_complex_float* theta, lapack_complex_float* u1, - lapack_int ldu1, lapack_complex_float* u2, + float* theta, lapack_complex_float* u1, + lapack_int ldu1, lapack_complex_float* u2, lapack_int ldu2, lapack_complex_float* v1t, - lapack_int ldv1t, lapack_complex_float* work, + lapack_int ldv1t, lapack_complex_float* work, lapack_int lwork, float* rwork, lapack_int lrwork, lapack_int* iwork ) { @@ -48,8 +48,8 @@ lapack_int LAPACKE_cuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_cuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11, x21, &ldx21, + theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, work, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -99,8 +99,8 @@ lapack_int LAPACKE_cuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, /* Query optimal working array(s) size if requested */ if( lrwork == -1 || lwork == -1 ) { LAPACK_cuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11_t, x21, &ldx21_t, + theta, u1, &ldu1_t, u2, &ldu2_t, v1t, &ldv1t_t, work, &lwork, rwork, &lrwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -146,8 +146,8 @@ lapack_int LAPACKE_cuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, ldx21_t ); /* Call LAPACK function and adjust info */ LAPACK_cuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11_t, &ldx11_t, x21_t, &ldx21_t, + theta, u1_t, &ldu1_t, u2_t, &ldu2_t, v1t_t, &ldv1t_t, work, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cunmbr_work.c b/lapack-netlib/LAPACKE/src/lapacke_cunmbr_work.c index c42f6e49ef..0da3b2a82c 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cunmbr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cunmbr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cunmbr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -73,9 +73,11 @@ lapack_int LAPACKE_cunmbr_work( int matrix_layout, char vect, char side, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - a_t = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * - lda_t * MAX(1,MIN(nq,k)) ); + if( LAPACKE_lsame( vect, 'q' ) ) { + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,k) ); + } else { + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,nq) ); + } if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_cunmlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_cunmlq_work.c index 1804b2b684..a7cc3ede62 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_cunmlq_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_cunmlq_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function cunmlq * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -73,8 +73,13 @@ lapack_int LAPACKE_cunmlq_work( int matrix_layout, char side, char trans, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - a_t = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,m) ); + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,m) ); + } else { + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + } if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx.c b/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx.c index d116f0dbf7..f61e11c417 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx.c @@ -28,20 +28,20 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dbdsvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dbdsvdx( int matrix_layout, char uplo, char jobz, char range, lapack_int n, double* d, double* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* z, lapack_int ldz, lapack_int* superb ) { lapack_int info = 0; - lapack_int lwork = 14*n; + lapack_int lwork = MAX(14*n,1); double* work = NULL; lapack_int* iwork = NULL; lapack_int i; @@ -54,7 +54,7 @@ lapack_int LAPACKE_dbdsvdx( int matrix_layout, char uplo, char jobz, char range, if( LAPACKE_d_nancheck( n, d, 1 ) ) { return -6; } - if( LAPACKE_d_nancheck( n, e, 1 ) ) { + if( LAPACKE_d_nancheck( n - 1, e, 1 ) ) { return -7; } #endif @@ -64,14 +64,14 @@ lapack_int LAPACKE_dbdsvdx( int matrix_layout, char uplo, char jobz, char range, info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(12*n,1) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } /* Call middle-level interface */ info = LAPACKE_dbdsvdx_work( matrix_layout, uplo, jobz, range, - n, d, e, vl, vu, il, iu, ns, s, z, + n, d, e, vl, vu, il, iu, ns, s, z, ldz, work, iwork); /* Backup significant data from working array(s) */ for( i=0; i<12*n-1; i++ ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx_work.c index 255d8f7119..a795110f90 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dbdsvdx_work.c @@ -28,41 +28,43 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dbdsvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dbdsvdx_work( int matrix_layout, char uplo, char jobz, char range, lapack_int n, double* d, double* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, - double* s, double* z, lapack_int ldz, + double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, + double* s, double* z, lapack_int ldz, double* work, lapack_int* iwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dbdsvdx( &uplo, &jobz, &range, &n, d, e, &vl, &vu, - &il, &iu, &ns, s, z, &ldz, + &il, &iu, ns, s, z, &ldz, work, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? MAX(2, 2*n) : 1; + lapack_int nrows_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? 2*n : 0; + lapack_int ncols_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(0,iu - il + 1) : n + 1 ) : 0; lapack_int ldz_t = MAX(1,nrows_z); double* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < nrows_z ) { + if( ldz < ncols_z ) { info = -3; LAPACKE_xerbla( "LAPACKE_dbdsvdx_work", info ); return info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( jobz, 'n' ) ) { + if( LAPACKE_lsame( jobz, 'v' ) ) { z_t = (double*) - LAPACKE_malloc( sizeof(double) * ldz_t * 2*n ); + LAPACKE_malloc( sizeof(double) * ldz_t * MAX(2*n,1) ); if( z_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -70,17 +72,17 @@ lapack_int LAPACKE_dbdsvdx_work( int matrix_layout, char uplo, char jobz, char r } /* Call LAPACK function and adjust info */ LAPACK_dbdsvdx( &uplo, &jobz, &range, &n, d, e, &vl, &vu, - &il, &iu, &ns, s, z_t, &ldz_t, work, + &il, &iu, ns, s, z_t, &ldz_t, work, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ - if( LAPACKE_lsame( jobz, 'n' ) ) { - LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_z, nrows_z, z_t, ldz_t, z, ldz); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_z, ncols_z, z_t, ldz_t, z, ldz); } /* Release memory and exit */ - if( LAPACKE_lsame( jobz, 'n' ) ) { + if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_free( z_t ); } exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgejsv.c b/lapack-netlib/LAPACKE/src/lapacke_dgejsv.c index 093afee973..85416056e5 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgejsv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgejsv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -70,7 +70,7 @@ lapack_int LAPACKE_dgejsv( int matrix_layout, char joba, char jobu, char jobv, ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && LAPACKE_lsame( jobv, 'j' ) ? MAX(7,m+3*n+n*n) : - 1) ) ) ) ) ); + 7) ) ) ) ) ); lapack_int* iwork = NULL; double* work = NULL; lapack_int i; @@ -86,25 +86,25 @@ lapack_int LAPACKE_dgejsv( int matrix_layout, char joba, char jobu, char jobv, if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { return -10; } - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - if( LAPACKE_dge_nancheck( matrix_layout, nu, n, u, ldu ) ) { - return -13; - } - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - if( LAPACKE_dge_nancheck( matrix_layout, nv, n, v, ldv ) ) { - return -15; - } - } #endif /* Allocate memory for working array(s) */ - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,m+3*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(3,m+3*n) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } + lwork = MAX3( lwork, 7, 2*m+n ); + { /* FIXUP LWORK */ + int want_u = LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ); + int want_v = LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ); + int want_sce = LAPACKE_lsame( joba, 'e' ) || LAPACKE_lsame( joba, 'g' ); + if( !want_u && !want_v && !want_sce ) lwork = MAX( lwork, 4*n+1 ); // 1.1 + if( !want_u && !want_v && want_sce ) lwork = MAX( lwork, n*n+4*n ); // 1.2 + if( !want_u && want_v ) lwork = MAX( lwork, 4*n+1 ); // 2 + if( want_u && !want_v ) lwork = MAX( lwork, 4*n+1 ); // 3 + if( want_u && LAPACKE_lsame( jobv, 'v' ) ) lwork = MAX( lwork, 6*n+2*n*n ); // 4.1 + if( want_u && LAPACKE_lsame( jobv, 'j' ) ) lwork = MAX3( lwork, 4*n+n*n, 2*n+n*n+6 ); // 4.2 + } work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgejsv_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgejsv_work.c index 379e63d2d1..fba9a374d9 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgejsv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgejsv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -53,6 +53,8 @@ lapack_int LAPACKE_dgejsv_work( int matrix_layout, char joba, char jobu, } else if( matrix_layout == LAPACK_ROW_MAJOR ) { lapack_int nu = LAPACKE_lsame( jobu, 'n' ) ? 1 : m; lapack_int nv = LAPACKE_lsame( jobv, 'n' ) ? 1 : n; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'n' ) ? 1 : + LAPACKE_lsame( jobu, 'f' ) ? m : n; lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nu); lapack_int ldv_t = MAX(1,nv); @@ -65,7 +67,7 @@ lapack_int LAPACKE_dgejsv_work( int matrix_layout, char joba, char jobu, LAPACKE_xerbla( "LAPACKE_dgejsv_work", info ); return info; } - if( ldu < n ) { + if( ldu < ncols_u ) { info = -14; LAPACKE_xerbla( "LAPACKE_dgejsv_work", info ); return info; @@ -83,7 +85,7 @@ lapack_int LAPACKE_dgejsv_work( int matrix_layout, char joba, char jobu, } if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - u_t = (double*)LAPACKE_malloc( sizeof(double) * ldu_t * MAX(1,n) ); + u_t = (double*)LAPACKE_malloc( sizeof(double) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_1; @@ -99,14 +101,6 @@ lapack_int LAPACKE_dgejsv_work( int matrix_layout, char joba, char jobu, } /* Transpose input matrices */ LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_dge_trans( matrix_layout, nu, n, u, ldu, u_t, ldu_t ); - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - LAPACKE_dge_trans( matrix_layout, nv, n, v, ldv, v_t, ldv_t ); - } /* Call LAPACK function and adjust info */ LAPACK_dgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a_t, &lda_t, sva, u_t, &ldu_t, v_t, &ldv_t, work, &lwork, @@ -117,7 +111,7 @@ lapack_int LAPACKE_dgejsv_work( int matrix_layout, char joba, char jobu, /* Transpose output matrices */ if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_dge_trans( LAPACK_COL_MAJOR, nu, n, u_t, ldu_t, u, ldu ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, nu, ncols_u, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'w' ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgelq.c b/lapack-netlib/LAPACKE/src/lapacke_dgelq.c new file mode 100644 index 0000000000..bd2be2c1cd --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgelq.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgelq_work( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgelq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgelq_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dgelq_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgelq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgelq_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgelq_work.c new file mode 100644 index 0000000000..1bd50678b9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgelq_work.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgelq_work( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgelq( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dgelq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_dgelq( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgelq( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgelq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgelq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgemlq.c b/lapack-netlib/LAPACKE/src/lapacke_dgemlq.c new file mode 100644 index 0000000000..fd62cad79e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgemlq.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgemlq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgemlq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, k, m, a, lda ) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_d_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgemlq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgemlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgemlq_work.c new file mode 100644 index 0000000000..e85252a14e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgemlq_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgemlq +* Author: Intel Corporation +* Generated June 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + double *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgemlq( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, + c, &ldc, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,k); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < r ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dgemlq_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_dgemlq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dgemlq( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,m) ); + } else { + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + } + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (double*)LAPACKE_malloc( sizeof(double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgemlq( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgemlq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgemlq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgemqr.c b/lapack-netlib/LAPACKE/src/lapacke_dgemqr.c new file mode 100644 index 0000000000..86566d9c41 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgemqr.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + lapack_int r; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgemqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_dge_nancheck( matrix_layout, r, k, a, lda ) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_d_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgemqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgemqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgemqr_work.c new file mode 100644 index 0000000000..a1179a466a --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgemqr_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const double* a, lapack_int lda, + const double* t, lapack_int tsize, + double* c, lapack_int ldc, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + double *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgemqr( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, c, &ldc, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,r); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < k ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dgemqr_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_dgemqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dgemqr( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*) + LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,k) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (double*) + LAPACKE_malloc( sizeof(double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, r, k, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgemqr( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgemqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgemqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgemqrt.c b/lapack-netlib/LAPACKE/src/lapacke_dgemqrt.c index 68cc6debc7..3fb17f0bf2 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgemqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgemqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function dgemqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,6 +39,7 @@ lapack_int LAPACKE_dgemqrt( int matrix_layout, char side, char trans, const double* t, lapack_int ldt, double* c, lapack_int ldc ) { + lapack_int nrows_v; lapack_int info = 0; double* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -47,13 +48,15 @@ lapack_int LAPACKE_dgemqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) { return -12; } - if( LAPACKE_dge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -10; } - if( LAPACKE_dge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -8; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgeqr.c b/lapack-netlib/LAPACKE/src/lapacke_dgeqr.c new file mode 100644 index 0000000000..7f9f9d29bc --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgeqr.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgeqr( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgeqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgeqr_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dgeqr_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgeqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgeqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgeqr_work.c new file mode 100644 index 0000000000..8bc3b1cb4b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgeqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + double* a, lapack_int lda, + double* t, lapack_int tsize, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgeqr( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dgeqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_dgeqr( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*) + LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgeqr( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgeqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgeqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgesvdx.c b/lapack-netlib/LAPACKE/src/lapacke_dgesvdx.c index ec487cea03..ca82202dfb 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgesvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgesvdx.c @@ -28,15 +28,15 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* u, lapack_int ldu, double* vt, lapack_int ldvt, lapack_int* superb ) @@ -71,7 +71,7 @@ lapack_int LAPACKE_dgesvdx( int matrix_layout, char jobu, char jobvt, char range info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*MIN(m,n)) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,(12*MIN(m,n))) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgesvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgesvdx_work.c index b334486f5a..a5a2cb65ed 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgesvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgesvdx_work.c @@ -28,38 +28,40 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, double* u, lapack_int ldu, - double* vt, lapack_int ldvt, + double* vt, lapack_int ldvt, double* work, lapack_int lwork, lapack_int* iwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda, &vl, &vu, - &il, &iu, &ns, s, u, &ldu, vt, &ldvt, + &il, &iu, ns, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_u = ( LAPACKE_lsame( jobu, 'a' ) || - LAPACKE_lsame( jobu, 's' ) ) ? m : 1; - lapack_int ncols_u = LAPACKE_lsame( jobu, 'a' ) ? m : - ( LAPACKE_lsame( jobu, 's' ) ? MIN(m,n) : 1); - lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'a' ) ? n : - ( LAPACKE_lsame( jobvt, 's' ) ? MIN(m,n) : 1); + lapack_int nrows_u = LAPACKE_lsame( jobu, 'v' ) ? m : 0; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int ncols_vt = LAPACKE_lsame( jobvt, 'v' ) ? n : 0; + lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nrows_u); lapack_int ldvt_t = MAX(1,nrows_vt); + double* a_t = NULL; double* u_t = NULL; double* vt_t = NULL; @@ -74,7 +76,7 @@ lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char LAPACKE_xerbla( "LAPACKE_dgesvdx_work", info ); return info; } - if( ldvt < n ) { + if( ldvt < ncols_vt ) { info = -18; LAPACKE_xerbla( "LAPACKE_dgesvdx_work", info ); return info; @@ -82,7 +84,7 @@ lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_dgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + &il, &iu, ns, s, u, &ldu_t, vt, &ldvt_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -92,7 +94,7 @@ lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { u_t = (double*) LAPACKE_malloc( sizeof(double) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { @@ -100,7 +102,7 @@ lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char goto exit_level_1; } } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { vt_t = (double*) LAPACKE_malloc( sizeof(double) * ldvt_t * MAX(1,n) ); if( vt_t == NULL ) { @@ -111,28 +113,28 @@ lapack_int LAPACKE_dgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Transpose input matrices */ LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_dgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + LAPACK_dgesvdx( &jobu, &jobvt, &range, &m, &n, a_t, &lda_t, &vl, &vu, + &il, &iu, ns, s, u_t, &ldu_t, vt_t, &ldvt_t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_u, ncols_u, u_t, ldu_t, u, ldu ); } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_vt, n, vt_t, ldvt_t, vt, ldvt ); } /* Release memory and exit */ - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_free( vt_t ); } exit_level_2: - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_free( u_t ); } exit_level_1: diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgesvj.c b/lapack-netlib/LAPACKE/src/lapacke_dgesvj.c index 1ffd432e57..542e52f790 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgesvj.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgesvj.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dgesvj * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -49,8 +49,8 @@ lapack_int LAPACKE_dgesvj( int matrix_layout, char joba, char jobu, char jobv, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { return -7; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgesvj_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgesvj_work.c index f2b1b9cd53..200b346cf1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dgesvj_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dgesvj_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dgesvj * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -48,8 +48,8 @@ lapack_int LAPACKE_dgesvj_work( int matrix_layout, char joba, char jobu, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); lapack_int lda_t = MAX(1,m); lapack_int ldv_t = MAX(1,nrows_v); double* a_t = NULL; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgetsls.c b/lapack-netlib/LAPACKE/src/lapacke_dgetsls.c new file mode 100644 index 0000000000..57563f5e50 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgetsls.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, double* a, + lapack_int lda, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgetsls", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -6; + } + if( LAPACKE_dge_nancheck( matrix_layout, MAX(m,n), nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgetsls", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgetsls_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgetsls_work.c new file mode 100644 index 0000000000..6f84d67484 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgetsls_work.c @@ -0,0 +1,108 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgetsls( &trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,MAX(m,n)); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dgetsls_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_dgetsls_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dgetsls( &trans, &m, &n, &nrhs, a, &lda_t, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, MAX(m,n), nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgetsls( &trans, &m, &n, &nrhs, a_t, &lda_t, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, MAX(m,n), nrhs, b_t, ldb_t, b, + ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgetsls_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgetsls_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dggsvd3_work.c b/lapack-netlib/LAPACKE/src/lapacke_dggsvd3_work.c index dcc6bc81ac..228a5b72fd 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dggsvd3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dggsvd3_work.c @@ -91,9 +91,9 @@ lapack_int LAPACKE_dggsvd3_work( int matrix_layout, char jobu, char jobv, } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_dggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a_t, &lda_t, - b_t, &ldb_t, alpha, beta, u_t, &ldu_t, v_t, &ldv_t, - q_t, &ldq_t, work, &lwork, iwork, &info ); + LAPACK_dggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a, &lda_t, + b, &ldb_t, alpha, beta, u, &ldu_t, v, &ldv_t, + q, &ldq_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_dggsvp3_work.c b/lapack-netlib/LAPACKE/src/lapacke_dggsvp3_work.c index e80a755761..d044df1e10 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dggsvp3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dggsvp3_work.c @@ -84,15 +84,15 @@ lapack_int LAPACKE_dggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_xerbla( "LAPACKE_dggsvp3_work", info ); return info; } - if( ldv < m ) { + if( ldv < p ) { info = -19; LAPACKE_xerbla( "LAPACKE_dggsvp3_work", info ); return info; } if( lwork == -1 ) { - LAPACK_dggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a_t, &lda_t, b_t, - &ldb_t, &tola, &tolb, k, l, u_t, &ldu_t, v_t, - &ldv_t, q_t, &ldq_t, iwork, tau, work, &lwork, + LAPACK_dggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a, &lda_t, b, + &ldb_t, &tola, &tolb, k, l, u, &ldu_t, v, + &ldv_t, q, &ldq_t, iwork, tau, work, &lwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -115,7 +115,7 @@ lapack_int LAPACKE_dggsvp3_work( int matrix_layout, char jobu, char jobv, } } if( LAPACKE_lsame( jobv, 'v' ) ) { - v_t = (double*)LAPACKE_malloc( sizeof(double) * ldv_t * MAX(1,m) ); + v_t = (double*)LAPACKE_malloc( sizeof(double) * ldv_t * MAX(1,p) ); if( v_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_3; @@ -145,7 +145,7 @@ lapack_int LAPACKE_dggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, m, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'v' ) ) { - LAPACKE_dge_trans( LAPACK_COL_MAJOR, p, m, v_t, ldv_t, v, ldv ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, p, p, v_t, ldv_t, v, ldv ); } if( LAPACKE_lsame( jobq, 'q' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlantr.c b/lapack-netlib/LAPACKE/src/lapacke_dlantr.c index 8fd1120841..480f31d910 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlantr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlantr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dlantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlantr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dlantr_work.c index ee5e665eed..2d570ce427 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlantr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlantr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dlantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlarfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_dlarfb_work.c index 3fe4893167..ef9c70df4c 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlarfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlarfb_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dlarfb * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -43,7 +43,7 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans, lapack_int info = 0; lapack_int nrows_v, ncols_v; lapack_int ldc_t, ldt_t, ldv_t; - double *v_t = NULL, *t_t = NULL, *c_t = NULL; + double *v_t = NULL, *t_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dlarfb( &side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, @@ -119,7 +119,7 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans, LAPACKE_dge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv, &v_t[k*ldv_t], ldv_t ); } else if( LAPACKE_lsame( storev, 'r' ) && - LAPACKE_lsame( direct, 'f' ) ) { + LAPACKE_lsame( direct, 'b' ) ) { if( k > ncols_v ) { LAPACKE_xerbla( "LAPACKE_dlarfb_work", -8 ); return -8; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlascl.c b/lapack-netlib/LAPACKE/src/lapacke_dlascl.c index d3a2f49347..b35b9b289b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlascl.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlascl.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dlaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dlascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, double* a, lapack_int lda ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -46,50 +46,64 @@ lapack_int LAPACKE_dlascl( int matrix_layout, char type, lapack_int kl, /* Optionally check input matrices for NaNs */ switch (type) { case 'G': - if( LAPACKE_dge_nancheck( matrix_layout, lda, n, a, lda ) ) { - return -9; - } + if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -9; + } break; case 'L': - // TYPE = 'L' - lower triangular matrix. - if( LAPACKE_dtr_nancheck( matrix_layout, 'L', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'L' - lower triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_dgb_nancheck( matrix_layout, m, n, m-1, 0, a, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_dgb_nancheck( LAPACK_COL_MAJOR, n, m, 0, m-1, a-m+1, lda+1 ) ) { + return -9; + } break; case 'U': - // TYPE = 'U' - upper triangular matrix - if( LAPACKE_dtr_nancheck( matrix_layout, 'U', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'U' - upper triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_dgb_nancheck( matrix_layout, m, n, 0, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_dgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 0, a, lda+1 ) ) { + return -9; + } break; case 'H': - // TYPE = 'H' - upper Hessenberg matrix - if( LAPACKE_dhs_nancheck( matrix_layout, n, a, lda ) ) { - return -9; - } - break; + // TYPE = 'H' - part of upper Hessenberg matrix in general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_dgb_nancheck( matrix_layout, m, n, 1, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_dgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 1, a-1, lda+1 ) ) { + return -9; + } case 'B': - // TYPE = 'B' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the lower - // half stored. - if( LAPACKE_dsb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { - return -9; - } - break; - case 'Q': - // TYPE = 'Q' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the upper - // half stored. - if( LAPACKE_dsb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { - return -9; - } + // TYPE = 'B' - lower part of symmetric band matrix (assume m==n) + if( LAPACKE_dsb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { + return -9; + } + break; + case 'Q': + // TYPE = 'Q' - upper part of symmetric band matrix (assume m==n) + if( LAPACKE_dsb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { + return -9; + } break; case 'Z': - // TYPE = 'Z' - A is a band matrix with lower bandwidth KL and upper - // bandwidth KU. See DGBTRF for storage details. - if( LAPACKE_dgb_nancheck( matrix_layout, n, n, kl, kl+ku, a, lda ) ) { - return -6; - } + // TYPE = 'Z' - band matrix laid out for ?GBTRF + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_dgb_nancheck( matrix_layout, m, n, kl, ku, a+kl, lda ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_dgb_nancheck( matrix_layout, m, n, kl, ku, a+lda*kl, lda ) ) { + return -9; + } break; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlascl_work.c b/lapack-netlib/LAPACKE/src/lapacke_dlascl_work.c index a98f3c8743..a20bf09e6a 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlascl_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlascl_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dlaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dlascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, double* a, lapack_int lda ) { lapack_int info = 0; @@ -46,7 +46,10 @@ lapack_int LAPACKE_dlascl_work( int matrix_layout, char type, lapack_int kl, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int nrows_a = LAPACKE_lsame(type, 'b') ? kl + 1 : + LAPACKE_lsame(type, 'q') ? ku + 1 : + LAPACKE_lsame(type, 'z') ? 2 * kl + ku + 1 : m; + lapack_int lda_t = MAX(1,nrows_a); double* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -61,12 +64,14 @@ lapack_int LAPACKE_dlascl_work( int matrix_layout, char type, lapack_int kl, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_dge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, nrows_a, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_dlascl( &type, &kl, &ku, &cfrom, &cto, &m, &n, a_t, &lda_t, &info); - info = 0; /* LAPACK call is ok! */ + if( info < 0 ) { + info = info - 1; + } /* Transpose output matrices */ - LAPACKE_dge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_a, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlaset.c b/lapack-netlib/LAPACKE/src/lapacke_dlaset.c index 3a299e9bef..cbd52b22b1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlaset.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlaset.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dlaset * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -44,8 +44,8 @@ lapack_int LAPACKE_dlaset( int matrix_layout, char uplo, lapack_int m, } /***************************************************************************** -* Note: we do not check NaNs in A since the goal of this subroutine is to -* initialized A. It is OK if A has NaNs in input. +* Note: we do not check NaNs in A since the goal of this subroutine is to +* initialized A. It is OK if A has NaNs in input. *****************************************************************************/ #ifndef LAPACK_DISABLE_NAN_CHECK diff --git a/lapack-netlib/LAPACKE/src/lapacke_dlaswp_work.c b/lapack-netlib/LAPACKE/src/lapacke_dlaswp_work.c index 5aa2219cd9..027c25fc04 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dlaswp_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dlaswp_work.c @@ -45,7 +45,11 @@ lapack_int LAPACKE_dlaswp_work( int matrix_layout, lapack_int n, double* a, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int lda_t = MAX(1,k2); + lapack_int i; + for( i = k1; i <= k2; i++ ) { + lda_t = MAX( lda_t, ipiv[k1 + ( i - k1 ) * ABS( incx ) - 1] ); + } double* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -60,12 +64,12 @@ lapack_int LAPACKE_dlaswp_work( int matrix_layout, lapack_int n, double* a, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_dge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, lda_t, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_dlaswp( &n, a_t, &lda_t, &k1, &k2, ipiv, &incx ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_dge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, lda_t, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1.c b/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1.c index 7c71cd47bd..43ca0b6caa 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dorcsd2by1 * Author: Intel Corporation -* Generated November, 2011 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -69,7 +69,7 @@ lapack_int LAPACKE_dorcsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_0; } /* Query optimal working array(s) size */ - info = LAPACKE_dorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_dorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, &work_query, lwork, iwork ); @@ -84,7 +84,7 @@ lapack_int LAPACKE_dorcsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_1; } /* Call middle-level interface */ - info = LAPACKE_dorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_dorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, iwork ); /* Release memory and exit */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1_work.c b/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1_work.c index 8a080fbcd8..5cc39b1b02 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dorcsd2by1_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dorcsd2by1 * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -46,8 +46,8 @@ lapack_int LAPACKE_dorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11, x21, &ldx21, + theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -97,8 +97,8 @@ lapack_int LAPACKE_dorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_dorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11_t, x21, &ldx21_t, + theta, u1, &ldu1_t, u2, &ldu2_t, v1t, &ldv1t_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -144,8 +144,8 @@ lapack_int LAPACKE_dorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, ldx21_t ); /* Call LAPACK function and adjust info */ LAPACK_dorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11_t, &ldx11_t, x21_t, &ldx21_t, + theta, u1_t, &ldu1_t, u2_t, &ldu2_t, v1t_t, &ldv1t_t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dormbr.c b/lapack-netlib/LAPACKE/src/lapacke_dormbr.c index 5f1de948bd..bee4b1ae04 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dormbr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dormbr.c @@ -42,7 +42,7 @@ lapack_int LAPACKE_dormbr( int matrix_layout, char vect, char side, char trans, lapack_int lwork = -1; double* work = NULL; double work_query; - lapack_int nq, r; + lapack_int nq, ar, ac; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_dormbr", -1 ); return -1; @@ -50,8 +50,9 @@ lapack_int LAPACKE_dormbr( int matrix_layout, char vect, char side, char trans, #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ nq = LAPACKE_lsame( side, 'l' ) ? m : n; - r = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); - if( LAPACKE_dge_nancheck( matrix_layout, r, MIN(nq,k), a, lda ) ) { + ar = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); + ac = LAPACKE_lsame( vect, 'q' ) ? MIN(nq,k) : nq; + if( LAPACKE_dge_nancheck( matrix_layout, ar, ac, a, lda ) ) { return -8; } if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dormbr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dormbr_work.c index dcd8842fae..d6adc83fea 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dormbr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dormbr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dormbr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,9 +40,6 @@ lapack_int LAPACKE_dormbr_work( int matrix_layout, char vect, char side, double* work, lapack_int lwork ) { lapack_int info = 0; - lapack_int nq, r; - lapack_int lda_t, ldc_t; - double *a_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dormbr( &vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, @@ -51,12 +48,15 @@ lapack_int LAPACKE_dormbr_work( int matrix_layout, char vect, char side, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - nq = LAPACKE_lsame( side, 'l' ) ? m : n; - r = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); - lda_t = MAX(1,r); - ldc_t = MAX(1,m); + lapack_int nq = LAPACKE_lsame( side, 'l' ) ? m : n; + lapack_int ar = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); + lapack_int ac = LAPACKE_lsame( vect, 'q' ) ? MIN(nq,k) : nq; + lapack_int lda_t = MAX(1,ar); + lapack_int ldc_t = MAX(1,m); + double *a_t = NULL; + double *c_t = NULL; /* Check leading dimension(s) */ - if( lda < MIN(nq,k) ) { + if( lda < ac ) { info = -9; LAPACKE_xerbla( "LAPACKE_dormbr_work", info ); return info; @@ -73,11 +73,7 @@ lapack_int LAPACKE_dormbr_work( int matrix_layout, char vect, char side, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( vect, 'q' ) ) { - a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,k) ); - } else { - a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,nq) ); - } + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,ac) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -88,7 +84,7 @@ lapack_int LAPACKE_dormbr_work( int matrix_layout, char vect, char side, goto exit_level_1; } /* Transpose input matrices */ - LAPACKE_dge_trans( matrix_layout, r, MIN(nq,k), a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, ar, ac, a, lda, a_t, lda_t ); LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); /* Call LAPACK function and adjust info */ LAPACK_dormbr( &vect, &side, &trans, &m, &n, &k, a_t, &lda_t, tau, c_t, diff --git a/lapack-netlib/LAPACKE/src/lapacke_dormlq.c b/lapack-netlib/LAPACKE/src/lapacke_dormlq.c index 77f0b85b18..e4bf0c14fc 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dormlq.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dormlq.c @@ -48,7 +48,8 @@ lapack_int LAPACKE_dormlq( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_dge_nancheck( matrix_layout, k, m, a, lda ) ) { + lapack_int r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_dge_nancheck( matrix_layout, k, r, a, lda ) ) { return -7; } if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dormlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_dormlq_work.c index f46c6d3b1d..7b383d0ed9 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dormlq_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dormlq_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dormlq * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,9 +40,6 @@ lapack_int LAPACKE_dormlq_work( int matrix_layout, char side, char trans, double* work, lapack_int lwork ) { lapack_int info = 0; - lapack_int r; - lapack_int lda_t, ldc_t; - double *a_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_dormlq( &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, @@ -51,9 +48,11 @@ lapack_int LAPACKE_dormlq_work( int matrix_layout, char side, char trans, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - r = LAPACKE_lsame( side, 'l' ) ? m : n; - lda_t = MAX(1,k); - ldc_t = MAX(1,m); + lapack_int r = LAPACKE_lsame( side, 'l' ) ? m : n; + lapack_int lda_t = MAX(1,k); + lapack_int ldc_t = MAX(1,m); + double *a_t = NULL; + double *c_t = NULL; /* Check leading dimension(s) */ if( lda < r ) { info = -8; @@ -72,11 +71,7 @@ lapack_int LAPACKE_dormlq_work( int matrix_layout, char side, char trans, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( side, 'l' ) ) { - a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,m) ); - } else { - a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); - } + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,r) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -87,7 +82,7 @@ lapack_int LAPACKE_dormlq_work( int matrix_layout, char side, char trans, goto exit_level_1; } /* Transpose input matrices */ - LAPACKE_dge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, k, r, a, lda, a_t, lda_t ); LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); /* Call LAPACK function and adjust info */ LAPACK_dormlq( &side, &trans, &m, &n, &k, a_t, &lda_t, tau, c_t, &ldc_t, diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage.c new file mode 100644 index 0000000000..3ad34a6604 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, double* ab, lapack_int ldab, double* w, + double* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsbev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage_work.c new file mode 100644 index 0000000000..a0bfbdd87c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbev_2stage_work.c @@ -0,0 +1,113 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsbev_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + double* ab_t = NULL; + double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dsbev_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dsbev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (double*)LAPACKE_malloc( sizeof(double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (double*)LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_dsb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsbev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage.c new file mode 100644 index 0000000000..a197c3f9e2 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, double* ab, lapack_int ldab, + double* w, double* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + lapack_int iwork_query; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage_work.c new file mode 100644 index 0000000000..915674409c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbevd_2stage_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + double* ab_t = NULL; + double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_dsbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab_t, w, z, &ldz_t, + work, &lwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (double*)LAPACKE_malloc( sizeof(double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (double*)LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_dsb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsbevd_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsbevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage.c new file mode 100644 index 0000000000..7188efc760 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, double* ab, + lapack_int ldab, double* q, lapack_int ldq, + double vl, double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -7; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -15; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -11; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -12; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, &work_query, lwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int) work_query; + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, work, lwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage_work.c new file mode 100644 index 0000000000..49c9922130 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbevx_2stage_work.c @@ -0,0 +1,146 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + double* ab, lapack_int ldab, double* q, + lapack_int ldq, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, + &vu, &il, &iu, &abstol, m, w, z, &ldz, work, &lwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + double* ab_t = NULL; + double* q_t = NULL; + double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage_work", info ); + return info; + } + if( ldq < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -19; + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (double*)LAPACKE_malloc( sizeof(double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + q_t = (double*)LAPACKE_malloc( sizeof(double) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (double*) + LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Transpose input matrices */ + LAPACKE_dsb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_2: + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( q_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsbevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsbtrd.c b/lapack-netlib/LAPACKE/src/lapacke_dsbtrd.c index d9fa474b2f..c1c9c03c5e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsbtrd.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsbtrd.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dsbtrd * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -48,7 +48,7 @@ lapack_int LAPACKE_dsbtrd( int matrix_layout, char vect, char uplo, lapack_int n if( LAPACKE_dsb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { return -6; } - if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) { + if( LAPACKE_lsame( vect, 'u' ) ) { if( LAPACKE_dge_nancheck( matrix_layout, n, n, q, ldq ) ) { return -10; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dstedc.c b/lapack-netlib/LAPACKE/src/lapacke_dstedc.c index 70a7346d1d..a974f4563f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dstedc.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dstedc.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dstedc * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -55,7 +55,7 @@ lapack_int LAPACKE_dstedc( int matrix_layout, char compz, lapack_int n, if( LAPACKE_d_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_dge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsteqr.c b/lapack-netlib/LAPACKE/src/lapacke_dsteqr.c index 6476aae182..81f325e661 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsteqr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsteqr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dsteqr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -52,7 +52,7 @@ lapack_int LAPACKE_dsteqr( int matrix_layout, char compz, lapack_int n, if( LAPACKE_d_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_dge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsycon_3.c b/lapack-netlib/LAPACKE/src/lapacke_dsycon_3.c new file mode 100644 index 0000000000..40503d1170 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsycon_3.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsycon_3( int matrix_layout, char uplo, lapack_int n, + const double* a, lapack_int lda, const double* e, + const lapack_int* ipiv, double anorm, double* rcond ) +{ + lapack_int info = 0; + lapack_int* iwork = NULL; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsycon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_d_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsycon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work, iwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsycon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsycon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsycon_3_work.c new file mode 100644 index 0000000000..e4e2d29f7f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsycon_3_work.c @@ -0,0 +1,83 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsycon_3_work( int matrix_layout, char uplo, lapack_int n, + const double* a, lapack_int lda, + const double* e, const lapack_int* ipiv, double anorm, + double* rcond, double* work, lapack_int* iwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsycon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, iwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dsycon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsycon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, iwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsycon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsycon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyconv.c b/lapack-netlib/LAPACKE/src/lapacke_dsyconv.c index ba937a97bb..1e3f78ee64 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsyconv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyconv.c @@ -28,32 +28,24 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dsyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dsyconv( int matrix_layout, char uplo, char way, lapack_int n, - double* a, lapack_int lda, const lapack_int* ipiv, double* work ) + double* a, lapack_int lda, const lapack_int* ipiv, double* e ) { - lapack_int info = 0; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_dsyconv", -1 ); return -1; } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_dge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { return -5; } #endif - /* Call middle-level interface */ - info = LAPACKE_dsyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, - work ); -exit_level_0: - if( info == LAPACK_WORK_MEMORY_ERROR ) { - LAPACKE_xerbla( "LAPACKE_dsyconv", info ); - } - return info; + return LAPACKE_dsyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, e ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyconv_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyconv_work.c index 3355dd32c7..05e8124620 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsyconv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyconv_work.c @@ -28,19 +28,19 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dsyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dsyconv_work( int matrix_layout, char uplo, char way, lapack_int n, double* a, lapack_int lda, - const lapack_int* ipiv, double* work ) + const lapack_int* ipiv, double* e ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_dsyconv( &uplo, &way, &n, a, &lda, ipiv, work, &info ); + LAPACK_dsyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } @@ -62,7 +62,7 @@ lapack_int LAPACKE_dsyconv_work( int matrix_layout, char uplo, char way, /* Transpose input matrices */ LAPACKE_dge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_dsyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, work, &info ); + LAPACK_dsyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage.c new file mode 100644 index 0000000000..1bac918847 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsyev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsyev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsyev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsyev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage_work.c new file mode 100644 index 0000000000..f103de9159 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyev_2stage_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsyev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsyev_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsyev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsyev_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsyev_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsyev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage.c new file mode 100644 index 0000000000..627605a5c8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsyevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + lapack_int iwork_query; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsyevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsyevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsyevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage_work.c new file mode 100644 index 0000000000..1d06250d16 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevd_2stage_work.c @@ -0,0 +1,91 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsyevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsyevd_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsyevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_dsyevd_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, iwork, + &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsyevd_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsyevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage.c new file mode 100644 index 0000000000..ee191d0249 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage.c @@ -0,0 +1,105 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsyevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, double* a, lapack_int lda, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* isuppz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + lapack_int iwork_query; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsyevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsyevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, work, + lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage_work.c new file mode 100644 index 0000000000..3ba0f3df2e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevr_2stage_work.c @@ -0,0 +1,124 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsyevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, double* a, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* isuppz, + double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsyevr_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, isuppz, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + double* a_t = NULL; + double* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_dsyevr_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, isuppz, work, &lwork, + iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (double*) + LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsyevr_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, isuppz, work, &lwork, + iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsyevr_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage.c new file mode 100644 index 0000000000..29b6fa5338 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsyevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, double* a, lapack_int lda, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, double* z, + lapack_int ldz, lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_dsyevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, &work_query, + lwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dsyevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, work, lwork, + iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage_work.c new file mode 100644 index 0000000000..76b3a85e5f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyevx_2stage_work.c @@ -0,0 +1,123 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsyevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsyevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, double* a, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, double abstol, + lapack_int* m, double* w, double* z, + lapack_int ldz, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsyevx_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, work, &lwork, iwork, ifail, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + double* a_t = NULL; + double* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsyevx_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, work, &lwork, iwork, + ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (double*) + LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsyevx_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, work, &lwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsyevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage.c new file mode 100644 index 0000000000..018e038b75 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsygv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsygv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsygv_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -6; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsygv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsygv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsygv_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage_work.c new file mode 100644 index 0000000000..cc22255247 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsygv_2stage_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsygv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsygv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* w, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsygv_2stage( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_dsygv_2stage_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_dsygv_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsygv_2stage( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsygv_2stage( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsygv_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsygv_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsygvx_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsygvx_work.c index a53e8f748f..b5f41c773e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsygvx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsygvx_work.c @@ -105,7 +105,7 @@ lapack_int LAPACKE_dsygvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose input matrices */ LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); - LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + LAPACKE_dsy_trans( matrix_layout, uplo, n, b, ldb, b_t, ldb_t ); /* Call LAPACK function and adjust info */ LAPACK_dsygvx( &itype, &jobz, &range, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, @@ -115,7 +115,7 @@ lapack_int LAPACKE_dsygvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose output matrices */ LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); - LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, b_t, ldb_t, b, ldb ); if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, ldz ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa.c new file mode 100644 index 0000000000..ea8d4f9f61 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa_work.c new file mode 100644 index 0000000000..6509a81007 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsysv_aa_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsysv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_dsysv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsysv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsysv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk.c new file mode 100644 index 0000000000..ba9eaa3a82 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk.c @@ -0,0 +1,83 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + double* e, lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_d_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk_work.c new file mode 100644 index 0000000000..e712f58634 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsysv_rk_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + double* e, lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsysv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dsysv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsysv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsysv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyswapr.c b/lapack-netlib/LAPACKE/src/lapacke_dsyswapr.c index 728ef0900d..eed600c60b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsyswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyswapr.c @@ -28,13 +28,13 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dsyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dsyswapr( int matrix_layout, char uplo, lapack_int n, - double* a, lapack_int i1, lapack_int i2 ) + double* a, lapack_int lda, lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_dsyswapr", -1 ); @@ -42,9 +42,9 @@ lapack_int LAPACKE_dsyswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_dsyswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_dsyswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsyswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsyswapr_work.c index 2855593f6a..1504803253 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsyswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsyswapr_work.c @@ -28,36 +28,38 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dsyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_dsyswapr_work( int matrix_layout, char uplo, lapack_int n, - double* a, lapack_int i1, lapack_int i2 ) + double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_dsyswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_dsyswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); double* a_t = NULL; /* Allocate memory for temporary array(s) */ - a_t = (double*)LAPACKE_malloc( sizeof(double) * n * MAX(1,n) ); + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_dsy_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_dsyswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_dsyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa.c new file mode 100644 index 0000000000..1e81f6a2c8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrf_aa( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa_work.c new file mode 100644 index 0000000000..cbf97b6326 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_aa_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int* ipiv, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dsytrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsytrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk.c new file mode 100644 index 0000000000..0d9cade8ee --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrf_rk( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, double* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_d_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk_work.c new file mode 100644 index 0000000000..0dc62630c4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrf_rk_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, double* e, lapack_int* ipiv, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsytrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dsytrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsytrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsytrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsytrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytri2.c b/lapack-netlib/LAPACKE/src/lapacke_dsytri2.c index 4797491c76..8ab5d82fdc 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsytri2.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytri2.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dsytri2 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -38,8 +38,8 @@ lapack_int LAPACKE_dsytri2( int matrix_layout, char uplo, lapack_int n, { lapack_int info = 0; lapack_int lwork = -1; - lapack_complex_double* work = NULL; - lapack_complex_double work_query; + double* work = NULL; + double work_query; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_dsytri2", -1 ); return -1; @@ -58,8 +58,8 @@ lapack_int LAPACKE_dsytri2( int matrix_layout, char uplo, lapack_int n, } lwork = LAPACK_Z2INT( work_query ); /* Allocate memory for work arrays */ - work = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + work = (double*) + LAPACKE_malloc( sizeof(double) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytri2_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytri2_work.c index 2168baf0fc..1f7f9088f0 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dsytri2_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytri2_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dsytri2 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,7 +36,7 @@ lapack_int LAPACKE_dsytri2_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_double* work, lapack_int lwork ) + double* work, lapack_int lwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytri_3.c b/lapack-netlib/LAPACKE/src/lapacke_dsytri_3.c new file mode 100644 index 0000000000..b0960dada7 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytri_3.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytri_3( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, const double* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsytri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_d_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytri_3_work.c new file mode 100644 index 0000000000..4d2c78b0c5 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytri_3_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytri_3_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, const double* e, + const lapack_int* ipiv, double* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsytri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_dsytri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsytri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3.c new file mode 100644 index 0000000000..59b83f9ae6 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3.c @@ -0,0 +1,59 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const double* e, + const lapack_int* ipiv, double* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsytrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_d_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_dsytrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3_work.c new file mode 100644 index 0000000000..ba92e4522c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_3_work.c @@ -0,0 +1,99 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const double* e, + const lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsytrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsytrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dsytrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsytrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsytrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa.c new file mode 100644 index 0000000000..6adb343a4a --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsytrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*) + LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa_work.c new file mode 100644 index 0000000000..6b266e084f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dsytrs_aa_work.c @@ -0,0 +1,99 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsytrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsytrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_dsytrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsytrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsytrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsytrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dtpmqrt.c b/lapack-netlib/LAPACKE/src/lapacke_dtpmqrt.c index d11f08283c..140890464b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dtpmqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dtpmqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function dtpmqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,6 +40,9 @@ lapack_int LAPACKE_dtpmqrt( int matrix_layout, char side, char trans, double* a, lapack_int lda, double* b, lapack_int ldb ) { + lapack_int ncols_a, nrows_a; + lapack_int nrows_v; + lapack_int lwork; lapack_int info = 0; double* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -48,21 +51,29 @@ lapack_int LAPACKE_dtpmqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_dge_nancheck( matrix_layout, k, m, a, lda ) ) { + ncols_a = LAPACKE_lsame( side, 'L' ) ? n : + ( LAPACKE_lsame( side, 'R' ) ? k : 0 ); + nrows_a = LAPACKE_lsame( side, 'L' ) ? k : + ( LAPACKE_lsame( side, 'R' ) ? m : 0 ); + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + if( LAPACKE_dge_nancheck( matrix_layout, nrows_a, ncols_a, a, lda ) ) { return -13; } if( LAPACKE_dge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -15; } - if( LAPACKE_dge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -11; } - if( LAPACKE_dge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -9; } #endif /* Allocate memory for working array(s) */ - work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,m) * MAX(1,nb) ); + lwork = LAPACKE_lsame( side, 'L' ) ? MAX(1,nb) * MAX(1,n) : + ( LAPACKE_lsame( side, 'R' ) ? MAX(1,m) * MAX(1,nb) : 0 ); + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dtprfb.c b/lapack-netlib/LAPACKE/src/lapacke_dtprfb.c index f674639792..7c4ce924d0 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dtprfb.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dtprfb.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function dtprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,6 +39,7 @@ lapack_int LAPACKE_dtprfb( int matrix_layout, char side, char trans, char direct lapack_int ldv, const double* t, lapack_int ldt, double* a, lapack_int lda, double* b, lapack_int ldb ) { + lapack_int ncols_v, nrows_v; lapack_int info = 0; lapack_int ldwork; lapack_int work_size; @@ -49,16 +50,28 @@ lapack_int LAPACKE_dtprfb( int matrix_layout, char side, char trans, char direct } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + if( LAPACKE_lsame( storev, 'C' ) ) { + ncols_v = k; + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + } else if( LAPACKE_lsame( storev, 'R' ) ) { + ncols_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + nrows_v = k; + } else { + ncols_v = 0; + nrows_v = 0; + } if( LAPACKE_dge_nancheck( matrix_layout, k, m, a, lda ) ) { return -14; } if( LAPACKE_dge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -16; } - if( LAPACKE_dge_nancheck( matrix_layout, ldt, k, t, ldt ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, k, k, t, ldt ) ) { return -12; } - if( LAPACKE_dge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, nrows_v, ncols_v, v, ldv ) ) { return -10; } #endif @@ -69,10 +82,10 @@ lapack_int LAPACKE_dtprfb( int matrix_layout, char side, char trans, char direct else { ldwork = m; work_size = MAX(1,ldwork) * MAX(1,k); - } + } /* Allocate memory for working array(s) */ work = (double*) - LAPACKE_malloc( sizeof(double) * work_size ); + LAPACKE_malloc( sizeof(double) * work_size ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_dtprfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_dtprfb_work.c index 0f059a4b08..2c3d64af1f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dtprfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dtprfb_work.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native middle-level C interface to LAPACK function dtprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,7 +39,7 @@ lapack_int LAPACKE_dtprfb_work( int matrix_layout, char side, char trans, const double* v, lapack_int ldv, const double* t, lapack_int ldt, double* a, lapack_int lda, double* b, lapack_int ldb, - const double* work, lapack_int ldwork ) + double* work, lapack_int ldwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_dtrexc_work.c b/lapack-netlib/LAPACKE/src/lapacke_dtrexc_work.c index 0c302b2ba8..9b68fb5f65 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_dtrexc_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_dtrexc_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dtrexc * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -51,7 +51,7 @@ lapack_int LAPACKE_dtrexc_work( int matrix_layout, char compq, lapack_int n, double* t_t = NULL; double* q_t = NULL; /* Check leading dimension(s) */ - if( ldq < n ) { + if( ldq < n && LAPACKE_lsame( compq, 'v' ) ) { info = -7; LAPACKE_xerbla( "LAPACKE_dtrexc_work", info ); return info; diff --git a/lapack-netlib/LAPACKE/src/lapacke_ilaver.c b/lapack-netlib/LAPACKE/src/lapacke_ilaver.c index bec1d900b1..86e6e490fa 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ilaver.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ilaver.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dgesv * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" -void LAPACKE_ilaver( const lapack_int* vers_major, - const lapack_int* vers_minor, - const lapack_int* vers_patch ) +void LAPACKE_ilaver( lapack_int* vers_major, + lapack_int* vers_minor, + lapack_int* vers_patch ) { /* Call LAPACK function */ LAPACK_ilaver( vers_major, vers_minor, vers_patch ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx.c b/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx.c index 2d773ba9d0..127417fc41 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx.c @@ -28,20 +28,20 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sbdsvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_sbdsvdx( int matrix_layout, char uplo, char jobz, char range, lapack_int n, float* d, float* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* z, lapack_int ldz, lapack_int* superb ) { lapack_int info = 0; - lapack_int lwork = 14*n; + lapack_int lwork = MAX(14*n,1); float* work = NULL; lapack_int* iwork = NULL; lapack_int i; @@ -54,7 +54,7 @@ lapack_int LAPACKE_sbdsvdx( int matrix_layout, char uplo, char jobz, char range, if( LAPACKE_s_nancheck( n, d, 1 ) ) { return -6; } - if( LAPACKE_s_nancheck( n, e, 1 ) ) { + if( LAPACKE_s_nancheck( n - 1, e, 1 ) ) { return -7; } #endif @@ -64,14 +64,14 @@ lapack_int LAPACKE_sbdsvdx( int matrix_layout, char uplo, char jobz, char range, info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(12*n,1) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } /* Call middle-level interface */ info = LAPACKE_sbdsvdx_work( matrix_layout, uplo, jobz, range, - n, d, e, vl, vu, il, iu, ns, s, z, + n, d, e, vl, vu, il, iu, ns, s, z, ldz, work, iwork); /* Backup significant data from working array(s) */ for( i=0; i<12*n-1; i++ ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx_work.c index 4f281ef544..f632b3ea98 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sbdsvdx_work.c @@ -28,41 +28,43 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sbdsvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_sbdsvdx_work( int matrix_layout, char uplo, char jobz, char range, lapack_int n, float* d, float* e, - lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, - float* s, float* z, lapack_int ldz, + float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, + float* s, float* z, lapack_int ldz, float* work, lapack_int* iwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_sbdsvdx( &uplo, &jobz, &range, &n, d, e, &vl, &vu, - &il, &iu, &ns, s, z, &ldz, + &il, &iu, ns, s, z, &ldz, work, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? MAX(2, 2*n) : 1; + lapack_int nrows_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? 2*n : 0; + lapack_int ncols_z = ( LAPACKE_lsame( jobz, 'v' ) ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(0,iu - il + 1) : n + 1 ) : 0; lapack_int ldz_t = MAX(1,nrows_z); float* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < nrows_z ) { + if( ldz < ncols_z ) { info = -3; LAPACKE_xerbla( "LAPACKE_sbdsvdx_work", info ); return info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( jobz, 'n' ) ) { + if( LAPACKE_lsame( jobz, 'v' ) ) { z_t = (float*) - LAPACKE_malloc( sizeof(float) * ldz_t * 2*n ); + LAPACKE_malloc( sizeof(float) * ldz_t * MAX(2*n,1) ); if( z_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -70,17 +72,17 @@ lapack_int LAPACKE_sbdsvdx_work( int matrix_layout, char uplo, char jobz, char r } /* Call LAPACK function and adjust info */ LAPACK_sbdsvdx( &uplo, &jobz, &range, &n, d, e, &vl, &vu, - &il, &iu, &ns, s, z_t, &ldz_t, work, + &il, &iu, ns, s, z_t, &ldz_t, work, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ - if( LAPACKE_lsame( jobz, 'n' ) ) { - LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_z, nrows_z, z_t, ldz_t, z, ldz); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_z, ncols_z, z_t, ldz_t, z, ldz); } /* Release memory and exit */ - if( LAPACKE_lsame( jobz, 'n' ) ) { + if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_free( z_t ); } exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgejsv.c b/lapack-netlib/LAPACKE/src/lapacke_sgejsv.c index 7af9901837..2dc52090c7 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgejsv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgejsv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -70,7 +70,7 @@ lapack_int LAPACKE_sgejsv( int matrix_layout, char joba, char jobu, char jobv, ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && LAPACKE_lsame( jobv, 'j' ) ? MAX(7,m+3*n+n*n) : - 1) ) ) ) ) ); + 7) ) ) ) ) ); lapack_int* iwork = NULL; float* work = NULL; lapack_int i; @@ -86,25 +86,25 @@ lapack_int LAPACKE_sgejsv( int matrix_layout, char joba, char jobu, char jobv, if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { return -10; } - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - if( LAPACKE_sge_nancheck( matrix_layout, nu, n, u, ldu ) ) { - return -13; - } - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - if( LAPACKE_sge_nancheck( matrix_layout, nv, n, v, ldv ) ) { - return -15; - } - } #endif /* Allocate memory for working array(s) */ - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,m+3*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(3,m+3*n) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } + lwork = MAX3( lwork, 7, 2*m+n ); + { /* FIXUP LWORK */ + int want_u = LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ); + int want_v = LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ); + int want_sce = LAPACKE_lsame( joba, 'e' ) || LAPACKE_lsame( joba, 'g' ); + if( !want_u && !want_v && !want_sce ) lwork = MAX( lwork, 4*n+1 ); // 1.1 + if( !want_u && !want_v && want_sce ) lwork = MAX( lwork, n*n+4*n ); // 1.2 + if( !want_u && want_v ) lwork = MAX( lwork, 4*n+1 ); // 2 + if( want_u && !want_v ) lwork = MAX( lwork, 4*n+1 ); // 3 + if( want_u && LAPACKE_lsame( jobv, 'v' ) ) lwork = MAX( lwork, 6*n+2*n*n ); // 4.1 + if( want_u && LAPACKE_lsame( jobv, 'j' ) ) lwork = MAX3( lwork, 4*n+n*n, 2*n+n*n+6 ); // 4.2 + } work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgejsv_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgejsv_work.c index fe2fa8fb07..559256276b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgejsv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgejsv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -53,6 +53,8 @@ lapack_int LAPACKE_sgejsv_work( int matrix_layout, char joba, char jobu, } else if( matrix_layout == LAPACK_ROW_MAJOR ) { lapack_int nu = LAPACKE_lsame( jobu, 'n' ) ? 1 : m; lapack_int nv = LAPACKE_lsame( jobv, 'n' ) ? 1 : n; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'n' ) ? 1 : + LAPACKE_lsame( jobu, 'f' ) ? m : n; lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nu); lapack_int ldv_t = MAX(1,nv); @@ -65,7 +67,7 @@ lapack_int LAPACKE_sgejsv_work( int matrix_layout, char joba, char jobu, LAPACKE_xerbla( "LAPACKE_sgejsv_work", info ); return info; } - if( ldu < n ) { + if( ldu < ncols_u ) { info = -14; LAPACKE_xerbla( "LAPACKE_sgejsv_work", info ); return info; @@ -83,7 +85,7 @@ lapack_int LAPACKE_sgejsv_work( int matrix_layout, char joba, char jobu, } if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - u_t = (float*)LAPACKE_malloc( sizeof(float) * ldu_t * MAX(1,n) ); + u_t = (float*)LAPACKE_malloc( sizeof(float) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_1; @@ -99,14 +101,6 @@ lapack_int LAPACKE_sgejsv_work( int matrix_layout, char joba, char jobu, } /* Transpose input matrices */ LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_sge_trans( matrix_layout, nu, n, u, ldu, u_t, ldu_t ); - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - LAPACKE_sge_trans( matrix_layout, nv, n, v, ldv, v_t, ldv_t ); - } /* Call LAPACK function and adjust info */ LAPACK_sgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a_t, &lda_t, sva, u_t, &ldu_t, v_t, &ldv_t, work, &lwork, @@ -117,7 +111,7 @@ lapack_int LAPACKE_sgejsv_work( int matrix_layout, char joba, char jobu, /* Transpose output matrices */ if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_sge_trans( LAPACK_COL_MAJOR, nu, n, u_t, ldu_t, u, ldu ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, nu, ncols_u, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'w' ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgelq.c b/lapack-netlib/LAPACKE/src/lapacke_sgelq.c new file mode 100644 index 0000000000..3fb1d9f85d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgelq.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgelq_work( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgelq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgelq_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_sgelq_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgelq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgelq_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgelq_work.c new file mode 100644 index 0000000000..5770acd472 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgelq_work.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgelq_work( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgelq( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_sgelq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_sgelq( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgelq( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgelq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgelq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgemlq.c b/lapack-netlib/LAPACKE/src/lapacke_sgemlq.c new file mode 100644 index 0000000000..1ed3f04854 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgemlq.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgemlq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgemlq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, k, m, a, lda ) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_d_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_sgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgemlq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgemlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgemlq_work.c new file mode 100644 index 0000000000..9931ec1337 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgemlq_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgemlq +* Author: Intel Corporation +* Generated June 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + float *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgemlq( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, + c, &ldc, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,k); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < r ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_sgemlq_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_sgemlq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sgemlq( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,m) ); + } else { + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + } + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (float*)LAPACKE_malloc( sizeof(float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgemlq( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgemlq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgemlq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgemqr.c b/lapack-netlib/LAPACKE/src/lapacke_sgemqr.c new file mode 100644 index 0000000000..4619d927a3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgemqr.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + lapack_int r; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgemqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_sge_nancheck( matrix_layout, r, k, a, lda ) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_s_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_sgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgemqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgemqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgemqr_work.c new file mode 100644 index 0000000000..d41b500c0f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgemqr_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const float* a, lapack_int lda, + const float* t, lapack_int tsize, + float* c, lapack_int ldc, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + float *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgemqr( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, c, &ldc, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,r); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < k ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_sgemqr_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_sgemqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sgemqr( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*) + LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,k) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (float*) + LAPACKE_malloc( sizeof(float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, r, k, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgemqr( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgemqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgemqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgemqrt.c b/lapack-netlib/LAPACKE/src/lapacke_sgemqrt.c index 93d4fcafb0..1fa1c82d0e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgemqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgemqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function sgemqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,6 +39,7 @@ lapack_int LAPACKE_sgemqrt( int matrix_layout, char side, char trans, const float* t, lapack_int ldt, float* c, lapack_int ldc ) { + lapack_int nrows_v; lapack_int info = 0; float* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -47,13 +48,15 @@ lapack_int LAPACKE_sgemqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) { return -12; } - if( LAPACKE_sge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -10; } - if( LAPACKE_sge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -8; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgeqr.c b/lapack-netlib/LAPACKE/src/lapacke_sgeqr.c new file mode 100644 index 0000000000..60323f53c9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgeqr.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgeqr( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgeqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgeqr_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_sgeqr_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgeqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgeqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgeqr_work.c new file mode 100644 index 0000000000..21c222a955 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgeqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + float* a, lapack_int lda, + float* t, lapack_int tsize, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgeqr( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_sgeqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_sgeqr( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*) + LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgeqr( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgeqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgeqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgesvdx.c b/lapack-netlib/LAPACKE/src/lapacke_sgesvdx.c index c5d727a9e8..6387451afe 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgesvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgesvdx.c @@ -28,15 +28,15 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_sgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* u, lapack_int ldu, float* vt, lapack_int ldvt, lapack_int* superb ) @@ -71,7 +71,7 @@ lapack_int LAPACKE_sgesvdx( int matrix_layout, char jobu, char jobvt, char range info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*MIN(m,n)) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,(12*MIN(m,n))) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgesvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgesvdx_work.c index edab2d1642..f7973f016b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgesvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgesvdx_work.c @@ -28,38 +28,40 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, float* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, lapack_int* ns, float* s, float* u, lapack_int ldu, - float* vt, lapack_int ldvt, + float* vt, lapack_int ldvt, float* work, lapack_int lwork, lapack_int* iwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_sgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda, &vl, &vu, - &il, &iu, &ns, s, u, &ldu, vt, &ldvt, + &il, &iu, ns, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_u = ( LAPACKE_lsame( jobu, 'a' ) || - LAPACKE_lsame( jobu, 's' ) ) ? m : 1; - lapack_int ncols_u = LAPACKE_lsame( jobu, 'a' ) ? m : - ( LAPACKE_lsame( jobu, 's' ) ? MIN(m,n) : 1); - lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'a' ) ? n : - ( LAPACKE_lsame( jobvt, 's' ) ? MIN(m,n) : 1); + lapack_int nrows_u = LAPACKE_lsame( jobu, 'v' ) ? m : 0; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int ncols_vt = LAPACKE_lsame( jobvt, 'v' ) ? n : 0; + lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nrows_u); lapack_int ldvt_t = MAX(1,nrows_vt); + float* a_t = NULL; float* u_t = NULL; float* vt_t = NULL; @@ -74,7 +76,7 @@ lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char LAPACKE_xerbla( "LAPACKE_sgesvdx_work", info ); return info; } - if( ldvt < n ) { + if( ldvt < ncols_vt ) { info = -18; LAPACKE_xerbla( "LAPACKE_sgesvdx_work", info ); return info; @@ -82,7 +84,7 @@ lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_sgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + &il, &iu, ns, s, u, &ldu_t, vt, &ldvt_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -92,7 +94,7 @@ lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { u_t = (float*) LAPACKE_malloc( sizeof(float) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { @@ -100,7 +102,7 @@ lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char goto exit_level_1; } } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { vt_t = (float*) LAPACKE_malloc( sizeof(float) * ldvt_t * MAX(1,n) ); if( vt_t == NULL ) { @@ -111,28 +113,28 @@ lapack_int LAPACKE_sgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Transpose input matrices */ LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_sgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + LAPACK_sgesvdx( &jobu, &jobvt, &range, &m, &n, a_t, &lda_t, &vl, &vu, + &il, &iu, ns, s, u_t, &ldu_t, vt_t, &ldvt_t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_u, ncols_u, u_t, ldu_t, u, ldu ); } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_vt, n, vt_t, ldvt_t, vt, ldvt ); } /* Release memory and exit */ - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_free( vt_t ); } exit_level_2: - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_free( u_t ); } exit_level_1: diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgesvj.c b/lapack-netlib/LAPACKE/src/lapacke_sgesvj.c index 25e438305f..c49c5412c4 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgesvj.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgesvj.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sgesvj * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -49,8 +49,8 @@ lapack_int LAPACKE_sgesvj( int matrix_layout, char joba, char jobu, char jobv, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0 ); if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { return -7; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgesvj_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgesvj_work.c index 74bdeea354..add5e60da4 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sgesvj_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sgesvj_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sgesvj * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -48,8 +48,8 @@ lapack_int LAPACKE_sgesvj_work( int matrix_layout, char joba, char jobu, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); lapack_int lda_t = MAX(1,m); lapack_int ldv_t = MAX(1,nrows_v); float* a_t = NULL; diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgetsls.c b/lapack-netlib/LAPACKE/src/lapacke_sgetsls.c new file mode 100644 index 0000000000..1a1d8f3a87 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgetsls.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, float* a, + lapack_int lda, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgetsls", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -6; + } + if( LAPACKE_sge_nancheck( matrix_layout, MAX(m,n), nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_sgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgetsls", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgetsls_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgetsls_work.c new file mode 100644 index 0000000000..6f36379ca3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgetsls_work.c @@ -0,0 +1,108 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgetsls( &trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,MAX(m,n)); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_sgetsls_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_sgetsls_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sgetsls( &trans, &m, &n, &nrhs, a, &lda_t, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, MAX(m,n), nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgetsls( &trans, &m, &n, &nrhs, a_t, &lda_t, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, MAX(m,n), nrhs, b_t, ldb_t, b, + ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgetsls_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgetsls_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sggsvd3_work.c b/lapack-netlib/LAPACKE/src/lapacke_sggsvd3_work.c index 617ecf2a10..8964773d4b 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sggsvd3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sggsvd3_work.c @@ -91,9 +91,9 @@ lapack_int LAPACKE_sggsvd3_work( int matrix_layout, char jobu, char jobv, } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_sggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a_t, &lda_t, - b_t, &ldb_t, alpha, beta, u_t, &ldu_t, v_t, &ldv_t, - q_t, &ldq_t, work, &lwork, iwork, &info ); + LAPACK_sggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a, &lda_t, + b, &ldb_t, alpha, beta, u, &ldu_t, v, &ldv_t, + q, &ldq_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_sggsvp3_work.c b/lapack-netlib/LAPACKE/src/lapacke_sggsvp3_work.c index ec200ca8ff..905b82447e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sggsvp3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sggsvp3_work.c @@ -84,16 +84,16 @@ lapack_int LAPACKE_sggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_xerbla( "LAPACKE_sggsvp3_work", info ); return info; } - if( ldv < m ) { + if( ldv < p ) { info = -19; LAPACKE_xerbla( "LAPACKE_sggsvp3_work", info ); return info; } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_sggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a_t, &lda_t, b_t, - &ldb_t, &tola, &tolb, k, l, u_t, &ldu_t, - v_t, &ldv_t, q_t, &ldq_t, iwork, tau, work, &lwork, + LAPACK_sggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a, &lda_t, b, + &ldb_t, &tola, &tolb, k, l, u, &ldu_t, + v, &ldv_t, q, &ldq_t, iwork, tau, work, &lwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -116,7 +116,7 @@ lapack_int LAPACKE_sggsvp3_work( int matrix_layout, char jobu, char jobv, } } if( LAPACKE_lsame( jobv, 'v' ) ) { - v_t = (float*)LAPACKE_malloc( sizeof(float) * ldv_t * MAX(1,m) ); + v_t = (float*)LAPACKE_malloc( sizeof(float) * ldv_t * MAX(1,p) ); if( v_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_3; @@ -146,7 +146,7 @@ lapack_int LAPACKE_sggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, m, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'v' ) ) { - LAPACKE_sge_trans( LAPACK_COL_MAJOR, p, m, v_t, ldv_t, v, ldv ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, p, p, v_t, ldv_t, v, ldv ); } if( LAPACKE_lsame( jobq, 'q' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_slantr.c b/lapack-netlib/LAPACKE/src/lapacke_slantr.c index 23b19b15dc..e92dc62ff3 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slantr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slantr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function slantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_slantr_work.c b/lapack-netlib/LAPACKE/src/lapacke_slantr_work.c index 92a0e4017c..e9f84b55c9 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slantr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slantr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function slantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_slarfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_slarfb_work.c index 12b4c7b69a..104bbd5aa2 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slarfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slarfb_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function slarfb * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -43,7 +43,7 @@ lapack_int LAPACKE_slarfb_work( int matrix_layout, char side, char trans, lapack_int info = 0; lapack_int nrows_v, ncols_v; lapack_int ldc_t, ldt_t, ldv_t; - float *v_t = NULL, *t_t = NULL, *c_t = NULL; + float *v_t = NULL, *t_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_slarfb( &side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, @@ -118,7 +118,7 @@ lapack_int LAPACKE_slarfb_work( int matrix_layout, char side, char trans, LAPACKE_sge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv, &v_t[k*ldv_t], ldv_t ); } else if( LAPACKE_lsame( storev, 'r' ) && - LAPACKE_lsame( direct, 'f' ) ) { + LAPACKE_lsame( direct, 'b' ) ) { if( k > ncols_v ) { LAPACKE_xerbla( "LAPACKE_slarfb_work", -8 ); return -8; diff --git a/lapack-netlib/LAPACKE/src/lapacke_slascl.c b/lapack-netlib/LAPACKE/src/lapacke_slascl.c index 0d5bd9559c..b5368e4b8e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slascl.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slascl.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function slaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_slascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, float* a, lapack_int lda ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -46,50 +46,64 @@ lapack_int LAPACKE_slascl( int matrix_layout, char type, lapack_int kl, /* Optionally check input matrices for NaNs */ switch (type) { case 'G': - if( LAPACKE_sge_nancheck( matrix_layout, lda, n, a, lda ) ) { - return -9; - } + if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -9; + } break; case 'L': - // TYPE = 'L' - lower triangular matrix. - if( LAPACKE_str_nancheck( matrix_layout, 'L', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'L' - lower triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_sgb_nancheck( matrix_layout, m, n, m-1, 0, a, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_sgb_nancheck( LAPACK_COL_MAJOR, n, m, 0, m-1, a-m+1, lda+1 ) ) { + return -9; + } break; case 'U': - // TYPE = 'U' - upper triangular matrix - if( LAPACKE_str_nancheck( matrix_layout, 'U', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'U' - upper triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_sgb_nancheck( matrix_layout, m, n, 0, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_sgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 0, a, lda+1 ) ) { + return -9; + } break; case 'H': - // TYPE = 'H' - upper Hessenberg matrix - if( LAPACKE_shs_nancheck( matrix_layout, n, a, lda ) ) { - return -9; - } - break; + // TYPE = 'H' - part of upper Hessenberg matrix in general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_sgb_nancheck( matrix_layout, m, n, 1, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_sgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 1, a-1, lda+1 ) ) { + return -9; + } case 'B': - // TYPE = 'B' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the lower - // half stored. - if( LAPACKE_ssb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { - return -9; - } - break; - case 'Q': - // TYPE = 'Q' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the upper - // half stored. - if( LAPACKE_ssb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { - return -9; - } + // TYPE = 'B' - lower part of symmetric band matrix (assume m==n) + if( LAPACKE_ssb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { + return -9; + } + break; + case 'Q': + // TYPE = 'Q' - upper part of symmetric band matrix (assume m==n) + if( LAPACKE_ssb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { + return -9; + } break; case 'Z': - // TYPE = 'Z' - A is a band matrix with lower bandwidth KL and upper - // bandwidth KU. See DGBTRF for storage details. - if( LAPACKE_sgb_nancheck( matrix_layout, n, n, kl, kl+ku, a, lda ) ) { - return -6; - } + // TYPE = 'Z' - band matrix laid out for ?GBTRF + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_sgb_nancheck( matrix_layout, m, n, kl, ku, a+kl, lda ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_sgb_nancheck( matrix_layout, m, n, kl, ku, a+lda*kl, lda ) ) { + return -9; + } break; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_slascl_work.c b/lapack-netlib/LAPACKE/src/lapacke_slascl_work.c index 4abb59ca7c..dac2a03f21 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slascl_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slascl_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function slaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_slascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, float cfrom, float cto, - lapack_int m, lapack_int n, float* a, + lapack_int ku, float cfrom, float cto, + lapack_int m, lapack_int n, float* a, lapack_int lda ) { lapack_int info = 0; @@ -46,7 +46,10 @@ lapack_int LAPACKE_slascl_work( int matrix_layout, char type, lapack_int kl, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int nrows_a = LAPACKE_lsame(type, 'b') ? kl + 1 : + LAPACKE_lsame(type, 'q') ? ku + 1 : + LAPACKE_lsame(type, 'z') ? 2 * kl + ku + 1 : m; + lapack_int lda_t = MAX(1,nrows_a); float* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -61,12 +64,14 @@ lapack_int LAPACKE_slascl_work( int matrix_layout, char type, lapack_int kl, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_sge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, nrows_a, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_slascl( &type, &kl, &ku, &cfrom, &cto, &m, &n, a_t, &lda_t, &info); - info = 0; /* LAPACK call is ok! */ + if( info < 0 ) { + info = info - 1; + } /* Transpose output matrices */ - LAPACKE_sge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_a, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_slaset.c b/lapack-netlib/LAPACKE/src/lapacke_slaset.c index 02af8724b4..45044ad5f4 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slaset.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slaset.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function slaset * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -44,8 +44,8 @@ lapack_int LAPACKE_slaset( int matrix_layout, char uplo, lapack_int m, } /***************************************************************************** -* Note: we do not check NaNs in A since the goal of this subroutine is to -* initialized A. It is OK if A has NaNs in input. +* Note: we do not check NaNs in A since the goal of this subroutine is to +* initialized A. It is OK if A has NaNs in input. *****************************************************************************/ #ifndef LAPACK_DISABLE_NAN_CHECK diff --git a/lapack-netlib/LAPACKE/src/lapacke_slaswp_work.c b/lapack-netlib/LAPACKE/src/lapacke_slaswp_work.c index 01abf59641..1faadbb96e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_slaswp_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_slaswp_work.c @@ -45,7 +45,11 @@ lapack_int LAPACKE_slaswp_work( int matrix_layout, lapack_int n, float* a, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int lda_t = MAX(1,k2); + lapack_int i; + for( i = k1; i <= k2; i++ ) { + lda_t = MAX( lda_t, ipiv[k1 + ( i - k1 ) * ABS( incx ) - 1] ); + } float* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -60,12 +64,12 @@ lapack_int LAPACKE_slaswp_work( int matrix_layout, lapack_int n, float* a, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_sge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, lda_t, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_slaswp( &n, a_t, &lda_t, &k1, &k2, ipiv, &incx ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_sge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, lda_t, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1.c b/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1.c index b924897db5..d0223859b3 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sorcsd2by1 * Author: Intel Corporation -* Generated November, 2011 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -69,7 +69,7 @@ lapack_int LAPACKE_sorcsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_0; } /* Query optimal working array(s) size */ - info = LAPACKE_sorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_sorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, &work_query, lwork, iwork ); @@ -84,7 +84,7 @@ lapack_int LAPACKE_sorcsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_1; } /* Call middle-level interface */ - info = LAPACKE_sorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_sorcsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, iwork ); /* Release memory and exit */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1_work.c b/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1_work.c index d3d24518b8..d361594c13 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sorcsd2by1_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sorcsd2by1 * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -46,8 +46,8 @@ lapack_int LAPACKE_sorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_sorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11, x21, &ldx21, + theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -97,8 +97,8 @@ lapack_int LAPACKE_sorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_sorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11_t, x21, &ldx21_t, + theta, u1, &ldu1_t, u2, &ldu2_t, v1t, &ldv1t_t, work, &lwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -144,8 +144,8 @@ lapack_int LAPACKE_sorcsd2by1_work( int matrix_layout, char jobu1, char jobu2, ldx21_t ); /* Call LAPACK function and adjust info */ LAPACK_sorcsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11_t, &ldx11_t, x21_t, &ldx21_t, + theta, u1_t, &ldu1_t, u2_t, &ldu2_t, v1t_t, &ldv1t_t, work, &lwork, iwork, &info ); if( info < 0 ) { info = info - 1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_sormbr.c b/lapack-netlib/LAPACKE/src/lapacke_sormbr.c index c27896dcc6..4df425efe4 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sormbr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sormbr.c @@ -42,7 +42,7 @@ lapack_int LAPACKE_sormbr( int matrix_layout, char vect, char side, char trans, lapack_int lwork = -1; float* work = NULL; float work_query; - lapack_int nq, r; + lapack_int nq, ar, ac; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_sormbr", -1 ); return -1; @@ -50,8 +50,9 @@ lapack_int LAPACKE_sormbr( int matrix_layout, char vect, char side, char trans, #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ nq = LAPACKE_lsame( side, 'l' ) ? m : n; - r = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); - if( LAPACKE_sge_nancheck( matrix_layout, r, MIN(nq,k), a, lda ) ) { + ar = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); + ac = LAPACKE_lsame( vect, 'q' ) ? MIN(nq,k) : nq; + if( LAPACKE_sge_nancheck( matrix_layout, ar, ac, a, lda ) ) { return -8; } if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_sormbr_work.c b/lapack-netlib/LAPACKE/src/lapacke_sormbr_work.c index 34bc41f30d..5d0f871b48 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sormbr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sormbr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sormbr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,9 +40,6 @@ lapack_int LAPACKE_sormbr_work( int matrix_layout, char vect, char side, float* work, lapack_int lwork ) { lapack_int info = 0; - lapack_int nq, r; - lapack_int lda_t, ldc_t; - float *a_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_sormbr( &vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, @@ -51,12 +48,15 @@ lapack_int LAPACKE_sormbr_work( int matrix_layout, char vect, char side, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - nq = LAPACKE_lsame( side, 'l' ) ? m : n; - r = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); - lda_t = MAX(1,r); - ldc_t = MAX(1,m); + lapack_int nq = LAPACKE_lsame( side, 'l' ) ? m : n; + lapack_int ar = LAPACKE_lsame( vect, 'q' ) ? nq : MIN(nq,k); + lapack_int ac = LAPACKE_lsame( vect, 'q' ) ? MIN(nq,k) : nq; + lapack_int lda_t = MAX(1,ar); + lapack_int ldc_t = MAX(1,m); + float *a_t = NULL; + float *c_t = NULL; /* Check leading dimension(s) */ - if( lda < MIN(nq,k) ) { + if( lda < ac ) { info = -9; LAPACKE_xerbla( "LAPACKE_sormbr_work", info ); return info; @@ -73,11 +73,7 @@ lapack_int LAPACKE_sormbr_work( int matrix_layout, char vect, char side, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( vect, 'q' ) ) { - a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,k) ); - } else { - a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,nq) ); - } + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,ac) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -88,7 +84,7 @@ lapack_int LAPACKE_sormbr_work( int matrix_layout, char vect, char side, goto exit_level_1; } /* Transpose input matrices */ - LAPACKE_sge_trans( matrix_layout, r, MIN(nq,k), a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, ar, ac, a, lda, a_t, lda_t ); LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); /* Call LAPACK function and adjust info */ LAPACK_sormbr( &vect, &side, &trans, &m, &n, &k, a_t, &lda_t, tau, c_t, diff --git a/lapack-netlib/LAPACKE/src/lapacke_sormlq.c b/lapack-netlib/LAPACKE/src/lapacke_sormlq.c index 25b522b6a5..c05fdb1e51 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sormlq.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sormlq.c @@ -48,7 +48,8 @@ lapack_int LAPACKE_sormlq( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_sge_nancheck( matrix_layout, k, m, a, lda ) ) { + lapack_int r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_sge_nancheck( matrix_layout, k, r, a, lda ) ) { return -7; } if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_sormlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_sormlq_work.c index b02a2d1008..f2f378587f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sormlq_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sormlq_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function sormlq * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,9 +40,6 @@ lapack_int LAPACKE_sormlq_work( int matrix_layout, char side, char trans, float* work, lapack_int lwork ) { lapack_int info = 0; - lapack_int r; - lapack_int lda_t, ldc_t; - float *a_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_sormlq( &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, @@ -51,9 +48,11 @@ lapack_int LAPACKE_sormlq_work( int matrix_layout, char side, char trans, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - r = LAPACKE_lsame( side, 'l' ) ? m : n; - lda_t = MAX(1,k); - ldc_t = MAX(1,m); + lapack_int r = LAPACKE_lsame( side, 'l' ) ? m : n; + lapack_int lda_t = MAX(1,k); + lapack_int ldc_t = MAX(1,m); + float *a_t = NULL; + float *c_t = NULL; /* Check leading dimension(s) */ if( lda < r ) { info = -8; @@ -72,11 +71,7 @@ lapack_int LAPACKE_sormlq_work( int matrix_layout, char side, char trans, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - if( LAPACKE_lsame( side, 'l' ) ) { - a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,m) ); - } else { - a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); - } + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,r) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; @@ -87,7 +82,7 @@ lapack_int LAPACKE_sormlq_work( int matrix_layout, char side, char trans, goto exit_level_1; } /* Transpose input matrices */ - LAPACKE_sge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, k, r, a, lda, a_t, lda_t ); LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); /* Call LAPACK function and adjust info */ LAPACK_sormlq( &side, &trans, &m, &n, &k, a_t, &lda_t, tau, c_t, &ldc_t, diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage.c new file mode 100644 index 0000000000..3ef3975ead --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, float* ab, lapack_int ldab, float* w, + float* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssbev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage_work.c new file mode 100644 index 0000000000..620fa513f4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbev_2stage_work.c @@ -0,0 +1,113 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssbev_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + float* ab_t = NULL; + float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_ssbev_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_ssbev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (float*)LAPACKE_malloc( sizeof(float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (float*)LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_ssb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssbev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage.c new file mode 100644 index 0000000000..a9f95c7f1c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, float* ab, lapack_int ldab, float* w, + float* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + lapack_int iwork_query; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage_work.c new file mode 100644 index 0000000000..d3f2f71b3f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbevd_2stage_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + float* ab_t = NULL; + float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_ssbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab_t, w, z, &ldz_t, + work, &lwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (float*)LAPACKE_malloc( sizeof(float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (float*)LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_ssb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssbevd_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssbevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage.c new file mode 100644 index 0000000000..27102f1113 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, float* ab, + lapack_int ldab, float* q, lapack_int ldq, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -7; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -15; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -11; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -12; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, &work_query, lwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int) work_query; + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, work, lwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage_work.c new file mode 100644 index 0000000000..2b470956f6 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbevx_2stage_work.c @@ -0,0 +1,146 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + float* ab, lapack_int ldab, float* q, + lapack_int ldq, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, + &vu, &il, &iu, &abstol, m, w, z, &ldz, work, &lwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + float* ab_t = NULL; + float* q_t = NULL; + float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage_work", info ); + return info; + } + if( ldq < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -19; + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (float*)LAPACKE_malloc( sizeof(float) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + q_t = (float*)LAPACKE_malloc( sizeof(float) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (float*) + LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Transpose input matrices */ + LAPACKE_ssb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_2: + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( q_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssbevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssbtrd.c b/lapack-netlib/LAPACKE/src/lapacke_ssbtrd.c index b70a982532..03a3ac9e5a 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssbtrd.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssbtrd.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function ssbtrd * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -48,7 +48,7 @@ lapack_int LAPACKE_ssbtrd( int matrix_layout, char vect, char uplo, lapack_int n if( LAPACKE_ssb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { return -6; } - if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) { + if( LAPACKE_lsame( vect, 'u' ) ) { if( LAPACKE_sge_nancheck( matrix_layout, n, n, q, ldq ) ) { return -10; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_sstedc.c b/lapack-netlib/LAPACKE/src/lapacke_sstedc.c index c4bf76434f..b5b6b49ce2 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_sstedc.c +++ b/lapack-netlib/LAPACKE/src/lapacke_sstedc.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function sstedc * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -55,7 +55,7 @@ lapack_int LAPACKE_sstedc( int matrix_layout, char compz, lapack_int n, float* d if( LAPACKE_s_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_sge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssteqr.c b/lapack-netlib/LAPACKE/src/lapacke_ssteqr.c index 1a5a673944..fc7ea29b8d 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssteqr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssteqr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function ssteqr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -52,7 +52,7 @@ lapack_int LAPACKE_ssteqr( int matrix_layout, char compz, lapack_int n, float* d if( LAPACKE_s_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_sge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssycon_3.c b/lapack-netlib/LAPACKE/src/lapacke_ssycon_3.c new file mode 100644 index 0000000000..ece1482eba --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssycon_3.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssycon_3( int matrix_layout, char uplo, lapack_int n, + const float* a, lapack_int lda, const float* e, + const lapack_int* ipiv, float anorm, float* rcond ) +{ + lapack_int info = 0; + lapack_int* iwork = NULL; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssycon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_s_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssycon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work, iwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssycon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssycon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssycon_3_work.c new file mode 100644 index 0000000000..7f76acaec6 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssycon_3_work.c @@ -0,0 +1,83 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssycon_3_work( int matrix_layout, char uplo, lapack_int n, + const float* a, lapack_int lda, + const float* e, const lapack_int* ipiv, float anorm, + float* rcond, float* work, lapack_int* iwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssycon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, iwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_ssycon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssycon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, iwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssycon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssycon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyconv.c b/lapack-netlib/LAPACKE/src/lapacke_ssyconv.c index 83ae6ff51c..c22b1e4478 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssyconv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyconv.c @@ -28,32 +28,24 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function ssyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_ssyconv( int matrix_layout, char uplo, char way, lapack_int n, - float* a, lapack_int lda, const lapack_int* ipiv, float* work ) + float* a, lapack_int lda, const lapack_int* ipiv, float* e ) { - lapack_int info = 0; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_ssyconv", -1 ); return -1; } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_sge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { return -5; } #endif - /* Call middle-level interface */ - info = LAPACKE_ssyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, - work ); -exit_level_0: - if( info == LAPACK_WORK_MEMORY_ERROR ) { - LAPACKE_xerbla( "LAPACKE_ssyconv", info ); - } - return info; + return LAPACKE_ssyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, e ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyconv_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyconv_work.c index 117c0952ca..2ffaf8deed 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssyconv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyconv_work.c @@ -28,19 +28,19 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function ssyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_ssyconv_work( int matrix_layout, char uplo, char way, lapack_int n, float* a, lapack_int lda, - const lapack_int* ipiv, float* work ) + const lapack_int* ipiv, float* e ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_ssyconv( &uplo, &way, &n, a, &lda, ipiv, work, &info ); + LAPACK_ssyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } @@ -62,7 +62,7 @@ lapack_int LAPACKE_ssyconv_work( int matrix_layout, char uplo, char way, /* Transpose input matrices */ LAPACKE_sge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_ssyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, work, &info ); + LAPACK_ssyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage.c new file mode 100644 index 0000000000..d031cea532 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssyev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssyev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssyev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssyev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage_work.c new file mode 100644 index 0000000000..277e66669a --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyev_2stage_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssyev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, float* w, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssyev_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssyev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssyev_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssyev_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssyev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage.c new file mode 100644 index 0000000000..12db2274e4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssyevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + lapack_int iwork_query; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssyevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssyevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssyevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage_work.c new file mode 100644 index 0000000000..5942a9abb8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevd_2stage_work.c @@ -0,0 +1,91 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssyevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, + float* w, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssyevd_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssyevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_ssyevd_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, iwork, + &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssyevd_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssyevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage.c new file mode 100644 index 0000000000..40a93b26ae --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage.c @@ -0,0 +1,105 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssyevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, float* a, lapack_int lda, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* isuppz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + lapack_int iwork_query; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssyevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssyevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, work, + lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage_work.c new file mode 100644 index 0000000000..ec6b5ca7a9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevr_2stage_work.c @@ -0,0 +1,124 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssyevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, float* a, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, lapack_int* isuppz, float* work, + lapack_int lwork, lapack_int* iwork, + lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssyevr_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, isuppz, work, &lwork, iwork, + &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + float* a_t = NULL; + float* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lwork == -1 ) { + LAPACK_ssyevr_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, isuppz, work, &lwork, + iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (float*) + LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssyevr_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, isuppz, work, &lwork, + iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssyevr_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage.c new file mode 100644 index 0000000000..7527f348dc --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssyevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, float* a, lapack_int lda, float vl, + float vu, lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, lapack_int ldz, + lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_s_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_s_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_ssyevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, &work_query, + lwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_ssyevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, work, lwork, + iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage_work.c new file mode 100644 index 0000000000..8529a83a2b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyevx_2stage_work.c @@ -0,0 +1,123 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssyevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssyevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, float* a, + lapack_int lda, float vl, float vu, + lapack_int il, lapack_int iu, float abstol, + lapack_int* m, float* w, float* z, + lapack_int ldz, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssyevx_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, work, &lwork, iwork, ifail, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + float* a_t = NULL; + float* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssyevx_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, work, &lwork, iwork, + ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (float*) + LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssyevx_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, work, &lwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssyevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage.c new file mode 100644 index 0000000000..5ca1bb76a3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssygv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssygv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssygv_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -6; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssygv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssygv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssygv_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage_work.c new file mode 100644 index 0000000000..802cd4d205 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssygv_2stage_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssygv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssygv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* w, float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssygv_2stage( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_ssygv_2stage_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_ssygv_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssygv_2stage( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssygv_2stage( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssygv_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssygv_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssygvx_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssygvx_work.c index 814eea30e0..9bc87810b6 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssygvx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssygvx_work.c @@ -105,7 +105,7 @@ lapack_int LAPACKE_ssygvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose input matrices */ LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); - LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + LAPACKE_ssy_trans( matrix_layout, uplo, n, b, ldb, b_t, ldb_t ); /* Call LAPACK function and adjust info */ LAPACK_ssygvx( &itype, &jobz, &range, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, @@ -115,7 +115,7 @@ lapack_int LAPACKE_ssygvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose output matrices */ LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); - LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, b_t, ldb_t, b, ldb ); if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, ldz ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa.c new file mode 100644 index 0000000000..0f10c82943 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa_work.c new file mode 100644 index 0000000000..c4db610bbd --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssysv_aa_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssysv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_ssysv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssysv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssysv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk.c new file mode 100644 index 0000000000..b352028447 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk.c @@ -0,0 +1,83 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + float* e, lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_s_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk_work.c new file mode 100644 index 0000000000..a6180501d4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssysv_rk_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + float* e, lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssysv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_ssysv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssysv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssysv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyswapr.c b/lapack-netlib/LAPACKE/src/lapacke_ssyswapr.c index c207edf21e..43a5a3e0c0 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssyswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyswapr.c @@ -28,13 +28,13 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function ssyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_ssyswapr( int matrix_layout, char uplo, lapack_int n, - float* a, lapack_int i1, lapack_int i2 ) + float* a, lapack_int lda, lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_ssyswapr", -1 ); @@ -42,9 +42,9 @@ lapack_int LAPACKE_ssyswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_ssyswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_ssyswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssyswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssyswapr_work.c index e138158834..b376abd65e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssyswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssyswapr_work.c @@ -28,36 +28,38 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function ssyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_ssyswapr_work( int matrix_layout, char uplo, lapack_int n, - float* a, lapack_int i1, lapack_int i2 ) + float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_ssyswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_ssyswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); float* a_t = NULL; /* Allocate memory for temporary array(s) */ - a_t = (float*)LAPACKE_malloc( sizeof(float) * n * MAX(1,n) ); + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_ssy_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_ssyswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_ssyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa.c new file mode 100644 index 0000000000..31056df4be --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrf_aa( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa_work.c new file mode 100644 index 0000000000..d68cb17c18 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_aa_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int* ipiv, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_ssytrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssytrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk.c new file mode 100644 index 0000000000..806631845c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrf_rk( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, float* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_s_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk_work.c new file mode 100644 index 0000000000..930baa765a --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrf_rk_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, float* e, lapack_int* ipiv, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssytrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_ssytrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssytrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssytrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssytrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytri2.c b/lapack-netlib/LAPACKE/src/lapacke_ssytri2.c index c817a8b8a7..eb348b1124 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssytri2.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytri2.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function ssytri2 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -38,8 +38,8 @@ lapack_int LAPACKE_ssytri2( int matrix_layout, char uplo, lapack_int n, float* a { lapack_int info = 0; lapack_int lwork = -1; - lapack_complex_float* work = NULL; - lapack_complex_float work_query; + float* work = NULL; + float work_query; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_ssytri2", -1 ); return -1; @@ -58,8 +58,8 @@ lapack_int LAPACKE_ssytri2( int matrix_layout, char uplo, lapack_int n, float* a } lwork = LAPACK_C2INT( work_query ); /* Allocate memory for work arrays */ - work = (lapack_complex_float*) - LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + work = (float*) + LAPACKE_malloc( sizeof(float) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytri2_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytri2_work.c index 10841945f3..8a9c72951e 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ssytri2_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytri2_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function ssytri2 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,7 +36,7 @@ lapack_int LAPACKE_ssytri2_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_float* work, lapack_int lwork ) + float* work, lapack_int lwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytri_3.c b/lapack-netlib/LAPACKE/src/lapacke_ssytri_3.c new file mode 100644 index 0000000000..b97ca49830 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytri_3.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytri_3( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const float* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssytri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_s_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytri_3_work.c new file mode 100644 index 0000000000..ee7cc4bce3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytri_3_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytri_3_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, const float* e, + const lapack_int* ipiv, float* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssytri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_ssytri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssytri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3.c new file mode 100644 index 0000000000..1bcefd4dc6 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3.c @@ -0,0 +1,59 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const float* e, + const lapack_int* ipiv, float* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssytrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_s_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_ssytrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3_work.c new file mode 100644 index 0000000000..db09e97f9c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_3_work.c @@ -0,0 +1,99 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const float* e, const lapack_int* ipiv, float* b, + lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssytrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssytrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_ssytrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssytrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssytrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa.c new file mode 100644 index 0000000000..6e384095b3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssytrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*) + LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa_work.c new file mode 100644 index 0000000000..f478880321 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_ssytrs_aa_work.c @@ -0,0 +1,99 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, + lapack_int lda, const lapack_int* ipiv, + float* b, lapack_int ldb, float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssytrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssytrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_ssytrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssytrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssytrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssytrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_stpmqrt.c b/lapack-netlib/LAPACKE/src/lapacke_stpmqrt.c index 43c266a91c..f7d65aca83 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_stpmqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_stpmqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function stpmqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,6 +39,9 @@ lapack_int LAPACKE_stpmqrt( int matrix_layout, char side, char trans, lapack_int ldv, const float* t, lapack_int ldt, float* a, lapack_int lda, float* b, lapack_int ldb ) { + lapack_int ncols_a, nrows_a; + lapack_int nrows_v; + lapack_int lwork; lapack_int info = 0; float* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -47,21 +50,29 @@ lapack_int LAPACKE_stpmqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_sge_nancheck( matrix_layout, k, m, a, lda ) ) { + ncols_a = LAPACKE_lsame( side, 'L' ) ? n : + ( LAPACKE_lsame( side, 'R' ) ? k : 0 ); + nrows_a = LAPACKE_lsame( side, 'L' ) ? k : + ( LAPACKE_lsame( side, 'R' ) ? m : 0 ); + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + if( LAPACKE_sge_nancheck( matrix_layout, nrows_a, ncols_a, a, lda ) ) { return -13; } if( LAPACKE_sge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -15; } - if( LAPACKE_sge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -11; } - if( LAPACKE_sge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -9; } #endif /* Allocate memory for working array(s) */ - work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,m) * MAX(1,nb) ); + lwork = LAPACKE_lsame( side, 'L' ) ? MAX(1,nb) * MAX(1,n) : + ( LAPACKE_lsame( side, 'R' ) ? MAX(1,m) * MAX(1,nb) : 0 ); + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_stprfb.c b/lapack-netlib/LAPACKE/src/lapacke_stprfb.c index 217a91f4d5..13d0cc7e72 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_stprfb.c +++ b/lapack-netlib/LAPACKE/src/lapacke_stprfb.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function stprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -39,6 +39,7 @@ lapack_int LAPACKE_stprfb( int matrix_layout, char side, char trans, char direct lapack_int ldv, const float* t, lapack_int ldt, float* a, lapack_int lda, float* b, lapack_int ldb) { + lapack_int ncols_v, nrows_v; lapack_int info = 0; lapack_int ldwork; lapack_int work_size; @@ -49,16 +50,28 @@ lapack_int LAPACKE_stprfb( int matrix_layout, char side, char trans, char direct } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + if( LAPACKE_lsame( storev, 'C' ) ) { + ncols_v = k; + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + } else if( LAPACKE_lsame( storev, 'R' ) ) { + ncols_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + nrows_v = k; + } else { + ncols_v = 0; + nrows_v = 0; + } if( LAPACKE_sge_nancheck( matrix_layout, k, m, a, lda ) ) { return -14; } if( LAPACKE_sge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -16; } - if( LAPACKE_sge_nancheck( matrix_layout, ldt, k, t, ldt ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, k, k, t, ldt ) ) { return -12; } - if( LAPACKE_sge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, nrows_v, ncols_v, v, ldv ) ) { return -10; } #endif @@ -69,7 +82,7 @@ lapack_int LAPACKE_stprfb( int matrix_layout, char side, char trans, char direct else { ldwork = m; work_size = MAX(1,ldwork) * MAX(1,k); - } + } /* Allocate memory for working array(s) */ work = (float*) LAPACKE_malloc( sizeof(float) * work_size ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_stprfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_stprfb_work.c index f39586b2c3..dd1d9c2ba1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_stprfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_stprfb_work.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native middle-level C interface to LAPACK function stprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -38,7 +38,7 @@ lapack_int LAPACKE_stprfb_work( int matrix_layout, char side, char trans, lapack_int n, lapack_int k, lapack_int l, const float* v, lapack_int ldv, const float* t, lapack_int ldt, float* a, lapack_int lda, - float* b, lapack_int ldb, const float* work, + float* b, lapack_int ldb, float* work, lapack_int ldwork ) { lapack_int info = 0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_strexc_work.c b/lapack-netlib/LAPACKE/src/lapacke_strexc_work.c index 571cfbc747..40a6c5d050 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_strexc_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_strexc_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function strexc * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -51,7 +51,7 @@ lapack_int LAPACKE_strexc_work( int matrix_layout, char compq, lapack_int n, float* t_t = NULL; float* q_t = NULL; /* Check leading dimension(s) */ - if( ldq < n ) { + if( ldq < n && LAPACKE_lsame( compq, 'v' ) ) { info = -7; LAPACKE_xerbla( "LAPACKE_strexc_work", info ); return info; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgejsv.c b/lapack-netlib/LAPACKE/src/lapacke_zgejsv.c index 7a938866ca..6eababe56a 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgejsv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgejsv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zgejsv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,10 +41,10 @@ lapack_int LAPACKE_zgejsv( int matrix_layout, char joba, char jobu, char jobv, { lapack_int info = 0; lapack_int lwork = ( - // 1.1 + // 1.1 ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? 2*n+1 : - + //1.2 ( ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? n*n+3*n : @@ -53,38 +53,38 @@ lapack_int LAPACKE_zgejsv( int matrix_layout, char joba, char jobu, char jobv, ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && (!( LAPACKE_lsame( jobu, 'u') || LAPACKE_lsame( jobu, 'f' ) )&& ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - + + //2.2 ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - //3.1 + + //3.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - - //3.2 + + //3.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !(LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && !(LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 3*n : - + //4.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 5*n+2*n*n : - + //4.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && - ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 4*n*n: - 1) ) ) ) ) ) ) ) ); + ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? 4*n*n: + 1) ) ) ) ) ) ) ) ); lapack_int lrwork = ( - // 1.1 + // 1.1 ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? MAX(7,n+2*m) : - + //1.2 ( ( LAPACKE_lsame( jobu, 'n' ) && LAPACKE_lsame( jobv, 'n' ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) )) ? MAX(7,2*n) : @@ -93,33 +93,33 @@ lapack_int LAPACKE_zgejsv( int matrix_layout, char joba, char jobu, char jobv, ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && (!( LAPACKE_lsame( jobu, 'u') || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - - + + //2.2 ( ( ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && !( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && !( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - - //3.1 + + //3.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - - //3.2 + + //3.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' )) && !(LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' )) && !(LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - + //4.1 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX( 7, n+ 2*m ) : - + //4.2 ( ( ( LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ) ) && ( LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ) ) && ( LAPACKE_lsame( jobt, 't' ) || LAPACKE_lsame( joba, 'f' ) || LAPACKE_lsame( joba, 'g' ) ))? MAX(7,2*n) : - 1) ) ) ) ) ) ) ) ); + 7) ) ) ) ) ) ) ) ); lapack_int* iwork = NULL; double* rwork = NULL; lapack_complex_double* cwork = NULL; @@ -136,30 +136,29 @@ lapack_int LAPACKE_zgejsv( int matrix_layout, char joba, char jobu, char jobv, if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { return -10; } - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - if( LAPACKE_zge_nancheck( matrix_layout, nu, n, u, ldu ) ) { - return -13; - } - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - if( LAPACKE_zge_nancheck( matrix_layout, nv, n, v, ldv ) ) { - return -15; - } - } #endif /* Allocate memory for working array(s) */ - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,m+3*n) ); + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(3,m+2*n) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; } + lwork = MAX( lwork, 1 ); + { /* FIXUP LWORK */ + int want_u = LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'f' ); + int want_v = LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'j' ); + int want_sce = LAPACKE_lsame( joba, 'e' ) || LAPACKE_lsame( joba, 'g' ); + if( !want_u && !want_v && !want_sce ) lwork = MAX( lwork, 2*n+1 ); // 1.1 + if( !want_u && !want_v && want_sce ) lwork = MAX( lwork, n*n+3*n ); // 1.2 + if( want_u && LAPACKE_lsame( jobv, 'v' ) ) lwork = MAX( lwork, 5*n+2*n*n ); // 4.1 + if( want_u && LAPACKE_lsame( jobv, 'j' ) ) lwork = MAX( lwork, 4*n+n*n ); // 4.2 + } cwork = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); if( cwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } + lrwork = MAX3( lrwork, 7, n+2*m ); rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); if( rwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgejsv_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgejsv_work.c index 5d785e9a23..83e0d647d4 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgejsv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgejsv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zgejsv * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -46,7 +46,7 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_zgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, - &lda, sva, u, &ldu, v, &ldv, cwork, &lwork, rwork, &lwork, + &lda, sva, u, &ldu, v, &ldv, cwork, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -54,6 +54,8 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, } else if( matrix_layout == LAPACK_ROW_MAJOR ) { lapack_int nu = LAPACKE_lsame( jobu, 'n' ) ? 1 : m; lapack_int nv = LAPACKE_lsame( jobv, 'n' ) ? 1 : n; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'n' ) ? 1 : + LAPACKE_lsame( jobu, 'f' ) ? m : n; lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nu); lapack_int ldv_t = MAX(1,nv); @@ -66,7 +68,7 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, LAPACKE_xerbla( "LAPACKE_zgejsv_work", info ); return info; } - if( ldu < n ) { + if( ldu < ncols_u ) { info = -14; LAPACKE_xerbla( "LAPACKE_zgejsv_work", info ); return info; @@ -86,7 +88,7 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { u_t = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * ldu_t * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_double) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_1; @@ -103,14 +105,6 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, } /* Transpose input matrices */ LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); - if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || - LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_zge_trans( matrix_layout, nu, n, u, ldu, u_t, ldu_t ); - } - if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || - LAPACKE_lsame( jobv, 'w' ) ) { - LAPACKE_zge_trans( matrix_layout, nv, n, v, ldv, v_t, ldv_t ); - } /* Call LAPACK function and adjust info */ LAPACK_zgejsv( &joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a_t, &lda_t, sva, u_t, &ldu_t, v_t, &ldv_t, cwork, &lwork, @@ -121,7 +115,7 @@ lapack_int LAPACKE_zgejsv_work( int matrix_layout, char joba, char jobu, /* Transpose output matrices */ if( LAPACKE_lsame( jobu, 'f' ) || LAPACKE_lsame( jobu, 'u' ) || LAPACKE_lsame( jobu, 'w' ) ) { - LAPACKE_zge_trans( LAPACK_COL_MAJOR, nu, n, u_t, ldu_t, u, ldu ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, nu, ncols_u, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'j' ) || LAPACKE_lsame( jobv, 'v' ) || LAPACKE_lsame( jobv, 'w' ) ) { diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgelq.c b/lapack-netlib/LAPACKE/src/lapacke_zgelq.c new file mode 100644 index 0000000000..5f12035069 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgelq.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgelq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgelq_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zgelq_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgelq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgelq_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgelq_work.c new file mode 100644 index 0000000000..9f503c0f47 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgelq_work.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgelq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgelq_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgelq( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zgelq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_zgelq( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgelq( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgelq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgelq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgemlq.c b/lapack-netlib/LAPACKE/src/lapacke_zgemlq.c new file mode 100644 index 0000000000..b47ca26a95 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgemlq.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgemlq +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgemlq( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgemlq", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, k, m, a, lda ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_d_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zgemlq_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgemlq", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgemlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgemlq_work.c new file mode 100644 index 0000000000..d10e730609 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgemlq_work.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgemlq +* Author: Intel Corporation +* Generated June 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgemlq_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + lapack_complex_double *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgemlq( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, + c, &ldc, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,k); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < r ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zgemlq_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_zgemlq_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zgemlq( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,m) ); + } else { + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + } + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, k, m, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgemlq( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgemlq_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgemlq_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgemqr.c b/lapack-netlib/LAPACKE/src/lapacke_zgemqr.c new file mode 100644 index 0000000000..07e1a7aa27 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgemqr.c @@ -0,0 +1,88 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgemqr( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + lapack_int r; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgemqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + r = LAPACKE_lsame( side, 'l' ) ? m : n; + if( LAPACKE_zge_nancheck( matrix_layout, r, k, a, lda ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, m, n, c, ldc ) ) { + return -10; + } + if( LAPACKE_z_nancheck( tsize, t, 1 ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zgemqr_work( matrix_layout, side, trans, m, n, k, a, lda, + t, tsize, c, ldc, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgemqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgemqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgemqr_work.c new file mode 100644 index 0000000000..f17fa84eba --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgemqr_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgemqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgemqr_work( int matrix_layout, char side, char trans, + lapack_int m, lapack_int n, lapack_int k, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + lapack_int r; + lapack_int lda_t, ldc_t; + lapack_complex_double *a_t = NULL, *c_t = NULL; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgemqr( &side, &trans, &m, &n, &k, a, &lda, t, &tsize, c, &ldc, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + r = LAPACKE_lsame( side, 'l' ) ? m : n; + lda_t = MAX(1,r); + ldc_t = MAX(1,m); + /* Check leading dimension(s) */ + if( lda < k ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zgemqr_work", info ); + return info; + } + if( ldc < n ) { + info = -11; + LAPACKE_xerbla( "LAPACKE_zgemqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zgemqr( &side, &trans, &m, &n, &k, a, &lda_t, t, &tsize, + c, &ldc_t, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,k) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + c_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, r, k, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgemqr( &side, &trans, &m, &n, &k, a_t, &lda_t, t, &tsize, + c_t, &ldc_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + /* Release memory and exit */ + LAPACKE_free( c_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgemqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgemqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgemqrt.c b/lapack-netlib/LAPACKE/src/lapacke_zgemqrt.c index d8b1540bcd..f1f32bb5b5 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgemqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgemqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function zgemqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -40,6 +40,7 @@ lapack_int LAPACKE_zgemqrt( int matrix_layout, char side, char trans, lapack_int ldt, lapack_complex_double* c, lapack_int ldc ) { + lapack_int nrows_v; lapack_int info = 0; lapack_complex_double* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -48,13 +49,15 @@ lapack_int LAPACKE_zgemqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); if( LAPACKE_zge_nancheck( matrix_layout, m, n, c, ldc ) ) { return -12; } - if( LAPACKE_zge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -10; } - if( LAPACKE_zge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -8; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgeqr.c b/lapack-netlib/LAPACKE/src/lapacke_zgeqr.c new file mode 100644 index 0000000000..2370f4c232 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgeqr.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgeqr( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgeqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgeqr_work( matrix_layout, m, n, a, lda, t, tsize, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + if( tsize == -1 || tsize == -2 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zgeqr_work( matrix_layout, m, n, a, lda, t, tsize, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgeqr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgeqr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgeqr_work.c new file mode 100644 index 0000000000..304738b486 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgeqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgeqr +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgeqr_work( int matrix_layout, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* t, lapack_int tsize, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgeqr( &m, &n, a, &lda, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zgeqr_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( tsize == -1 || tsize == -2 || lwork == -1 || lwork == -2) { + LAPACK_zgeqr( &m, &n, a, &lda_t, t, &tsize, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgeqr( &m, &n, a_t, &lda_t, t, &tsize, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgeqr_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgeqr_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgesvdx.c b/lapack-netlib/LAPACKE/src/lapacke_zgesvdx.c index c2635da85f..4847dbf1c1 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgesvdx.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgesvdx.c @@ -28,15 +28,15 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zgesvdx * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zgesvdx( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, lapack_complex_double* u, lapack_int ldu, lapack_complex_double* vt, lapack_int ldvt, lapack_int* superb ) @@ -44,9 +44,9 @@ lapack_int LAPACKE_zgesvdx( int matrix_layout, char jobu, char jobvt, char range lapack_int info = 0; lapack_int lwork = -1; lapack_complex_double* work = NULL; - lapack_complex_double work_query; + lapack_complex_double work_query; double* rwork = NULL; - lapack_int lrwork = MIN(m,n)*(MIN(m,n)*2+15*MIN(m,n)); + lapack_int lrwork = MAX(1,MIN(m,n)*(MIN(m,n)*2+15*MIN(m,n))); lapack_int* iwork = NULL; lapack_int i; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -68,18 +68,18 @@ lapack_int LAPACKE_zgesvdx( int matrix_layout, char jobu, char jobvt, char range } lwork = LAPACK_Z2INT (work_query); /* Allocate memory for work arrays */ - rwork = (double*)LAPACKE_malloc( sizeof(double) * lwork ); - if( work == NULL ) { - info = LAPACK_WORK_MEMORY_ERROR; - goto exit_level_0; - } work = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * lrwork ); + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_1; } - iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * (12*MIN(m,n)) ); + rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,(12*MIN(m,n))) ); if( iwork == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_2; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgesvdx_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgesvdx_work.c index 91b20165a7..3070687a78 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgesvdx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgesvdx_work.c @@ -28,39 +28,41 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zgesvdx * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char range, lapack_int m, lapack_int n, lapack_complex_double* a, - lapack_int lda, lapack_int vl, lapack_int vu, - lapack_int il, lapack_int iu, lapack_int ns, + lapack_int lda, double vl, double vu, + lapack_int il, lapack_int iu, lapack_int* ns, double* s, lapack_complex_double* u, lapack_int ldu, - lapack_complex_double* vt, lapack_int ldvt, - lapack_complex_double* work, lapack_int lwork, + lapack_complex_double* vt, lapack_int ldvt, + lapack_complex_double* work, lapack_int lwork, double* rwork, lapack_int* iwork ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_zgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda, &vl, &vu, - &il, &iu, &ns, s, u, &ldu, vt, &ldvt, + &il, &iu, ns, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_u = ( LAPACKE_lsame( jobu, 'a' ) || - LAPACKE_lsame( jobu, 's' ) ) ? m : 1; - lapack_int ncols_u = LAPACKE_lsame( jobu, 'a' ) ? m : - ( LAPACKE_lsame( jobu, 's' ) ? MIN(m,n) : 1); - lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'a' ) ? n : - ( LAPACKE_lsame( jobvt, 's' ) ? MIN(m,n) : 1); + lapack_int nrows_u = LAPACKE_lsame( jobu, 'v' ) ? m : 0; + lapack_int ncols_u = LAPACKE_lsame( jobu, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int nrows_vt = LAPACKE_lsame( jobvt, 'v' ) ? + ( LAPACKE_lsame( range, 'i' ) ? MAX(iu - il + 1, 0) : MIN(m,n)) : 0; + lapack_int ncols_vt = LAPACKE_lsame( jobvt, 'v' ) ? n : 0; + lapack_int lda_t = MAX(1,m); lapack_int ldu_t = MAX(1,nrows_u); lapack_int ldvt_t = MAX(1,nrows_vt); + lapack_complex_double* a_t = NULL; lapack_complex_double* u_t = NULL; lapack_complex_double* vt_t = NULL; @@ -75,7 +77,7 @@ lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char LAPACKE_xerbla( "LAPACKE_zgesvdx_work", info ); return info; } - if( ldvt < n ) { + if( ldvt < ncols_vt ) { info = -18; LAPACKE_xerbla( "LAPACKE_zgesvdx_work", info ); return info; @@ -83,7 +85,7 @@ lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { LAPACK_zgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + &il, &iu, ns, s, u, &ldu_t, vt, &ldvt_t, work, &lwork, rwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -94,7 +96,7 @@ lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { u_t = (lapack_complex_double*) LAPACKE_malloc( sizeof(lapack_complex_double) * ldu_t * MAX(1,ncols_u) ); if( u_t == NULL ) { @@ -102,7 +104,7 @@ lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char goto exit_level_1; } } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { vt_t = (lapack_complex_double*) LAPACKE_malloc( sizeof(lapack_complex_double) * ldvt_t * MAX(1,n) ); if( vt_t == NULL ) { @@ -113,28 +115,28 @@ lapack_int LAPACKE_zgesvdx_work( int matrix_layout, char jobu, char jobvt, char /* Transpose input matrices */ LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_zgesvdx( &jobu, &jobvt, &range, &m, &n, a, &lda_t, &vl, &vu, - &il, &iu, &ns, s, u, &ldu_t, vt, + LAPACK_zgesvdx( &jobu, &jobvt, &range, &m, &n, a_t, &lda_t, &vl, &vu, + &il, &iu, ns, s, u_t, &ldu_t, vt_t, &ldvt_t, work, &lwork, rwork, iwork, &info ); if( info < 0 ) { info = info - 1; } /* Transpose output matrices */ LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_zge_trans( LAPACK_COL_MAJOR, nrows_u, ncols_u, u_t, ldu_t, u, ldu ); } - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_zge_trans( LAPACK_COL_MAJOR, nrows_vt, n, vt_t, ldvt_t, vt, ldvt ); } /* Release memory and exit */ - if( LAPACKE_lsame( jobvt, 'a' ) || LAPACKE_lsame( jobvt, 's' ) ) { + if( LAPACKE_lsame( jobvt, 'v' ) ) { LAPACKE_free( vt_t ); } exit_level_2: - if( LAPACKE_lsame( jobu, 'a' ) || LAPACKE_lsame( jobu, 's' ) ) { + if( LAPACKE_lsame( jobu, 'v' ) ) { LAPACKE_free( u_t ); } exit_level_1: diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgesvj.c b/lapack-netlib/LAPACKE/src/lapacke_zgesvj.c index dbd5c436cb..dfa0ca88a8 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgesvj.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgesvj.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zgesvj * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -52,8 +52,8 @@ lapack_int LAPACKE_zgesvj( int matrix_layout, char joba, char jobu, char jobv, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { return -7; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgesvj_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgesvj_work.c index e618bf9e42..37e6c1ee6f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgesvj_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgesvj_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zgesvj * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zgesvj_work( int matrix_layout, char joba, char jobu, - char jobv, lapack_int m, lapack_int n, - lapack_complex_double* a, lapack_int lda, + char jobv, lapack_int m, lapack_int n, + lapack_complex_double* a, lapack_int lda, double* sva, lapack_int mv, lapack_complex_double* v, lapack_int ldv, lapack_complex_double* cwork, lapack_int lwork, @@ -50,8 +50,8 @@ lapack_int LAPACKE_zgesvj_work( int matrix_layout, char joba, char jobu, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? n : - ( LAPACKE_lsame( jobv, 'a' ) ? mv : 1); + lapack_int nrows_v = LAPACKE_lsame( jobv, 'v' ) ? MAX(0,n) : + ( LAPACKE_lsame( jobv, 'a' ) ? MAX(0,mv) : 0); lapack_int lda_t = MAX(1,m); lapack_int ldv_t = MAX(1,nrows_v); lapack_complex_double* a_t = NULL; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgetsls.c b/lapack-netlib/LAPACKE/src/lapacke_zgetsls.c new file mode 100644 index 0000000000..6e73657d58 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgetsls.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgetsls( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgetsls", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -6; + } + if( LAPACKE_zge_nancheck( matrix_layout, MAX(m,n), nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zgetsls_work( matrix_layout, trans, m, n, nrhs, a, lda, b, ldb, + work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgetsls", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgetsls_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgetsls_work.c new file mode 100644 index 0000000000..dca7d49afd --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgetsls_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgetsls +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgetsls_work( int matrix_layout, char trans, lapack_int m, + lapack_int n, lapack_int nrhs, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgetsls( &trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,MAX(m,n)); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zgetsls_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zgetsls_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zgetsls( &trans, &m, &n, &nrhs, a, &lda_t, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, MAX(m,n), nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgetsls( &trans, &m, &n, &nrhs, a_t, &lda_t, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, MAX(m,n), nrhs, b_t, ldb_t, b, + ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgetsls_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgetsls_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgghd3.c b/lapack-netlib/LAPACKE/src/lapacke_zgghd3.c index 03becb8a96..c43f1a55d8 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zgghd3.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zgghd3.c @@ -75,7 +75,7 @@ lapack_int LAPACKE_zgghd3( int matrix_layout, char compq, char compz, if( info != 0 ) { goto exit_level_0; } - lwork = LAPACK_C2INT( work_query ); + lwork = LAPACK_Z2INT( work_query ); /* Allocate memory for work arrays */ work = (lapack_complex_double*) LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_zggsvd3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zggsvd3_work.c index aedd405f03..1c65153252 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zggsvd3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zggsvd3_work.c @@ -93,9 +93,9 @@ lapack_int LAPACKE_zggsvd3_work( int matrix_layout, char jobu, char jobv, } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_zggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a_t, &lda_t, - b_t, &ldb_t, alpha, beta, u_t, &ldu_t, v_t, &ldv_t, - q_t, &ldq_t, work, &lwork, rwork, iwork, &info ); + LAPACK_zggsvd3( &jobu, &jobv, &jobq, &m, &n, &p, k, l, a, &lda_t, + b, &ldb_t, alpha, beta, u, &ldu_t, v, &ldv_t, + q, &ldq_t, work, &lwork, rwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_zggsvp3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zggsvp3_work.c index a266beb541..6ea0c8d52d 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zggsvp3_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zggsvp3_work.c @@ -87,16 +87,16 @@ lapack_int LAPACKE_zggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_xerbla( "LAPACKE_zggsvp3_work", info ); return info; } - if( ldv < m ) { + if( ldv < p ) { info = -19; LAPACKE_xerbla( "LAPACKE_zggsvp3_work", info ); return info; } /* Query optimal working array(s) size if requested */ if( lwork == -1 ) { - LAPACK_zggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a_t, &lda_t, b_t, - &ldb_t, &tola, &tolb, k, l, u_t, &ldu_t, v_t, - &ldv_t, q_t, &ldq_t, iwork, rwork, tau, work, + LAPACK_zggsvp3( &jobu, &jobv, &jobq, &m, &p, &n, a, &lda_t, b, + &ldb_t, &tola, &tolb, k, l, u, &ldu_t, v, + &ldv_t, q, &ldq_t, iwork, rwork, tau, work, &lwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -125,7 +125,7 @@ lapack_int LAPACKE_zggsvp3_work( int matrix_layout, char jobu, char jobv, if( LAPACKE_lsame( jobv, 'v' ) ) { v_t = (lapack_complex_double*) LAPACKE_malloc( sizeof(lapack_complex_double) * - ldv_t * MAX(1,m) ); + ldv_t * MAX(1,p) ); if( v_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_3; @@ -157,7 +157,7 @@ lapack_int LAPACKE_zggsvp3_work( int matrix_layout, char jobu, char jobv, LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, m, u_t, ldu_t, u, ldu ); } if( LAPACKE_lsame( jobv, 'v' ) ) { - LAPACKE_zge_trans( LAPACK_COL_MAJOR, p, m, v_t, ldv_t, v, ldv ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, p, p, v_t, ldv_t, v, ldv ); } if( LAPACKE_lsame( jobq, 'q' ) ) { LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage.c new file mode 100644 index 0000000000..6bad98ddb2 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_double* ab, + lapack_int ldab, double* w, lapack_complex_double* z, + lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhbev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for working array(s) */ + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_zhbev_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage_work.c new file mode 100644 index 0000000000..5671c111e3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbev_2stage_work.c @@ -0,0 +1,118 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhbev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhbev_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, + rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* ab_t = NULL; + lapack_complex_double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zhbev_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zhbev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_zhb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhbev_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhbev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage.c new file mode 100644 index 0000000000..cf1263d492 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_int kd, lapack_complex_double* ab, + lapack_int ldab, double* w, lapack_complex_double* z, + lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_int iwork_query; + double rwork_query; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zhbevd_2stage_work( matrix_layout, jobz, uplo, n, kd, ab, ldab, w, z, + ldz, work, lwork, rwork, lrwork, iwork, + liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage_work.c new file mode 100644 index 0000000000..e7604e870f --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbevd_2stage_work.c @@ -0,0 +1,121 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhbevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, + lapack_int lrwork, lapack_int* iwork, + lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, + &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* ab_t = NULL; + lapack_complex_double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage_work", info ); + return info; + } + if( ldz < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_zhbevd_2stage( &jobz, &uplo, &n, &kd, ab, &ldab_t, w, z, &ldz_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_zhb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhbevd_2stage( &jobz, &uplo, &n, &kd, ab_t, &ldab_t, w, z_t, &ldz_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhbevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage.c new file mode 100644 index 0000000000..5adf4992cf --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage.c @@ -0,0 +1,114 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + lapack_complex_double* q, lapack_int ldq, double vl, + double vu, lapack_int il, lapack_int iu, + double abstol, lapack_int* m, double* w, + lapack_complex_double* z, lapack_int ldz, + lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { + return -7; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -15; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -11; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -12; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, &work_query, lwork, rwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,7*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zhbevx_2stage_work( matrix_layout, jobz, range, uplo, n, kd, ab, + ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, + ldz, work, lwork, rwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage_work.c new file mode 100644 index 0000000000..ffd5527fbb --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbevx_2stage_work.c @@ -0,0 +1,152 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhbevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhbevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, lapack_int kd, + lapack_complex_double* ab, lapack_int ldab, + lapack_complex_double* q, lapack_int ldq, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, lapack_int* iwork, + lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, + &vu, &il, &iu, &abstol, m, w, z, &ldz, work, &lwork, rwork, + iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int ldab_t = MAX(1,kd+1); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* ab_t = NULL; + lapack_complex_double* q_t = NULL; + lapack_complex_double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldab < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage_work", info ); + return info; + } + if( ldq < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -19; + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + ab_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldab_t * MAX(1,n) ); + if( ab_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + q_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, rwork, iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Transpose input matrices */ + LAPACKE_zhb_trans( matrix_layout, uplo, n, kd, ab, ldab, ab_t, ldab_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhbevx_2stage( &jobz, &range, &uplo, &n, &kd, ab_t, &ldab_t, q_t, + &ldq_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, + work, &lwork, rwork, iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhb_trans( LAPACK_COL_MAJOR, uplo, n, kd, ab_t, ldab_t, ab, + ldab ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_2: + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( q_t ); + } +exit_level_1: + LAPACKE_free( ab_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhbevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhbtrd.c b/lapack-netlib/LAPACKE/src/lapacke_zhbtrd.c index 309123cc60..c3abb6a259 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zhbtrd.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zhbtrd.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zhbtrd * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -49,7 +49,7 @@ lapack_int LAPACKE_zhbtrd( int matrix_layout, char vect, char uplo, lapack_int n if( LAPACKE_zhb_nancheck( matrix_layout, uplo, n, kd, ab, ldab ) ) { return -6; } - if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) { + if( LAPACKE_lsame( vect, 'u' ) ) { if( LAPACKE_zge_nancheck( matrix_layout, n, n, q, ldq ) ) { return -10; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhecon_3.c b/lapack-netlib/LAPACKE/src/lapacke_zhecon_3.c new file mode 100644 index 0000000000..a08bc8c096 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhecon_3.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhecon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhecon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, double* rcond ) +{ + lapack_int info = 0; + lapack_complex_double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhecon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhecon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhecon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhecon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhecon_3_work.c new file mode 100644 index 0000000000..47d26f54f7 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhecon_3_work.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhecon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhecon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond, lapack_complex_double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhecon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zhecon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhecon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhecon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhecon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage.c new file mode 100644 index 0000000000..c7ef18da7b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zheev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheev_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zheev_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_zheev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_zheev_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheev_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage_work.c new file mode 100644 index 0000000000..213ea04af4 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheev_2stage_work.c @@ -0,0 +1,93 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zheev_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheev_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double* w, + lapack_complex_double* work, lapack_int lwork, + double* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zheev_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zheev_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zheev_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, rwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zheev_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, rwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheev_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zheev_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage.c new file mode 100644 index 0000000000..b6dd0a202d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage.c @@ -0,0 +1,100 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zheevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevd_2stage( int matrix_layout, char jobz, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, double* w ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_int iwork_query; + double rwork_query; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zheevd_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zheevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zheevd_2stage_work( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevd_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage_work.c new file mode 100644 index 0000000000..d4b648ee1e --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevd_2stage_work.c @@ -0,0 +1,94 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zheevd_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevd_2stage_work( int matrix_layout, char jobz, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double* w, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zheevd_2stage( &jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zheevd_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_zheevd_2stage( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zheevd_2stage( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevd_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zheevd_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage.c new file mode 100644 index 0000000000..38748e4cbf --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage.c @@ -0,0 +1,119 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zheevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevr_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, lapack_int ldz, + lapack_int* isuppz ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lrwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_int iwork_query; + double rwork_query; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zheevr_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zheevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, + &work_query, lwork, &rwork_query, lrwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = (lapack_int)iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zheevr_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, isuppz, work, + lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevr_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage_work.c new file mode 100644 index 0000000000..643d0e2163 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevr_2stage_work.c @@ -0,0 +1,128 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zheevr_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevr_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_int* isuppz, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zheevr_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, isuppz, work, &lwork, rwork, + &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zheevr_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_zheevr_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( liwork == -1 || lrwork == -1 || lwork == -1 ) { + LAPACK_zheevr_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, isuppz, work, &lwork, + rwork, &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zheevr_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, isuppz, work, &lwork, + rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevr_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zheevr_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage.c new file mode 100644 index 0000000000..1350e17966 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage.c @@ -0,0 +1,113 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zheevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevx_2stage( int matrix_layout, char jobz, char range, char uplo, + lapack_int n, lapack_complex_double* a, + lapack_int lda, double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, lapack_int ldz, + lapack_int* ifail ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zheevx_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &abstol, 1 ) ) { + return -12; + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vl, 1 ) ) { + return -8; + } + } + if( LAPACKE_lsame( range, 'v' ) ) { + if( LAPACKE_d_nancheck( 1, &vu, 1 ) ) { + return -9; + } + } +#endif + /* Allocate memory for working array(s) */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * MAX(1,5*n) ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,7*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Query optimal working array(s) size */ + info = LAPACKE_zheevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, &work_query, + lwork, rwork, iwork, ifail ); + if( info != 0 ) { + goto exit_level_2; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zheevx_2stage_work( matrix_layout, jobz, range, uplo, n, a, lda, vl, + vu, il, iu, abstol, m, w, z, ldz, work, lwork, + rwork, iwork, ifail ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevx_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage_work.c new file mode 100644 index 0000000000..846ec14453 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zheevx_2stage_work.c @@ -0,0 +1,127 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zheevx_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zheevx_2stage_work( int matrix_layout, char jobz, char range, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + double vl, double vu, lapack_int il, + lapack_int iu, double abstol, lapack_int* m, + double* w, lapack_complex_double* z, + lapack_int ldz, lapack_complex_double* work, + lapack_int lwork, double* rwork, + lapack_int* iwork, lapack_int* ifail ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zheevx_2stage( &jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, + &abstol, m, w, z, &ldz, work, &lwork, rwork, iwork, + ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ncols_z = ( LAPACKE_lsame( range, 'a' ) || + LAPACKE_lsame( range, 'v' ) ) ? n : + ( LAPACKE_lsame( range, 'i' ) ? (iu-il+1) : 1); + lapack_int lda_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* z_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zheevx_2stage_work", info ); + return info; + } + if( ldz < ncols_z ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_zheevx_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zheevx_2stage( &jobz, &range, &uplo, &n, a, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z, &ldz_t, work, &lwork, rwork, + iwork, ifail, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( LAPACKE_lsame( jobz, 'v' ) ) { + z_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldz_t * MAX(1,ncols_z) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zheevx_2stage( &jobz, &range, &uplo, &n, a_t, &lda_t, &vl, &vu, &il, + &iu, &abstol, m, w, z_t, &ldz_t, work, &lwork, rwork, + iwork, ifail, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, + ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zheevx_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zheevx_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage.c b/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage.c new file mode 100644 index 0000000000..31f8eba86d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage.c @@ -0,0 +1,91 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhegv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhegv_2stage( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* b, + lapack_int ldb, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhegv_2stage", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -6; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,3*n-2) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_zhegv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_zhegv_2stage_work( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork, rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhegv_2stage", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage_work.c new file mode 100644 index 0000000000..596c8fdb28 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhegv_2stage_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhegv_2stage +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhegv_2stage_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + double* w, lapack_complex_double* work, + lapack_int lwork, double* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhegv_2stage( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + LAPACKE_xerbla( "LAPACKE_zhegv_2stage_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zhegv_2stage_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhegv_2stage( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, rwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhegv_2stage( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhegv_2stage_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhegv_2stage_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhegvx_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhegvx_work.c index 5ebfb99544..4da4f560ab 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zhegvx_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zhegvx_work.c @@ -110,7 +110,7 @@ lapack_int LAPACKE_zhegvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose input matrices */ LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); - LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + LAPACKE_zhe_trans( matrix_layout, uplo, n, b, ldb, b_t, ldb_t ); /* Call LAPACK function and adjust info */ LAPACK_zhegvx( &itype, &jobz, &range, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &vl, &vu, &il, &iu, &abstol, m, w, z_t, &ldz_t, @@ -120,7 +120,7 @@ lapack_int LAPACKE_zhegvx_work( int matrix_layout, lapack_int itype, char jobz, } /* Transpose output matrices */ LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); - LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, b_t, ldb_t, b, ldb ); if( LAPACKE_lsame( jobz, 'v' ) ) { LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, ncols_z, z_t, ldz_t, z, ldz ); diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa.c new file mode 100644 index 0000000000..29818469e1 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhesv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhesv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhesv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhesv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa_work.c new file mode 100644 index 0000000000..85efc4bae3 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhesv_aa_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhesv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhesv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhesv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zhesv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zhesv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhesv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhesv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhesv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk.c new file mode 100644 index 0000000000..777a7b9fab --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhesv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhesv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_z_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhesv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhesv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk_work.c new file mode 100644 index 0000000000..892843a664 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhesv_rk_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhesv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhesv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, + lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhesv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zhesv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zhesv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhesv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhesv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhesv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhesv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheswapr.c b/lapack-netlib/LAPACKE/src/lapacke_zheswapr.c index 93350fbd46..61dbb24ec7 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zheswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zheswapr.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zheswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zheswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_zheswapr", -1 ); @@ -43,9 +43,9 @@ lapack_int LAPACKE_zheswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_zheswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_zheswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zheswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zheswapr_work.c index e62f987bfc..73853a8a81 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zheswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zheswapr_work.c @@ -28,38 +28,39 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zheswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zheswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_zheswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_zheswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); lapack_complex_double* a_t = NULL; /* Allocate memory for temporary array(s) */ a_t = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * n * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_zhe_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_zheswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_zheswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa.c new file mode 100644 index 0000000000..8649ad0b5c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhetrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhetrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhetrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa_work.c new file mode 100644 index 0000000000..5214217fb8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_aa_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhetrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhetrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zhetrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhetrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhetrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhetrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk.c new file mode 100644 index 0000000000..19dc423dc8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhetrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhetrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhetrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk_work.c new file mode 100644 index 0000000000..45d6964a20 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrf_rk_work.c @@ -0,0 +1,90 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhetrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhetrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zhetrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhetrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhetrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhetrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetri2x.c b/lapack-netlib/LAPACKE/src/lapacke_zhetri2x.c index a2835dc330..b991412b85 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zhetri2x.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetri2x.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zhetri2x * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -45,7 +45,7 @@ lapack_int LAPACKE_zhetri2x( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_zge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { return -4; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetri_3.c b/lapack-netlib/LAPACKE/src/lapacke_zhetri_3.c new file mode 100644 index 0000000000..33790c2f73 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetri_3.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhetri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhetri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhetri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for working array(s) */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhetri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhetri_3_work.c new file mode 100644 index 0000000000..c85bc575f8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetri_3_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhetri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhetri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zhetri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zhetri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhetri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zhe_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhetri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3.c new file mode 100644 index 0000000000..016bc79297 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3.c @@ -0,0 +1,60 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhetrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhetrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_z_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_zhetrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3_work.c new file mode 100644 index 0000000000..da60c355ca --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_3_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhetrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhetrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zhetrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zhetrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhetrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhetrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa.c new file mode 100644 index 0000000000..b15786f1f1 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zhetrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zhetrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zhe_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zhetrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zhetrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa_work.c new file mode 100644 index 0000000000..d1d64a79b9 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zhetrs_aa_work.c @@ -0,0 +1,104 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zhetrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zhetrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, + const lapack_complex_double* a, lapack_int lda, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zhetrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zhetrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zhetrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zhe_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zhetrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zhetrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zhetrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlantr.c b/lapack-netlib/LAPACKE/src/lapacke_zlantr.c index 2b645e7508..29f7cf27d9 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlantr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlantr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zlantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlantr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zlantr_work.c index 0988bf6e8c..0d8bcf5506 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlantr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlantr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zlantr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlarfb_work.c b/lapack-netlib/LAPACKE/src/lapacke_zlarfb_work.c index 9580f593e1..8289db78da 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlarfb_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlarfb_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zlarfb * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -44,7 +44,7 @@ lapack_int LAPACKE_zlarfb_work( int matrix_layout, char side, char trans, lapack_int info = 0; lapack_int nrows_v, ncols_v; lapack_int ldc_t, ldt_t, ldv_t; - lapack_complex_double *v_t = NULL, *t_t = NULL, *c_t = NULL; + lapack_complex_double *v_t = NULL, *t_t = NULL, *c_t = NULL; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_zlarfb( &side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, @@ -123,7 +123,7 @@ lapack_int LAPACKE_zlarfb_work( int matrix_layout, char side, char trans, LAPACKE_zge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv, &v_t[k*ldv_t], ldv_t ); } else if( LAPACKE_lsame( storev, 'r' ) && - LAPACKE_lsame( direct, 'f' ) ) { + LAPACKE_lsame( direct, 'b' ) ) { if( k > ncols_v ) { LAPACKE_xerbla( "LAPACKE_zlarfb_work", -8 ); return -8; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlascl.c b/lapack-netlib/LAPACKE/src/lapacke_zlascl.c index e4c1bb0cdc..de4b9c2196 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlascl.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlascl.c @@ -28,68 +28,82 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function dlaswp * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zlascl( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, lapack_complex_double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, lapack_complex_double* a, lapack_int lda ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_zlascl", -1 ); return -1; } -#ifndef LAPACK_zISABLE_NAN_CHECK +#ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ switch (type) { case 'G': - if( LAPACKE_zge_nancheck( matrix_layout, lda, n, a, lda ) ) { - return -9; - } + if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -9; + } break; case 'L': - // TYPE = 'L' - lower triangular matrix. - if( LAPACKE_ztr_nancheck( matrix_layout, 'L', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'L' - lower triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_zgb_nancheck( matrix_layout, m, n, m-1, 0, a, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_zgb_nancheck( LAPACK_COL_MAJOR, n, m, 0, m-1, a-m+1, lda+1 ) ) { + return -9; + } break; case 'U': - // TYPE = 'U' - upper triangular matrix - if( LAPACKE_ztr_nancheck( matrix_layout, 'U', 'N', n, a, lda ) ) { - return -9; - } + // TYPE = 'U' - upper triangle of general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_zgb_nancheck( matrix_layout, m, n, 0, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_zgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 0, a, lda+1 ) ) { + return -9; + } break; case 'H': - // TYPE = 'H' - upper Hessenberg matrix - if( LAPACKE_zhs_nancheck( matrix_layout, n, a, lda ) ) { - return -9; - } - break; + // TYPE = 'H' - part of upper Hessenberg matrix in general matrix + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_zgb_nancheck( matrix_layout, m, n, 1, n-1, a-n+1, lda+1 ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_zgb_nancheck( LAPACK_COL_MAJOR, n, m, n-1, 1, a-1, lda+1 ) ) { + return -9; + } case 'B': - // TYPE = 'B' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the lower - // half stored. - if( LAPACKE_zhb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { - return -9; - } - break; - case 'Q': - // TYPE = 'Q' - A is a symmetric band matrix with lower bandwidth KL - // and upper bandwidth KU and with the only the upper - // half stored. - if( LAPACKE_zhb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { - return -9; - } + // TYPE = 'B' - lower part of symmetric band matrix (assume m==n) + if( LAPACKE_zhb_nancheck( matrix_layout, 'L', n, kl, a, lda ) ) { + return -9; + } + break; + case 'Q': + // TYPE = 'Q' - upper part of symmetric band matrix (assume m==n) + if( LAPACKE_zhb_nancheck( matrix_layout, 'U', n, ku, a, lda ) ) { + return -9; + } break; case 'Z': - // TYPE = 'Z' - A is a band matrix with lower bandwidth KL and upper - // bandwidth KU. See DGBTRF for storage details. - if( LAPACKE_zgb_nancheck( matrix_layout, n, n, kl, kl+ku, a, lda ) ) { - return -6; - } + // TYPE = 'Z' - band matrix laid out for ?GBTRF + if( matrix_layout == LAPACK_COL_MAJOR && + LAPACKE_zgb_nancheck( matrix_layout, m, n, kl, ku, a+kl, lda ) ) { + return -9; + } + if( matrix_layout == LAPACK_ROW_MAJOR && + LAPACKE_zgb_nancheck( matrix_layout, m, n, kl, ku, a+lda*kl, lda ) ) { + return -9; + } break; } #endif diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlascl_work.c b/lapack-netlib/LAPACKE/src/lapacke_zlascl_work.c index d8a76a8583..7adfbc9e55 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlascl_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlascl_work.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function dlaswp * Author: Intel Corporation -* Generated November, 2011 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zlascl_work( int matrix_layout, char type, lapack_int kl, - lapack_int ku, double cfrom, double cto, - lapack_int m, lapack_int n, lapack_complex_double* a, + lapack_int ku, double cfrom, double cto, + lapack_int m, lapack_int n, lapack_complex_double* a, lapack_int lda ) { lapack_int info = 0; @@ -46,7 +46,10 @@ lapack_int LAPACKE_zlascl_work( int matrix_layout, char type, lapack_int kl, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int nrows_a = LAPACKE_lsame(type, 'b') ? kl + 1 : + LAPACKE_lsame(type, 'q') ? ku + 1 : + LAPACKE_lsame(type, 'z') ? 2 * kl + ku + 1 : m; + lapack_int lda_t = MAX(1,nrows_a); lapack_complex_double* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -62,12 +65,14 @@ lapack_int LAPACKE_zlascl_work( int matrix_layout, char type, lapack_int kl, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_zge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, nrows_a, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_zlascl( &type, &kl, &ku, &cfrom, &cto, &m, &n, a_t, &lda_t, &info); - info = 0; /* LAPACK call is ok! */ + if( info < 0 ) { + info = info - 1; + } /* Transpose output matrices */ - LAPACKE_zge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, nrows_a, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlaset.c b/lapack-netlib/LAPACKE/src/lapacke_zlaset.c index 7de38f00e4..2dc0179292 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlaset.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlaset.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zlaset * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -45,8 +45,8 @@ lapack_int LAPACKE_zlaset( int matrix_layout, char uplo, lapack_int m, } /***************************************************************************** -* Note: we do not check NaNs in A since the goal of this subroutine is to -* initialized A. It is OK if A has NaNs in input. +* Note: we do not check NaNs in A since the goal of this subroutine is to +* initialized A. It is OK if A has NaNs in input. *****************************************************************************/ diff --git a/lapack-netlib/LAPACKE/src/lapacke_zlaswp_work.c b/lapack-netlib/LAPACKE/src/lapacke_zlaswp_work.c index e9a282cbd7..0ab0aae4ef 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zlaswp_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zlaswp_work.c @@ -46,7 +46,11 @@ lapack_int LAPACKE_zlaswp_work( int matrix_layout, lapack_int n, info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { - lapack_int lda_t = MAX(1,lda); + lapack_int lda_t = MAX(1,k2); + lapack_int i; + for( i = k1; i <= k2; i++ ) { + lda_t = MAX( lda_t, ipiv[k1 + ( i - k1 ) * ABS( incx ) - 1] ); + } lapack_complex_double* a_t = NULL; /* Check leading dimension(s) */ if( lda < n ) { @@ -62,12 +66,12 @@ lapack_int LAPACKE_zlaswp_work( int matrix_layout, lapack_int n, goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_zge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, lda_t, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ LAPACK_zlaswp( &n, a_t, &lda_t, &k1, &k2, ipiv, &incx ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_zge_trans( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, lda_t, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_zstedc.c b/lapack-netlib/LAPACKE/src/lapacke_zstedc.c index e88316eb5b..4e194f19e0 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zstedc.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zstedc.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zstedc * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -59,7 +59,7 @@ lapack_int LAPACKE_zstedc( int matrix_layout, char compz, lapack_int n, if( LAPACKE_d_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_zge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsteqr.c b/lapack-netlib/LAPACKE/src/lapacke_zsteqr.c index 0694baa9ce..c25b99fe0d 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zsteqr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zsteqr.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zsteqr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -53,7 +53,7 @@ lapack_int LAPACKE_zsteqr( int matrix_layout, char compz, lapack_int n, if( LAPACKE_d_nancheck( n-1, e, 1 ) ) { return -5; } - if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_lsame( compz, 'v' ) ) { if( LAPACKE_zge_nancheck( matrix_layout, n, n, z, ldz ) ) { return -6; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsycon_3.c b/lapack-netlib/LAPACKE/src/lapacke_zsycon_3.c new file mode 100644 index 0000000000..03900b66c5 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsycon_3.c @@ -0,0 +1,76 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsycon_3( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, double* rcond ) +{ + lapack_int info = 0; + lapack_complex_double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsycon_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } + if( LAPACKE_d_nancheck( 1, &anorm, 1 ) ) { + return -8; + } +#endif + /* Allocate memory for working array(s) */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsycon_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, anorm, + rcond, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsycon_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsycon_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsycon_3_work.c new file mode 100644 index 0000000000..b59d023400 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsycon_3_work.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsycon_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsycon_3_work( int matrix_layout, char uplo, lapack_int n, + const lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, + const lapack_int* ipiv, double anorm, + double* rcond, lapack_complex_double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsycon_3( &uplo, &n, a, &lda, e, ipiv, &anorm, rcond, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zsycon_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsycon_3( &uplo, &n, a_t, &lda_t, e, ipiv, &anorm, rcond, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsycon_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsycon_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsyconv.c b/lapack-netlib/LAPACKE/src/lapacke_zsyconv.c index 9dbc067895..e0b9166a68 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zsyconv.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zsyconv.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zsyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,26 +36,18 @@ lapack_int LAPACKE_zsyconv( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_double* work ) + lapack_complex_double* e ) { - lapack_int info = 0; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_zsyconv", -1 ); return -1; } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_zge_nancheck( matrix_layout, lda, n, a, lda ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { return -5; } #endif /* Call middle-level interface */ - info = LAPACKE_zsyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, - work ); - -exit_level_0: - if( info == LAPACK_WORK_MEMORY_ERROR ) { - LAPACKE_xerbla( "LAPACKE_zsyconv", info ); - } - return info; + return LAPACKE_zsyconv_work( matrix_layout, uplo, way, n, a, lda, ipiv, e ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsyconv_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsyconv_work.c index 34f1294e66..259f4d74c0 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zsyconv_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zsyconv_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zsyconv * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -36,12 +36,12 @@ lapack_int LAPACKE_zsyconv_work( int matrix_layout, char uplo, char way, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv, - lapack_complex_double* work ) + lapack_complex_double* e ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_zsyconv( &uplo, &way, &n, a, &lda, ipiv, work, &info ); + LAPACK_zsyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } @@ -64,7 +64,7 @@ lapack_int LAPACKE_zsyconv_work( int matrix_layout, char uplo, char way, /* Transpose input matrices */ LAPACKE_zge_trans( matrix_layout, lda, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_zsyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, work, &info ); + LAPACK_zsyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); if( info < 0 ) { info = info - 1; } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa.c new file mode 100644 index 0000000000..d858a0b39c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsysv_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa_work.c new file mode 100644 index 0000000000..80ba5c7467 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsysv_aa_work.c @@ -0,0 +1,111 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsysv_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zsysv_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zsysv_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsysv_aa( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsysv_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk.c b/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk.c new file mode 100644 index 0000000000..a33851193a --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_rk( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_z_nancheck( n, e, 1) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsysv_rk_work( matrix_layout, uplo, n, nrhs, a, lda, e, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk_work.c new file mode 100644 index 0000000000..bb07da25ed --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsysv_rk_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsysv_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_complex_double* e, + lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_rk( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zsysv_rk_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zsysv_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsysv_rk( &uplo, &n, &nrhs, a, &lda_t, e, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_rk( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsysv_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsyswapr.c b/lapack-netlib/LAPACKE/src/lapacke_zsyswapr.c index 46e948d183..9a08cf724f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zsyswapr.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zsyswapr.c @@ -28,14 +28,14 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zsyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zsyswapr( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { LAPACKE_xerbla( "LAPACKE_zsyswapr", -1 ); @@ -43,9 +43,9 @@ lapack_int LAPACKE_zsyswapr( int matrix_layout, char uplo, lapack_int n, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, n ) ) { + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { return -4; } #endif - return LAPACKE_zsyswapr_work( matrix_layout, uplo, n, a, i1, i2 ); + return LAPACKE_zsyswapr_work( matrix_layout, uplo, n, a, lda, i1, i2 ); } diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsyswapr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsyswapr_work.c index 1959a23154..44a297de54 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zsyswapr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zsyswapr_work.c @@ -28,38 +28,39 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zsyswapr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" lapack_int LAPACKE_zsyswapr_work( int matrix_layout, char uplo, lapack_int n, - lapack_complex_double* a, lapack_int i1, - lapack_int i2 ) + lapack_complex_double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) { lapack_int info = 0; if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ - LAPACK_zsyswapr( &uplo, &n, a, &i1, &i2 ); + LAPACK_zsyswapr( &uplo, &n, a, &lda, &i1, &i2 ); if( info < 0 ) { info = info - 1; } } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); lapack_complex_double* a_t = NULL; /* Allocate memory for temporary array(s) */ a_t = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * n * MAX(1,n) ); + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; } /* Transpose input matrices */ - LAPACKE_zsy_trans( matrix_layout, uplo, n, a, n, a_t, n ); + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); /* Call LAPACK function and adjust info */ - LAPACK_zsyswapr( &uplo, &n, a_t, &i1, &i2 ); + LAPACK_zsyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); info = 0; /* LAPACK call is ok! */ /* Transpose output matrices */ - LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, n, a, n ); + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); /* Release memory and exit */ LAPACKE_free( a_t ); exit_level_0: diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa.c new file mode 100644 index 0000000000..97b1f1df84 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrf_aa( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsytrf_aa_work( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa_work.c new file mode 100644 index 0000000000..29d75319e1 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_aa_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsytrf +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrf_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zsytrf_aa_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsytrf_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk.c new file mode 100644 index 0000000000..c4ead32de0 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrf_rk( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_rk", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsytrf_rk_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_rk", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk_work.c new file mode 100644 index 0000000000..20270b7d1b --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrf_rk_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsytrf_rk +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrf_rk_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* e, lapack_int* ipiv, lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsytrf_rk( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zsytrf_rk_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsytrf_rk( &uplo, &n, a, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsytrf_rk( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrf_rk_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsytrf_rk_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytri_3.c b/lapack-netlib/LAPACKE/src/lapacke_zsytri_3.c new file mode 100644 index 0000000000..0902c57fa0 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytri_3.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytri_3( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsytri_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + if( LAPACKE_z_nancheck( n, e, 1 ) ) { + return -6; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for working array(s) */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsytri_3_work( matrix_layout, uplo, n, a, lda, e, ipiv, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytri_3", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytri_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsytri_3_work.c new file mode 100644 index 0000000000..55e6c34635 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytri_3_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsytri_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytri_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_complex_double* a, lapack_int lda, + const lapack_complex_double* e, const lapack_int* ipiv, + lapack_complex_double* work, lapack_int lwork) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsytri_3( &uplo, &n, a, &lda, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + LAPACKE_xerbla( "LAPACKE_zsytri_3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsytri_3( &uplo, &n, a_t, &lda_t, e, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytri_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsytri_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3.c new file mode 100644 index 0000000000..47b3c36daa --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3.c @@ -0,0 +1,60 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrs_3( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, lapack_complex_double* b, + lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsytrs_3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_z_nancheck( n, e ,1 ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -9; + } +#endif + return LAPACKE_zsytrs_3_work( matrix_layout, uplo, n, nrhs, a, lda, + e, ipiv, b, ldb ); +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3_work.c new file mode 100644 index 0000000000..c510a1f74d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_3_work.c @@ -0,0 +1,103 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsytrs_3 +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrs_3_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_complex_double* e, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsytrs_3( &uplo, &n, &nrhs, a, &lda, e, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zsytrs_3_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zsytrs_3_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsytrs_3( &uplo, &n, &nrhs, a_t, &lda_t, e, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrs_3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsytrs_3_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa.c new file mode 100644 index 0000000000..d306b0f0b5 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrs_aa( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const lapack_complex_double* a, + lapack_int lda, const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsytrs_aa", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsytrs_aa_work( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrs_aa", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa_work.c b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa_work.c new file mode 100644 index 0000000000..8c54aa9b5c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zsytrs_aa_work.c @@ -0,0 +1,104 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsytrs_aa +* Author: Intel Corporation +* Generated December 2016 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsytrs_aa_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, + const lapack_complex_double* a, lapack_int lda, + const lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsytrs_aa( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zsytrs_aa_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zsytrs_aa_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsytrs_aa( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsytrs_aa_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsytrs_aa_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_ztpmqrt.c b/lapack-netlib/LAPACKE/src/lapacke_ztpmqrt.c index a591363c4f..e3bd95a650 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ztpmqrt.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ztpmqrt.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function ztpmqrt * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,6 +41,9 @@ lapack_int LAPACKE_ztpmqrt( int matrix_layout, char side, char trans, lapack_complex_double* a, lapack_int lda, lapack_complex_double* b, lapack_int ldb ) { + lapack_int ncols_a, nrows_a; + lapack_int nrows_v; + lapack_int lwork; lapack_int info = 0; lapack_complex_double* work = NULL; if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { @@ -49,22 +52,30 @@ lapack_int LAPACKE_ztpmqrt( int matrix_layout, char side, char trans, } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ - if( LAPACKE_zge_nancheck( matrix_layout, k, m, a, lda ) ) { + ncols_a = LAPACKE_lsame( side, 'L' ) ? n : + ( LAPACKE_lsame( side, 'R' ) ? k : 0 ); + nrows_a = LAPACKE_lsame( side, 'L' ) ? k : + ( LAPACKE_lsame( side, 'R' ) ? m : 0 ); + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + if( LAPACKE_zge_nancheck( matrix_layout, nrows_a, ncols_a, a, lda ) ) { return -13; } if( LAPACKE_zge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -15; } - if( LAPACKE_zge_nancheck( matrix_layout, ldt, nb, t, ldt ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, nb, k, t, ldt ) ) { return -11; } - if( LAPACKE_zge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, nrows_v, k, v, ldv ) ) { return -9; } #endif /* Allocate memory for working array(s) */ + lwork = LAPACKE_lsame( side, 'L' ) ? MAX(1,nb) * MAX(1,n) : + ( LAPACKE_lsame( side, 'R' ) ? MAX(1,m) * MAX(1,nb) : 0 ); work = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * MAX(1,m) * MAX(1,nb) ); + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_ztprfb.c b/lapack-netlib/LAPACKE/src/lapacke_ztprfb.c index 63a50bde90..b6894e8fae 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ztprfb.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ztprfb.c @@ -28,7 +28,7 @@ ****************************************************************************** * Contents: Native high-level C interface to LAPACK function ztprfb * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -41,6 +41,7 @@ lapack_int LAPACKE_ztprfb( int matrix_layout, char side, char trans, char direct lapack_complex_double* a, lapack_int lda, lapack_complex_double* b, lapack_int ldb) { + lapack_int ncols_v, nrows_v; lapack_int info = 0; lapack_int ldwork; lapack_int work_size; @@ -51,16 +52,28 @@ lapack_int LAPACKE_ztprfb( int matrix_layout, char side, char trans, char direct } #ifndef LAPACK_DISABLE_NAN_CHECK /* Optionally check input matrices for NaNs */ + if( LAPACKE_lsame( storev, 'C' ) ) { + ncols_v = k; + nrows_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + } else if( LAPACKE_lsame( storev, 'R' ) ) { + ncols_v = LAPACKE_lsame( side, 'L' ) ? m : + ( LAPACKE_lsame( side, 'R' ) ? n : 0 ); + nrows_v = k; + } else { + ncols_v = 0; + nrows_v = 0; + } if( LAPACKE_zge_nancheck( matrix_layout, k, m, a, lda ) ) { return -14; } if( LAPACKE_zge_nancheck( matrix_layout, m, n, b, ldb ) ) { return -16; } - if( LAPACKE_zge_nancheck( matrix_layout, ldt, k, t, ldt ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, k, k, t, ldt ) ) { return -12; } - if( LAPACKE_zge_nancheck( matrix_layout, ldv, k, v, ldv ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, nrows_v, ncols_v, v, ldv ) ) { return -10; } #endif @@ -71,11 +84,11 @@ lapack_int LAPACKE_ztprfb( int matrix_layout, char side, char trans, char direct else { ldwork = m; work_size = MAX(1,ldwork) * MAX(1,k); - } - + } + /* Allocate memory for working array(s) */ work = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * work_size ); + LAPACKE_malloc( sizeof(lapack_complex_double) * work_size ); if( work == NULL ) { info = LAPACK_WORK_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_ztrexc_work.c b/lapack-netlib/LAPACKE/src/lapacke_ztrexc_work.c index d6783e94a3..d19746ac5d 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_ztrexc_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_ztrexc_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function ztrexc * Author: Intel Corporation -* Generated November 2015 +* Generated December 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -51,7 +51,7 @@ lapack_int LAPACKE_ztrexc_work( int matrix_layout, char compq, lapack_int n, lapack_complex_double* t_t = NULL; lapack_complex_double* q_t = NULL; /* Check leading dimension(s) */ - if( ldq < n ) { + if( ldq < n && LAPACKE_lsame( compq, 'v' ) ) { info = -7; LAPACKE_xerbla( "LAPACKE_ztrexc_work", info ); return info; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1.c b/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1.c index ddf944e09f..f5dbd55bef 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native high-level C interface to LAPACK function zuncsd2by1 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -37,7 +37,7 @@ lapack_int LAPACKE_zuncsd2by1( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_double* x11, lapack_int ldx11, lapack_complex_double* x21, lapack_int ldx21, - lapack_complex_double* theta, lapack_complex_double* u1, + double* theta, lapack_complex_double* u1, lapack_int ldu1, lapack_complex_double* u2, lapack_int ldu2, lapack_complex_double* v1t, lapack_int ldv1t ) { @@ -74,7 +74,7 @@ lapack_int LAPACKE_zuncsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_0; } /* Query optimal working array(s) size */ - info = LAPACKE_zuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_zuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, &work_query, lwork, &rwork_query, lrwork, iwork ); @@ -95,7 +95,7 @@ lapack_int LAPACKE_zuncsd2by1( int matrix_layout, char jobu1, char jobu2, goto exit_level_2; } /* Call middle-level interface */ - info = LAPACKE_zuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, + info = LAPACKE_zuncsd2by1_work( matrix_layout, jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork ); /* Release memory and exit */ diff --git a/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1_work.c b/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1_work.c index 437a90e8df..6d3296100f 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zuncsd2by1_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zuncsd2by1 * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -37,10 +37,10 @@ lapack_int LAPACKE_zuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, char jobv1t, lapack_int m, lapack_int p, lapack_int q, lapack_complex_double* x11, lapack_int ldx11, lapack_complex_double* x21, lapack_int ldx21, - lapack_complex_double* theta, lapack_complex_double* u1, - lapack_int ldu1, lapack_complex_double* u2, + double* theta, lapack_complex_double* u1, + lapack_int ldu1, lapack_complex_double* u2, lapack_int ldu2, lapack_complex_double* v1t, - lapack_int ldv1t, lapack_complex_double* work, + lapack_int ldv1t, lapack_complex_double* work, lapack_int lwork, double* rwork, lapack_int lrwork, lapack_int* iwork ) { @@ -48,8 +48,8 @@ lapack_int LAPACKE_zuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, if( matrix_layout == LAPACK_COL_MAJOR ) { /* Call LAPACK function and adjust info */ LAPACK_zuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11, x21, &ldx21, + theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, work, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; @@ -99,8 +99,8 @@ lapack_int LAPACKE_zuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, /* Query optimal working array(s) size if requested */ if( lrwork == -1 || lwork == -1 ) { LAPACK_zuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11, &ldx11_t, x21, &ldx21_t, + theta, u1, &ldu1_t, u2, &ldu2_t, v1t, &ldv1t_t, work, &lwork, rwork, &lrwork, iwork, &info ); return (info < 0) ? (info - 1) : info; } @@ -146,8 +146,8 @@ lapack_int LAPACKE_zuncsd2by1_work( int matrix_layout, char jobu1, char jobu2, ldx21_t ); /* Call LAPACK function and adjust info */ LAPACK_zuncsd2by1( &jobu1, &jobu2, &jobv1t, &m, &p, - &q, x11, &ldx11, x21, &ldx21, - theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, + &q, x11_t, &ldx11_t, x21_t, &ldx21_t, + theta, u1_t, &ldu1_t, u2_t, &ldu2_t, v1t_t, &ldv1t_t, work, &lwork, rwork, &lrwork, iwork, &info ); if( info < 0 ) { info = info - 1; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zunmbr_work.c b/lapack-netlib/LAPACKE/src/lapacke_zunmbr_work.c index 3558974bc4..13191a90c3 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zunmbr_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zunmbr_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zunmbr * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -74,9 +74,11 @@ lapack_int LAPACKE_zunmbr_work( int matrix_layout, char vect, char side, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - a_t = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * - lda_t * MAX(1,MIN(nq,k)) ); + if( LAPACKE_lsame( vect, 'q' ) ) { + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,k) ); + } else { + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,nq) ); + } if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/src/lapacke_zunmlq_work.c b/lapack-netlib/LAPACKE/src/lapacke_zunmlq_work.c index bc2e16ccfe..f51fbc8441 100644 --- a/lapack-netlib/LAPACKE/src/lapacke_zunmlq_work.c +++ b/lapack-netlib/LAPACKE/src/lapacke_zunmlq_work.c @@ -28,7 +28,7 @@ ***************************************************************************** * Contents: Native middle-level C interface to LAPACK function zunmlq * Author: Intel Corporation -* Generated November 2015 +* Generated June 2016 *****************************************************************************/ #include "lapacke_utils.h" @@ -73,8 +73,13 @@ lapack_int LAPACKE_zunmlq_work( int matrix_layout, char side, char trans, return (info < 0) ? (info - 1) : info; } /* Allocate memory for temporary array(s) */ - a_t = (lapack_complex_double*) - LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,m) ); + if( LAPACKE_lsame( side, 'l' ) ) { + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,m) ); + } else { + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + } if( a_t == NULL ) { info = LAPACK_TRANSPOSE_MEMORY_ERROR; goto exit_level_0; diff --git a/lapack-netlib/LAPACKE/utils/CMakeLists.txt b/lapack-netlib/LAPACKE/utils/CMakeLists.txt index f7d294fbb9..c8b8511e7a 100644 --- a/lapack-netlib/LAPACKE/utils/CMakeLists.txt +++ b/lapack-netlib/LAPACKE/utils/CMakeLists.txt @@ -1,4 +1,4 @@ -set (UTILS_OBJ +set(UTILS_OBJ lapacke_c_nancheck.c lapacke_ctr_trans.c lapacke_make_complex_float.c lapacke_zgb_nancheck.c lapacke_cgb_nancheck.c lapacke_d_nancheck.c lapacke_s_nancheck.c lapacke_zgb_trans.c lapacke_cgb_trans.c lapacke_dgb_nancheck.c lapacke_sgb_nancheck.c lapacke_zge_nancheck.c @@ -30,10 +30,10 @@ lapacke_cst_nancheck.c lapacke_dtb_nancheck.c lapacke_stb_nanc lapacke_csy_nancheck.c lapacke_dtb_trans.c lapacke_stb_trans.c lapacke_zsy_trans.c lapacke_csy_trans.c lapacke_dtf_nancheck.c lapacke_stf_nancheck.c lapacke_ztb_nancheck.c lapacke_ctb_nancheck.c lapacke_dtf_trans.c lapacke_stf_trans.c lapacke_ztb_trans.c -lapacke_ctb_trans.c lapacke_dtp_nancheck.c lapacke_stp_nancheck.c lapacke_ztf_nancheck.c +lapacke_ctb_trans.c lapacke_dtp_nancheck.c lapacke_stp_nancheck.c lapacke_ztf_nancheck.c lapacke_ctf_nancheck.c lapacke_dtp_trans.c lapacke_stp_trans.c lapacke_ztf_trans.c lapacke_ctf_trans.c lapacke_dtr_nancheck.c lapacke_str_nancheck.c lapacke_ztp_nancheck.c lapacke_ctp_nancheck.c lapacke_dtr_trans.c lapacke_str_trans.c lapacke_ztp_trans.c lapacke_ctp_trans.c lapacke_lsame.c lapacke_xerbla.c lapacke_ztr_nancheck.c lapacke_ctr_nancheck.c lapacke_make_complex_double.c lapacke_z_nancheck.c lapacke_ztr_trans.c -) \ No newline at end of file +) diff --git a/lapack-netlib/LAPACKE/utils/Makefile b/lapack-netlib/LAPACKE/utils/Makefile index 1d78567897..57b8f0dd1e 100644 --- a/lapack-netlib/LAPACKE/utils/Makefile +++ b/lapack-netlib/LAPACKE/utils/Makefile @@ -190,7 +190,7 @@ lib: $(OBJ) $(RANLIB) ../../$(LAPACKELIB) .c.o: - $(CC) -c $(CFLAGS) -I ../include -o $@ $< + $(CC) $(CFLAGS) -I../include -c -o $@ $< clean: rm -f *.o diff --git a/lapack-netlib/LAPACKE/utils/lapacke_cgb_nancheck.c b/lapack-netlib/LAPACKE/utils/lapacke_cgb_nancheck.c index 9446b355ad..400e806f2a 100644 --- a/lapack-netlib/LAPACKE/utils/lapacke_cgb_nancheck.c +++ b/lapack-netlib/LAPACKE/utils/lapacke_cgb_nancheck.c @@ -46,14 +46,14 @@ lapack_logical LAPACKE_cgb_nancheck( int matrix_layout, lapack_int m, if( matrix_layout == LAPACK_COL_MAJOR ) { for( j = 0; j < n; j++ ) { - for( i = MAX( ku-j, 0 ); i < MIN3( ldab, m+ku-j, kl+ku+1 ); + for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_CISNAN( ab[i+(size_t)j*ldab] ) ) return (lapack_logical) 1; } } } else if ( matrix_layout == LAPACK_ROW_MAJOR ) { - for( j = 0; j < MIN( n, ldab ); j++ ) { + for( j = 0; j < n; j++ ) { for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_CISNAN( ab[(size_t)i*ldab+j] ) ) return (lapack_logical) 1; diff --git a/lapack-netlib/LAPACKE/utils/lapacke_dgb_nancheck.c b/lapack-netlib/LAPACKE/utils/lapacke_dgb_nancheck.c index 5fa13e75dc..e94d488d73 100644 --- a/lapack-netlib/LAPACKE/utils/lapacke_dgb_nancheck.c +++ b/lapack-netlib/LAPACKE/utils/lapacke_dgb_nancheck.c @@ -46,14 +46,14 @@ lapack_logical LAPACKE_dgb_nancheck( int matrix_layout, lapack_int m, if( matrix_layout == LAPACK_COL_MAJOR ) { for( j = 0; j < n; j++ ) { - for( i = MAX( ku-j, 0 ); i < MIN3( ldab, m+ku-j, kl+ku+1 ); + for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_DISNAN( ab[i+(size_t)j*ldab] ) ) return (lapack_logical) 1; } } } else if ( matrix_layout == LAPACK_ROW_MAJOR ) { - for( j = 0; j < MIN( n, ldab ); j++ ) { + for( j = 0; j < n; j++ ) { for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_DISNAN( ab[(size_t)i*ldab+j] ) ) return (lapack_logical) 1; diff --git a/lapack-netlib/LAPACKE/utils/lapacke_sgb_nancheck.c b/lapack-netlib/LAPACKE/utils/lapacke_sgb_nancheck.c index dcebcf6b57..e20cb2421c 100644 --- a/lapack-netlib/LAPACKE/utils/lapacke_sgb_nancheck.c +++ b/lapack-netlib/LAPACKE/utils/lapacke_sgb_nancheck.c @@ -46,14 +46,14 @@ lapack_logical LAPACKE_sgb_nancheck( int matrix_layout, lapack_int m, if( matrix_layout == LAPACK_COL_MAJOR ) { for( j = 0; j < n; j++ ) { - for( i = MAX( ku-j, 0 ); i < MIN3( ldab, m+ku-j, kl+ku+1 ); + for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_SISNAN( ab[i+(size_t)j*ldab] ) ) return (lapack_logical) 1; } } } else if ( matrix_layout == LAPACK_ROW_MAJOR ) { - for( j = 0; j < MIN( n, ldab ); j++ ) { + for( j = 0; j < n; j++ ) { for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_SISNAN( ab[(size_t)i*ldab+j] ) ) return (lapack_logical) 1; diff --git a/lapack-netlib/LAPACKE/utils/lapacke_zgb_nancheck.c b/lapack-netlib/LAPACKE/utils/lapacke_zgb_nancheck.c index 019a73578b..8f0ffc1d69 100644 --- a/lapack-netlib/LAPACKE/utils/lapacke_zgb_nancheck.c +++ b/lapack-netlib/LAPACKE/utils/lapacke_zgb_nancheck.c @@ -46,14 +46,14 @@ lapack_logical LAPACKE_zgb_nancheck( int matrix_layout, lapack_int m, if( matrix_layout == LAPACK_COL_MAJOR ) { for( j = 0; j < n; j++ ) { - for( i = MAX( ku-j, 0 ); i < MIN3( ldab, m+ku-j, kl+ku+1 ); + for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_ZISNAN( ab[i+(size_t)j*ldab] ) ) return (lapack_logical) 1; } } } else if ( matrix_layout == LAPACK_ROW_MAJOR ) { - for( j = 0; j < MIN( n, ldab ); j++ ) { + for( j = 0; j < n; j++ ) { for( i = MAX( ku-j, 0 ); i < MIN( m+ku-j, kl+ku+1 ); i++ ) { if( LAPACK_ZISNAN( ab[(size_t)i*ldab+j] ) ) return (lapack_logical) 1; diff --git a/lapack-netlib/LICENSE b/lapack-netlib/LICENSE index 8d713b6ae7..eefcbdaee3 100644 --- a/lapack-netlib/LICENSE +++ b/lapack-netlib/LICENSE @@ -1,9 +1,9 @@ -Copyright (c) 1992-2015 The University of Tennessee and The University +Copyright (c) 1992-2016 The University of Tennessee and The University of Tennessee Research Foundation. All rights reserved. -Copyright (c) 2000-2015 The University of California Berkeley. All +Copyright (c) 2000-2016 The University of California Berkeley. All rights reserved. -Copyright (c) 2006-2015 The University of Colorado Denver. All rights +Copyright (c) 2006-2016 The University of Colorado Denver. All rights reserved. $COPYRIGHT$ diff --git a/lapack-netlib/Makefile b/lapack-netlib/Makefile index 3b0b660836..edde5ff9c4 100644 --- a/lapack-netlib/Makefile +++ b/lapack-netlib/Makefile @@ -14,13 +14,15 @@ lib: lapacklib tmglib clean: cleanlib cleantesting cleanblas_testing cleancblas_testing lapack_install: - ( cd INSTALL; $(MAKE); ) + ( cd INSTALL; $(MAKE) ) +# ./testlsame; ./testslamch; ./testdlamch; \ +# ./testsecond; ./testdsecnd; ./testieee; ./testversion ) blaslib: ( cd BLAS/SRC; $(MAKE) ) cblaslib: - ( cd CBLAS/src; $(MAKE) ) + ( cd CBLAS; $(MAKE) ) lapacklib: lapack_install ( cd SRC; $(MAKE) ) @@ -116,7 +118,7 @@ cleanblas_testing: ( cd BLAS; rm -f xblat* ) cleancblas_testing: - ( cd CBLAS; $(MAKE) cleanexe ) + ( cd CBLAS/testing; $(MAKE) clean ) cleantesting: ( cd TESTING/LIN; $(MAKE) clean ) diff --git a/lapack-netlib/README b/lapack-netlib/README.md similarity index 65% rename from lapack-netlib/README rename to lapack-netlib/README.md index 9f5562a5c6..0864929420 100644 --- a/lapack-netlib/README +++ b/lapack-netlib/README.md @@ -1,27 +1,29 @@ -================== -LAPACK README FILE -================== - -VERSION 1.0 : February 29, 1992 -VERSION 1.0a : June 30, 1992 -VERSION 1.0b : October 31, 1992 -VERSION 1.1 : March 31, 1993 -VERSION 2.0 : September 30, 1994 -VERSION 3.0 : June 30, 1999 -VERSION 3.0 + update : October 31, 1999 -VERSION 3.0 + update : May 31, 2000 -VERSION 3.1 : November 2006 -VERSION 3.1.1 : February 2007 -VERSION 3.2 : November 2008 -VERSION 3.2.1 : April 2009 -VERSION 3.2.2 : June 2010 -VERSION 3.3.0 : November 2010 -VERSION 3.3.1 : April 2011 -VERSION 3.4.0 : November 2011 -VERSION 3.4.1 : April 2012 -VERSION 3.4.2 : September 2012 -VERSION 3.5.0 : November 2013 -VERSION 3.6.0 : November 2015 +# LAPACK + +[![Build Status](https://travis-ci.org/Reference-LAPACK/lapack.svg?branch=master)](https://travis-ci.org/Reference-LAPACK/lapack) + +* VERSION 1.0 : February 29, 1992 +* VERSION 1.0a : June 30, 1992 +* VERSION 1.0b : October 31, 1992 +* VERSION 1.1 : March 31, 1993 +* VERSION 2.0 : September 30, 1994 +* VERSION 3.0 : June 30, 1999 +* VERSION 3.0 + update : October 31, 1999 +* VERSION 3.0 + update : May 31, 2000 +* VERSION 3.1 : November 2006 +* VERSION 3.1.1 : February 2007 +* VERSION 3.2 : November 2008 +* VERSION 3.2.1 : April 2009 +* VERSION 3.2.2 : June 2010 +* VERSION 3.3.0 : November 2010 +* VERSION 3.3.1 : April 2011 +* VERSION 3.4.0 : November 2011 +* VERSION 3.4.1 : April 2012 +* VERSION 3.4.2 : September 2012 +* VERSION 3.5.0 : November 2013 +* VERSION 3.6.0 : November 2015 +* VERSION 3.6.1 : June 2016 +* VERSION 3.7.0 : December 2016 LAPACK is a library of Fortran 90 with subroutines for solving the most commonly occurring problems in numerical linear algebra. @@ -40,47 +42,44 @@ intended for use only if there is no other implementation of the BLAS already available on your machine; the efficiency of LAPACK depends very much on the efficiency of the BLAS. -================= -LAPACK INSTALLATION: - - LAPACK can be installed with make. Configuration have to be set in the - make.inc file. A make.inc.example for a Linux machine running GNU compilers - is given in the main directory. Some specific make.inc are also available in - the INSTALL directory - - LAPACK includes also the CMAKE build. You will need to have CMAKE installed - on your machine (CMAKE is available at http://www.cmake.org/). CMAKE will allow - an easy installation on a Windows Machine - - Specific information to run LAPACK under Windows are available at - http://icl.cs.utk.edu/lapack-for-windows/lapack/ - +## Installation + + - LAPACK can be installed with `make`. Configuration have to be set in the + `make.inc` file. A `make.inc.example` for a Linux machine running GNU compilers + is given in the main directory. Some specific `make.inc` are also available in + the `INSTALL` directory. + - LAPACK includes also the CMake build. You will need to have CMake installed + on your machine (CMake is available at http://www.cmake.org/). CMake will + allow an easy installation on a Windows Machine. + - Specific information to run LAPACK under Windows are available at + http://icl.cs.utk.edu/lapack-for-windows/lapack/. + For further information on LAPACK please read our FAQ at http://www.netlib.org/lapack/#_faq A User forum is also available to help you with the LAPACK library at http://icl.cs.utk.edu/lapack-forum/ -================ - - -================ -LAPACK User Support - + + +## User Support + LAPACK has been thoroughly tested, on many different types of computers. The LAPACK project supports the package in the sense that reports of errors or poor performance will gain immediate -attention from the developers. Such reports, descriptions +attention from the developers. Such reports, descriptions of interesting applications, and other comments should be sent by electronic mail to lapack@cs.utk.edu. A list of known problems, bugs, and compiler errors for LAPACK is maintained on netlib. - http://www.netlib.org/lapack/release_notes.html - + * http://www.netlib.org/lapack/release_notes.html + A User forum is also available to help you with the LAPACK library at - http://icl.cs.utk.edu/lapack-forum/ -You can also contact directly the LAPACK team at lapack@cs.utk.edu -================ - - -================ -LAPACK TESTING + http://icl.cs.utk.edu/lapack-forum/. +You can also contact directly the LAPACK team at lapack@cs.utk.edu. + + +## Testing + The complete package, including test code in four different Fortran data types (real, complex, double precision, double complex), contains some 805,000 lines of Fortran source and comments. @@ -91,17 +90,16 @@ types, including the object files, is approximately 80 Mbytes. A README file containing the information in this letter is located in the LAPACK directory. Postscript and LaTeX versions of the Quick -Installation Guide are in the LAPACK/INSTALL directory, in the files -lawn81.tex, psfig.tex, lawn81.ps, and org2.ps. Consult the Installation +Installation Guide are in the `LAPACK/INSTALL` directory, in the files +`lawn81.tex`, `psfig.tex`, `lawn81.ps`, and `org2.ps`. Consult the Installation Guide for further details on installing the package and on what is contained in each subdirectory. For complete information on the LAPACK Testing please consult LAPACK Working Note 41 "Installation Guide for LAPACK". -================ -================ -LAPACK USER GUIDE +## User Guide + It is highly recommended that you obtain a copy of the Third Edition of the LAPACK Users' Guide published by SIAM in Winter, 1999. This Users' Guide gives a detailed description of the philosophy behind LAPACK as well @@ -117,55 +115,42 @@ price for SIAM members is $31.20; the cost for nonmembers is $39.00. To view an HTML version of the Users' Guide please refer to the URL http://www.netlib.org/lapack/lug/lapack_lug.html. -================ -================ -LAPACKE +## LAPACKE LAPACK now includes the LAPACKE package LAPACKE is a Standard C language APIs for LAPACK http://www.netlib.org/lapack/#_standard_c_language_apis_for_lapack collaboration LAPACK and INTEL Math Kernel Library Documentation available in the DOCS folder -================ -================ -RELATED LAPACK PROJECTS +## Related Projects The Fortran95 interface to LAPACK is available, as well as an f2c'ed version of LAPACK, and a C++ version of a subset of LAPACK routines. Refer to the following URLs on netlib for further information: - http://www.netlib.org/lapack95/ - http://www.netlib.org/clapack/ - http://www.netlib.org/lapack++/ - http://www.cs.utk.edu/java/f2j/ + * http://www.netlib.org/lapack95/ + * http://www.netlib.org/clapack/ + * http://www.netlib.org/lapack++/ + * http://www.cs.utk.edu/java/f2j/ Or, for more information on the distributed-memory version of LAPACK, consult the ScaLAPACK index on netlib: http://www.netlib.org/scalapack/ -================ -================ -LAPACK WORKING NOTES +## Working Notes A number of technical reports were written during the development of LAPACK and published as LAPACK Working Notes, initially by Argonne -National Laboratory and later by the University of Tennessee. Many of +National Laboratory and later by the University of Tennessee. Many of these reports later appeared as journal articles. Most of these working notes are available in pdf and postscript form from netlib. - http://www.netlib.org/lapack/lawns/ - http://www.netlib.org/lapack/lawnspdf/ + * http://www.netlib.org/lapack/lawns/ + * http://www.netlib.org/lapack/lawnspdf/ Otherwise, requests for copies of these working notes can be sent to the following address. -LAPACK Project -c/o J.J. Dongarra -Computer Science Department -University of Tennessee -Knoxville, Tennessee 37996-1301 -USA -Email: lapack@cs.utk.edu -================ +LAPACK Project, c/o J.J. Dongarra, Computer Science Department, University of Tennessee, Knoxville, Tennessee 37996-1301, USA, Email: lapack@cs.utk.edu. diff --git a/lapack-netlib/SRC/CMakeLists.txt b/lapack-netlib/SRC/CMakeLists.txt index 03441b9426..4d7081cf29 100644 --- a/lapack-netlib/SRC/CMakeLists.txt +++ b/lapack-netlib/SRC/CMakeLists.txt @@ -1,25 +1,33 @@ ####################################################################### # This is the makefile to create a library for LAPACK. # The files are organized as follows: -# ALLAUX -- Auxiliary routines called from all precisions -# ALLXAUX -- Auxiliary routines called from all precisions but -# only from routines using extra precision. -# SCLAUX -- Auxiliary routines called from both REAL and COMPLEX -# DZLAUX -- Auxiliary routines called from both DOUBLE PRECISION -# and COMPLEX*16 -# SLASRC -- Single precision real LAPACK routines +# ALLAUX -- Auxiliary routines called from all precisions +# +# SCLAUX -- Auxiliary routines called from both REAL and COMPLEX. +# DZLAUX -- Auxiliary routines called from both DOUBLE and COMPLEX*16. +# +# DSLASRC -- Double-single mixed precision real routines called from +# single, single-extra and double precision real LAPACK +# routines (i.e. from SLASRC, SXLASRC, DLASRC). +# ZCLASRC -- Double-single mixed precision complex routines called from +# single, single-extra and double precision complex LAPACK +# routines (i.e. from CLASRC, CXLASRC, ZLASRC). +# +# SLASRC -- Single precision real LAPACK routines # SXLASRC -- Single precision real LAPACK routines using extra # precision. -# CLASRC -- Single precision complex LAPACK routines +# CLASRC -- Single precision complex LAPACK routines # CXLASRC -- Single precision complex LAPACK routines using extra # precision. -# DLASRC -- Double precision real LAPACK routines +# DLASRC -- Double precision real LAPACK routines # DXLASRC -- Double precision real LAPACK routines using extra # precision. -# ZLASRC -- Double precision complex LAPACK routines +# ZLASRC -- Double precision complex LAPACK routines # ZXLASRC -- Double precision complex LAPACK routines using extra # precision. # +# DEPRECATED -- Deprecated routines in all precisions +# # The library can be set up to include routines for any combination # of the four precisions. To create or add to the library, enter make # followed by one or more of the precisions desired. Some examples: @@ -46,409 +54,460 @@ # ####################################################################### -set(ALLAUX ilaenv.f ieeeck.f lsamen.f iparmq.f - ilaprec.f ilatrans.f ilauplo.f iladiag.f chla_transtype.f - ../INSTALL/ilaver.f ../INSTALL/lsame.f xerbla.f xerbla_array.f - ../INSTALL/slamch.f) - -set(ALLXAUX ) +set(ALLAUX ilaenv.f ieeeck.f lsamen.f iparmq.f iparam2stage.F + ilaprec.f ilatrans.f ilauplo.f iladiag.f chla_transtype.f + ../INSTALL/ilaver.f ../INSTALL/lsame.f xerbla.f xerbla_array.f + ../INSTALL/slamch.f) -set(SCLAUX - sbdsdc.f - sbdsqr.f sdisna.f slabad.f slacpy.f sladiv.f slae2.f slaebz.f - slaed0.f slaed1.f slaed2.f slaed3.f slaed4.f slaed5.f slaed6.f - slaed7.f slaed8.f slaed9.f slaeda.f slaev2.f slagtf.f - slagts.f slamrg.f slanst.f - slapy2.f slapy3.f slarnv.f - slarra.f slarrb.f slarrc.f slarrd.f slarre.f slarrf.f slarrj.f - slarrk.f slarrr.f slaneg.f - slartg.f slaruv.f slas2.f slascl.f - slasd0.f slasd1.f slasd2.f slasd3.f slasd4.f slasd5.f slasd6.f - slasd7.f slasd8.f slasda.f slasdq.f slasdt.f - slaset.f slasq1.f slasq2.f slasq3.f slasq4.f slasq5.f slasq6.f - slasr.f slasrt.f slassq.f slasv2.f spttrf.f sstebz.f sstedc.f - ssteqr.f ssterf.f slaisnan.f sisnan.f - slartgp.f slartgs.f +set(SCLAUX + sbdsdc.f + sbdsqr.f sdisna.f slabad.f slacpy.f sladiv.f slae2.f slaebz.f + slaed0.f slaed1.f slaed2.f slaed3.f slaed4.f slaed5.f slaed6.f + slaed7.f slaed8.f slaed9.f slaeda.f slaev2.f slagtf.f + slagts.f slamrg.f slanst.f + slapy2.f slapy3.f slarnv.f + slarra.f slarrb.f slarrc.f slarrd.f slarre.f slarrf.f slarrj.f + slarrk.f slarrr.f slaneg.f + slartg.f slaruv.f slas2.f slascl.f + slasd0.f slasd1.f slasd2.f slasd3.f slasd4.f slasd5.f slasd6.f + slasd7.f slasd8.f slasda.f slasdq.f slasdt.f + slaset.f slasq1.f slasq2.f slasq3.f slasq4.f slasq5.f slasq6.f + slasr.f slasrt.f slassq.f slasv2.f spttrf.f sstebz.f sstedc.f + ssteqr.f ssterf.f slaisnan.f sisnan.f + slartgp.f slartgs.f ${SECOND_SRC}) -set(DZLAUX - dbdsdc.f - dbdsqr.f ddisna.f dlabad.f dlacpy.f dladiv.f dlae2.f dlaebz.f - dlaed0.f dlaed1.f dlaed2.f dlaed3.f dlaed4.f dlaed5.f dlaed6.f - dlaed7.f dlaed8.f dlaed9.f dlaeda.f dlaev2.f dlagtf.f - dlagts.f dlamrg.f dlanst.f - dlapy2.f dlapy3.f dlarnv.f - dlarra.f dlarrb.f dlarrc.f dlarrd.f dlarre.f dlarrf.f dlarrj.f - dlarrk.f dlarrr.f dlaneg.f - dlartg.f dlaruv.f dlas2.f dlascl.f - dlasd0.f dlasd1.f dlasd2.f dlasd3.f dlasd4.f dlasd5.f dlasd6.f - dlasd7.f dlasd8.f dlasda.f dlasdq.f dlasdt.f - dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f - dlasr.f dlasrt.f dlassq.f dlasv2.f dpttrf.f dstebz.f dstedc.f - dsteqr.f dsterf.f dlaisnan.f disnan.f +set(DZLAUX + dbdsdc.f + dbdsqr.f ddisna.f dlabad.f dlacpy.f dladiv.f dlae2.f dlaebz.f + dlaed0.f dlaed1.f dlaed2.f dlaed3.f dlaed4.f dlaed5.f dlaed6.f + dlaed7.f dlaed8.f dlaed9.f dlaeda.f dlaev2.f dlagtf.f + dlagts.f dlamrg.f dlanst.f + dlapy2.f dlapy3.f dlarnv.f + dlarra.f dlarrb.f dlarrc.f dlarrd.f dlarre.f dlarrf.f dlarrj.f + dlarrk.f dlarrr.f dlaneg.f + dlartg.f dlaruv.f dlas2.f dlascl.f + dlasd0.f dlasd1.f dlasd2.f dlasd3.f dlasd4.f dlasd5.f dlasd6.f + dlasd7.f dlasd8.f dlasda.f dlasdq.f dlasdt.f + dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f + dlasr.f dlasrt.f dlassq.f dlasv2.f dpttrf.f dstebz.f dstedc.f + dsteqr.f dsterf.f dlaisnan.f disnan.f dlartgp.f dlartgs.f ../INSTALL/dlamch.f ${DSECOND_SRC}) -set(SLASRC - sbdsvdx.f sgbbrd.f sgbcon.f sgbequ.f sgbrfs.f sgbsv.f - sgbsvx.f sgbtf2.f sgbtrf.f sgbtrs.f sgebak.f sgebal.f sgebd2.f - sgebrd.f sgecon.f sgeequ.f sgees.f sgeesx.f sgeev.f sgeevx.f - sgehd2.f sgehrd.f sgelq2.f sgelqf.f - sgels.f sgelsd.f sgelss.f sgelsy.f sgeql2.f sgeqlf.f - sgeqp3.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f - sgesc2.f sgesdd.f sgesv.f sgesvd.f sgesvdx.f sgesvx.f sgetc2.f sgetf2.f - sgetrf.f sgetrf2.f sgetri.f +set(SLASRC + sbdsvdx.f sgbbrd.f sgbcon.f sgbequ.f sgbrfs.f sgbsv.f + sgbsvx.f sgbtf2.f sgbtrf.f sgbtrs.f sgebak.f sgebal.f sgebd2.f + sgebrd.f sgecon.f sgeequ.f sgees.f sgeesx.f sgeev.f sgeevx.f + sgehd2.f sgehrd.f sgelq2.f sgelqf.f + sgels.f sgelsd.f sgelss.f sgelsy.f sgeql2.f sgeqlf.f + sgeqp3.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f + sgesc2.f sgesdd.f sgesv.f sgesvd.f sgesvdx.f sgesvx.f sgetc2.f sgetf2.f + sgetrf.f sgetrf2.f sgetri.f sgetrs.f sggbak.f sggbal.f sgges.f sgges3.f sggesx.f sggev.f sggev3.f sggevx.f - sggglm.f sgghrd.f sgghd3.f sgglse.f sggqrf.f - sggrqf.f sggsvd3.f sggsvp3.f sgtcon.f sgtrfs.f sgtsv.f - sgtsvx.f sgttrf.f sgttrs.f sgtts2.f shgeqz.f - shsein.f shseqr.f slabrd.f slacon.f slacn2.f - slaein.f slaexc.f slag2.f slags2.f slagtm.f slagv2.f slahqr.f - slahr2.f slaic1.f slaln2.f slals0.f slalsa.f slalsd.f - slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f - slansy.f slantb.f slantp.f slantr.f slanv2.f - slapll.f slapmt.f - slaqgb.f slaqge.f slaqp2.f slaqps.f slaqsb.f slaqsp.f slaqsy.f - slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f - slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f - slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f - slarrv.f slartv.f - slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f - slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f - slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f - sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f - sorgrq.f sorgtr.f sorm2l.f sorm2r.f sorm22.f - sormbr.f sormhr.f sorml2.f sormlq.f sormql.f sormqr.f sormr2.f - sormr3.f sormrq.f sormrz.f sormtr.f spbcon.f spbequ.f spbrfs.f - spbstf.f spbsv.f spbsvx.f - spbtf2.f spbtrf.f spbtrs.f spocon.f spoequ.f sporfs.f sposv.f - sposvx.f spotf2.f spotrf.f spotrf2.f spotri.f spotrs.f spstrf.f spstf2.f - sppcon.f sppequ.f - spprfs.f sppsv.f sppsvx.f spptrf.f spptri.f spptrs.f sptcon.f - spteqr.f sptrfs.f sptsv.f sptsvx.f spttrs.f sptts2.f srscl.f - ssbev.f ssbevd.f ssbevx.f ssbgst.f ssbgv.f ssbgvd.f ssbgvx.f - ssbtrd.f sspcon.f sspev.f sspevd.f sspevx.f sspgst.f - sspgv.f sspgvd.f sspgvx.f ssprfs.f sspsv.f sspsvx.f ssptrd.f - ssptrf.f ssptri.f ssptrs.f sstegr.f sstein.f sstev.f sstevd.f sstevr.f - sstevx.f ssycon.f ssyev.f ssyevd.f ssyevr.f ssyevx.f ssygs2.f - ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f + sggglm.f sgghrd.f sgghd3.f sgglse.f sggqrf.f + sggrqf.f sggsvd3.f sggsvp3.f sgtcon.f sgtrfs.f sgtsv.f + sgtsvx.f sgttrf.f sgttrs.f sgtts2.f shgeqz.f + shsein.f shseqr.f slabrd.f slacon.f slacn2.f + slaein.f slaexc.f slag2.f slags2.f slagtm.f slagv2.f slahqr.f + slahr2.f slaic1.f slaln2.f slals0.f slalsa.f slalsd.f + slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f + slansy.f slantb.f slantp.f slantr.f slanv2.f + slapll.f slapmt.f + slaqgb.f slaqge.f slaqp2.f slaqps.f slaqsb.f slaqsp.f slaqsy.f + slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f + slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f + slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f + slarrv.f slartv.f + slarz.f slarzb.f slarzt.f slaswp.f slasy2.f + slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f + slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f + slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f + sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f + sorgrq.f sorgtr.f sorm2l.f sorm2r.f sorm22.f + sormbr.f sormhr.f sorml2.f sormlq.f sormql.f sormqr.f sormr2.f + sormr3.f sormrq.f sormrz.f sormtr.f spbcon.f spbequ.f spbrfs.f + spbstf.f spbsv.f spbsvx.f + spbtf2.f spbtrf.f spbtrs.f spocon.f spoequ.f sporfs.f sposv.f + sposvx.f spotf2.f spotrf.f spotrf2.f spotri.f spotrs.f spstrf.f spstf2.f + sppcon.f sppequ.f + spprfs.f sppsv.f sppsvx.f spptrf.f spptri.f spptrs.f sptcon.f + spteqr.f sptrfs.f sptsv.f sptsvx.f spttrs.f sptts2.f srscl.f + ssbev.f ssbevd.f ssbevx.f ssbgst.f ssbgv.f ssbgvd.f ssbgvx.f + ssbtrd.f sspcon.f sspev.f sspevd.f sspevx.f sspgst.f + sspgv.f sspgvd.f sspgvx.f ssprfs.f sspsv.f sspsvx.f ssptrd.f + ssptrf.f ssptri.f ssptrs.f sstegr.f sstein.f sstev.f sstevd.f sstevr.f + sstevx.f ssycon.f ssyev.f ssyevd.f ssyevr.f ssyevx.f ssygs2.f + ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f - ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f + ssyswapr.f ssytrs.f ssytrs2.f + ssyconv.f ssyconvf.f ssyconvf_rook.f + ssysv_aa.f ssytrf_aa.f ssytrs_aa.f ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f ssytri_rook.f ssycon_rook.f ssysv_rook.f - stbcon.f - stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f - stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f - stptrs.f - strcon.f strevc.f strexc.f strrfs.f strsen.f strsna.f strsyl.f - strti2.f strtri.f strtrs.f stzrzf.f sstemr.f - slansf.f spftrf.f spftri.f spftrs.f ssfrk.f stfsm.f stftri.f stfttp.f - stfttr.f stpttf.f stpttr.f strttf.f strttp.f - sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f + ssytf2_rk.f ssytrf_rk.f ssytrs_3.f + ssytri_3.f ssytri_3x.f ssycon_3.f ssysv_rk.f + ssysv_aa.f ssytrf_aa.f ssytrs_aa.f + stbcon.f + stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f + stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f + stptrs.f + strcon.f strevc.f strevc3.f strexc.f strrfs.f strsen.f strsna.f strsyl.f + strti2.f strtri.f strtrs.f stzrzf.f sstemr.f + slansf.f spftrf.f spftri.f spftrs.f ssfrk.f stfsm.f stftri.f stfttp.f + stfttr.f stpttf.f stpttr.f strttf.f strttp.f + sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f sgeequb.f ssyequb.f spoequb.f sgbequb.f sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f stpqrt.f stpqrt2.f stpmqrt.f stprfb.f - ) + sgelqt.f sgelqt3.f sgemlqt.f + sgetsls.f sgeqr.f slatsqr.f slamtsqr.f sgemqr.f + sgelq.f slaswlq.f slamswlq.f sgemlq.f + stplqt.f stplqt2.f stpmlqt.f + ssytrd_2stage.f ssytrd_sy2sb.f ssytrd_sb2st.F ssb2st_kernels.f + ssyevd_2stage.f ssyev_2stage.f ssyevx_2stage.f ssyevr_2stage.f + ssbev_2stage.f ssbevx_2stage.f ssbevd_2stage.f ssygv_2stage.f) -set(DSLASRC spotrs.f sgetrs.f spotrf.f sgetrf.f) +set(DSLASRC spotrs.f sgetrs.f spotrf.f sgetrf.f) -set(SXLASRC sgesvxx.f sgerfsx.f sla_gerfsx_extended.f sla_geamv.f - sla_gercond.f sla_gerpvgrw.f ssysvxx.f ssyrfsx.f - sla_syrfsx_extended.f sla_syamv.f sla_syrcond.f sla_syrpvgrw.f - sposvxx.f sporfsx.f sla_porfsx_extended.f sla_porcond.f - sla_porpvgrw.f sgbsvxx.f sgbrfsx.f sla_gbrfsx_extended.f - sla_gbamv.f sla_gbrcond.f sla_gbrpvgrw.f sla_lin_berr.f slarscl2.f +set(SXLASRC sgesvxx.f sgerfsx.f sla_gerfsx_extended.f sla_geamv.f + sla_gercond.f sla_gerpvgrw.f ssysvxx.f ssyrfsx.f + sla_syrfsx_extended.f sla_syamv.f sla_syrcond.f sla_syrpvgrw.f + sposvxx.f sporfsx.f sla_porfsx_extended.f sla_porcond.f + sla_porpvgrw.f sgbsvxx.f sgbrfsx.f sla_gbrfsx_extended.f + sla_gbamv.f sla_gbrcond.f sla_gbrpvgrw.f sla_lin_berr.f slarscl2.f slascl2.f sla_wwaddw.f) -set(CLASRC - cbdsqr.f cgbbrd.f cgbcon.f cgbequ.f cgbrfs.f cgbsv.f cgbsvx.f - cgbtf2.f cgbtrf.f cgbtrs.f cgebak.f cgebal.f cgebd2.f cgebrd.f - cgecon.f cgeequ.f cgees.f cgeesx.f cgeev.f cgeevx.f - cgehd2.f cgehrd.f cgelq2.f cgelqf.f - cgels.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f - cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f +set(CLASRC + cbdsqr.f cgbbrd.f cgbcon.f cgbequ.f cgbrfs.f cgbsv.f cgbsvx.f + cgbtf2.f cgbtrf.f cgbtrs.f cgebak.f cgebal.f cgebd2.f cgebrd.f + cgecon.f cgeequ.f cgees.f cgeesx.f cgeev.f cgeevx.f + cgehd2.f cgehrd.f cgelq2.f cgelqf.f + cgels.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f + cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f cgesc2.f cgesdd.f cgesv.f cgesvd.f cgesvdx.f cgesvj.f cgejsv.f cgsvj0.f cgsvj1.f cgesvx.f cgetc2.f cgetf2.f cgetrf.f cgetrf2.f - cgetri.f cgetrs.f + cgetri.f cgetrs.f cggbak.f cggbal.f cgges.f cgges3.f cggesx.f cggev.f cggev3.f cggevx.f - cggglm.f cgghrd.f cgghd3.f cgglse.f cggqrf.f cggrqf.f - cggsvd3.f cggsvp3.f - cgtcon.f cgtrfs.f cgtsv.f cgtsvx.f cgttrf.f cgttrs.f cgtts2.f chbev.f - chbevd.f chbevx.f chbgst.f chbgv.f chbgvd.f chbgvx.f chbtrd.f - checon.f cheev.f cheevd.f cheevr.f cheevx.f chegs2.f chegst.f - chegv.f chegvd.f chegvx.f cherfs.f chesv.f chesvx.f chetd2.f - chetf2.f chetrd.f + cggglm.f cgghrd.f cgghd3.f cgglse.f cggqrf.f cggrqf.f + cggsvd3.f cggsvp3.f + cgtcon.f cgtrfs.f cgtsv.f cgtsvx.f cgttrf.f cgttrs.f cgtts2.f chbev.f + chbevd.f chbevx.f chbgst.f chbgv.f chbgvd.f chbgvx.f chbtrd.f + checon.f cheev.f cheevd.f cheevr.f cheevx.f chegs2.f chegst.f + chegv.f chegvd.f chegvx.f cherfs.f chesv.f chesvx.f chetd2.f + chetf2.f chetrd.f chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f - chetrs.f chetrs2.f - chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f - chgeqz.f chpcon.f chpev.f chpevd.f - chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f - chpsvx.f - chptrd.f chptrf.f chptri.f chptrs.f chsein.f chseqr.f clabrd.f - clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f - claed0.f claed7.f claed8.f - claein.f claesy.f claev2.f clags2.f clagtm.f - clahef.f clahef_rook.f clahqr.f - clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f - clanhb.f clanhe.f - clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f - clantp.f clantr.f clapll.f clapmt.f clarcm.f claqgb.f claqge.f - claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqsb.f - claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f - claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f - clarf.f clarfb.f clarfg.f clarfgp.f clarft.f - clarfx.f clargv.f clarnv.f clarrv.f clartg.f clartv.f - clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f - claswp.f clasyf.f clasyf_rook.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f - clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f - cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f - cposv.f cposvx.f cpotf2.f cpotrf.f cpotrf2.f cpotri.f cpotrs.f cpstrf.f cpstf2.f - cppcon.f cppequ.f cpprfs.f cppsv.f cppsvx.f cpptrf.f cpptri.f cpptrs.f - cptcon.f cpteqr.f cptrfs.f cptsv.f cptsvx.f cpttrf.f cpttrs.f cptts2.f - crot.f cspcon.f cspmv.f cspr.f csprfs.f cspsv.f - cspsvx.f csptrf.f csptri.f csptrs.f csrscl.f cstedc.f - cstegr.f cstein.f csteqr.f csycon.f csymv.f - csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f + chetrs.f chetrs2.f + chetf2_rook.f chetrf_rook.f chetri_rook.f + chetrs_rook.f checon_rook.f chesv_rook.f + chetf2_rk.f chetrf_rk.f chetri_3.f chetri_3x.f + chetrs_3.f checon_3.f chesv_rk.f + chesv_aa.f chetrf_aa.f chetrs_aa.f + chgeqz.f chpcon.f chpev.f chpevd.f + chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f + chpsvx.f + chptrd.f chptrf.f chptri.f chptrs.f chsein.f chseqr.f clabrd.f + clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f + claed0.f claed7.f claed8.f + claein.f claesy.f claev2.f clags2.f clagtm.f + clahef.f clahef_rook.f clahef_rk.f clahef_aa.f clahqr.f + clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f + clanhb.f clanhe.f + clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f + clantp.f clantr.f clapll.f clapmt.f clarcm.f claqgb.f claqge.f + claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqsb.f + claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f + claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f + clarf.f clarfb.f clarfg.f clarfgp.f clarft.f + clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f clartv.f + clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f + claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f + clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f + clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f + cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f + cposv.f cposvx.f cpotf2.f cpotrf.f cpotrf2.f cpotri.f cpotrs.f cpstrf.f cpstf2.f + cppcon.f cppequ.f cpprfs.f cppsv.f cppsvx.f cpptrf.f cpptri.f cpptrs.f + cptcon.f cpteqr.f cptrfs.f cptsv.f cptsvx.f cpttrf.f cpttrs.f cptts2.f + crot.f cspcon.f cspmv.f cspr.f csprfs.f cspsv.f + cspsvx.f csptrf.f csptri.f csptrs.f csrscl.f cstedc.f + cstegr.f cstein.f csteqr.f csycon.f csymv.f + csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f csytri2.f csytri2x.f csyswapr.f - csytrs.f csytrs2.f csyconv.f + csytrs.f csytrs2.f + csyconv.f csyconvf.f csyconvf_rook.f csytf2_rook.f csytrf_rook.f csytrs_rook.f csytri_rook.f csycon_rook.f csysv_rook.f - ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f - ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f - ctprfs.f ctptri.f - ctptrs.f ctrcon.f ctrevc.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f - ctrsyl.f ctrti2.f ctrtri.f ctrtrs.f ctzrzf.f cung2l.f cung2r.f - cungbr.f cunghr.f cungl2.f cunglq.f cungql.f cungqr.f cungr2.f + csytf2_rk.f csytrf_rk.f csytrf_aa.f csytrs_3.f csytrs_aa.f + csytri_3.f csytri_3x.f csycon_3.f csysv_rk.f csysv_aa.f + ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f + ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f + ctprfs.f ctptri.f + ctptrs.f ctrcon.f ctrevc.f ctrevc3.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f + ctrsyl.f ctrti2.f ctrtri.f ctrtrs.f ctzrzf.f cung2l.f cung2r.f + cungbr.f cunghr.f cungl2.f cunglq.f cungql.f cungqr.f cungr2.f cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f cunm22.f - cunmlq.f cunmql.f cunmqr.f cunmr2.f cunmr3.f cunmrq.f cunmrz.f - cunmtr.f cupgtr.f cupmtr.f icmax1.f scsum1.f cstemr.f - chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f - ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f + cunmlq.f cunmql.f cunmqr.f cunmr2.f cunmr3.f cunmrq.f cunmrz.f + cunmtr.f cupgtr.f cupmtr.f icmax1.f scsum1.f cstemr.f + chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f + ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f cgeequb.f cgbequb.f csyequb.f cpoequb.f cheequb.f cbbcsd.f clapmr.f cunbdb.f cunbdb1.f cunbdb2.f cunbdb3.f cunbdb4.f cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f - ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f) + ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f + cgelqt.f cgelqt3.f cgemlqt.f + cgetsls.f cgeqr.f clatsqr.f clamtsqr.f cgemqr.f + cgelq.f claswlq.f clamswlq.f cgemlq.f + ctplqt.f ctplqt2.f ctpmlqt.f + chetrd_2stage.f chetrd_he2hb.f chetrd_hb2st.F chb2st_kernels.f + cheevd_2stage.f cheev_2stage.f cheevx_2stage.f cheevr_2stage.f + chbev_2stage.f chbevx_2stage.f chbevd_2stage.f chegv_2stage.f) -set(CXLASRC cgesvxx.f cgerfsx.f cla_gerfsx_extended.f cla_geamv.f - cla_gercond_c.f cla_gercond_x.f cla_gerpvgrw.f - csysvxx.f csyrfsx.f cla_syrfsx_extended.f cla_syamv.f - cla_syrcond_c.f cla_syrcond_x.f cla_syrpvgrw.f - cposvxx.f cporfsx.f cla_porfsx_extended.f - cla_porcond_c.f cla_porcond_x.f cla_porpvgrw.f - cgbsvxx.f cgbrfsx.f cla_gbrfsx_extended.f cla_gbamv.f - cla_gbrcond_c.f cla_gbrcond_x.f cla_gbrpvgrw.f - chesvxx.f cherfsx.f cla_herfsx_extended.f cla_heamv.f - cla_hercond_c.f cla_hercond_x.f cla_herpvgrw.f +set(CXLASRC cgesvxx.f cgerfsx.f cla_gerfsx_extended.f cla_geamv.f + cla_gercond_c.f cla_gercond_x.f cla_gerpvgrw.f + csysvxx.f csyrfsx.f cla_syrfsx_extended.f cla_syamv.f + cla_syrcond_c.f cla_syrcond_x.f cla_syrpvgrw.f + cposvxx.f cporfsx.f cla_porfsx_extended.f + cla_porcond_c.f cla_porcond_x.f cla_porpvgrw.f + cgbsvxx.f cgbrfsx.f cla_gbrfsx_extended.f cla_gbamv.f + cla_gbrcond_c.f cla_gbrcond_x.f cla_gbrpvgrw.f + chesvxx.f cherfsx.f cla_herfsx_extended.f cla_heamv.f + cla_hercond_c.f cla_hercond_x.f cla_herpvgrw.f cla_lin_berr.f clarscl2.f clascl2.f cla_wwaddw.f) -set(ZCLASRC cpotrs.f cgetrs.f cpotrf.f cgetrf.f) +set(ZCLASRC cpotrs.f cgetrs.f cpotrf.f cgetrf.f) -set(DLASRC - dbdsvdx.f dgbbrd.f dgbcon.f dgbequ.f dgbrfs.f dgbsv.f - dgbsvx.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f dgebal.f dgebd2.f - dgebrd.f dgecon.f dgeequ.f dgees.f dgeesx.f dgeev.f dgeevx.f - dgehd2.f dgehrd.f dgelq2.f dgelqf.f - dgels.f dgelsd.f dgelss.f dgelsy.f dgeql2.f dgeqlf.f - dgeqp3.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f - dgesc2.f dgesdd.f dgesv.f dgesvd.f dgesvdx.f dgesvx.f dgetc2.f dgetf2.f - dgetrf.f dgetrf2.f dgetri.f +set(DLASRC + dbdsvdx.f dgbbrd.f dgbcon.f dgbequ.f dgbrfs.f dgbsv.f + dgbsvx.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f dgebal.f dgebd2.f + dgebrd.f dgecon.f dgeequ.f dgees.f dgeesx.f dgeev.f dgeevx.f + dgehd2.f dgehrd.f dgelq2.f dgelqf.f + dgels.f dgelsd.f dgelss.f dgelsy.f dgeql2.f dgeqlf.f + dgeqp3.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f + dgesc2.f dgesdd.f dgesv.f dgesvd.f dgesvdx.f dgesvx.f dgetc2.f dgetf2.f + dgetrf.f dgetrf2.f dgetri.f dgetrs.f dggbak.f dggbal.f dgges.f dgges3.f dggesx.f dggev.f dggev3.f dggevx.f - dggglm.f dgghrd.f dgghd3.f dgglse.f dggqrf.f - dggrqf.f dggsvd3.f dggsvp3.f dgtcon.f dgtrfs.f dgtsv.f - dgtsvx.f dgttrf.f dgttrs.f dgtts2.f dhgeqz.f - dhsein.f dhseqr.f dlabrd.f dlacon.f dlacn2.f - dlaein.f dlaexc.f dlag2.f dlags2.f dlagtm.f dlagv2.f dlahqr.f - dlahr2.f dlaic1.f dlaln2.f dlals0.f dlalsa.f dlalsd.f - dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f - dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f - dlapll.f dlapmt.f - dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f - dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f - dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f - dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f - dlarrv.f dlartv.f - dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f - dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlauu2.f - dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f - dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f - dorgrq.f dorgtr.f dorm2l.f dorm2r.f dorm22.f - dormbr.f dormhr.f dorml2.f dormlq.f dormql.f dormqr.f dormr2.f - dormr3.f dormrq.f dormrz.f dormtr.f dpbcon.f dpbequ.f dpbrfs.f - dpbstf.f dpbsv.f dpbsvx.f - dpbtf2.f dpbtrf.f dpbtrs.f dpocon.f dpoequ.f dporfs.f dposv.f - dposvx.f dpotf2.f dpotrf.f dpotrf2.f dpotri.f dpotrs.f dpstrf.f dpstf2.f - dppcon.f dppequ.f - dpprfs.f dppsv.f dppsvx.f dpptrf.f dpptri.f dpptrs.f dptcon.f - dpteqr.f dptrfs.f dptsv.f dptsvx.f dpttrs.f dptts2.f drscl.f - dsbev.f dsbevd.f dsbevx.f dsbgst.f dsbgv.f dsbgvd.f dsbgvx.f - dsbtrd.f dspcon.f dspev.f dspevd.f dspevx.f dspgst.f - dspgv.f dspgvd.f dspgvx.f dsprfs.f dspsv.f dspsvx.f dsptrd.f - dsptrf.f dsptri.f dsptrs.f dstegr.f dstein.f dstev.f dstevd.f dstevr.f - dstevx.f dsycon.f dsyev.f dsyevd.f dsyevr.f - dsyevx.f dsygs2.f dsygst.f dsygv.f dsygvd.f dsygvx.f dsyrfs.f - dsysv.f dsysvx.f - dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f - dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f + dggglm.f dgghrd.f dgghd3.f dgglse.f dggqrf.f + dggrqf.f dggsvd3.f dggsvp3.f dgtcon.f dgtrfs.f dgtsv.f + dgtsvx.f dgttrf.f dgttrs.f dgtts2.f dhgeqz.f + dhsein.f dhseqr.f dlabrd.f dlacon.f dlacn2.f + dlaein.f dlaexc.f dlag2.f dlags2.f dlagtm.f dlagv2.f dlahqr.f + dlahr2.f dlaic1.f dlaln2.f dlals0.f dlalsa.f dlalsd.f + dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f + dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f + dlapll.f dlapmt.f + dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f + dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f + dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f + dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f + dlargv.f dlarrv.f dlartv.f + dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f + dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f + dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlauu2.f + dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f + dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f + dorgrq.f dorgtr.f dorm2l.f dorm2r.f dorm22.f + dormbr.f dormhr.f dorml2.f dormlq.f dormql.f dormqr.f dormr2.f + dormr3.f dormrq.f dormrz.f dormtr.f dpbcon.f dpbequ.f dpbrfs.f + dpbstf.f dpbsv.f dpbsvx.f + dpbtf2.f dpbtrf.f dpbtrs.f dpocon.f dpoequ.f dporfs.f dposv.f + dposvx.f dpotf2.f dpotrf.f dpotrf2.f dpotri.f dpotrs.f dpstrf.f dpstf2.f + dppcon.f dppequ.f + dpprfs.f dppsv.f dppsvx.f dpptrf.f dpptri.f dpptrs.f dptcon.f + dpteqr.f dptrfs.f dptsv.f dptsvx.f dpttrs.f dptts2.f drscl.f + dsbev.f dsbevd.f dsbevx.f dsbgst.f dsbgv.f dsbgvd.f dsbgvx.f + dsbtrd.f dspcon.f dspev.f dspevd.f dspevx.f dspgst.f + dspgv.f dspgvd.f dspgvx.f dsprfs.f dspsv.f dspsvx.f dsptrd.f + dsptrf.f dsptri.f dsptrs.f dstegr.f dstein.f dstev.f dstevd.f dstevr.f + dstevx.f dsycon.f dsyev.f dsyevd.f dsyevr.f + dsyevx.f dsygs2.f dsygst.f dsygv.f dsygvd.f dsygvx.f dsyrfs.f + dsysv.f dsysvx.f + dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f + dsytri2.f dsytri2x.f dsyswapr.f + dsyconv.f dsyconvf.f dsyconvf_rook.f dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f dsytri_rook.f dsycon_rook.f dsysv_rook.f - dtbcon.f - dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f - dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f - dtptrs.f - dtrcon.f dtrevc.f dtrexc.f dtrrfs.f dtrsen.f dtrsna.f dtrsyl.f - dtrti2.f dtrtri.f dtrtrs.f dtzrzf.f dstemr.f - dsgesv.f dsposv.f dlag2s.f slag2d.f dlat2s.f - dlansf.f dpftrf.f dpftri.f dpftrs.f dsfrk.f dtfsm.f dtftri.f dtfttp.f - dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f - dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f + dsytf2_rk.f dsytrf_rk.f dsytrs_3.f + dsytri_3.f dsytri_3x.f dsycon_3.f dsysv_rk.f + dsysv_aa.f dsytrf_aa.f dsytrs_aa.f + dtbcon.f + dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f + dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f + dtptrs.f + dtrcon.f dtrevc.f dtrevc3.f dtrexc.f dtrrfs.f dtrsen.f dtrsna.f dtrsyl.f + dtrti2.f dtrtri.f dtrtrs.f dtzrzf.f dstemr.f + dsgesv.f dsposv.f dlag2s.f slag2d.f dlat2s.f + dlansf.f dpftrf.f dpftri.f dpftrs.f dsfrk.f dtfsm.f dtftri.f dtfttp.f + dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f + dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f dgeequb.f dsyequb.f dpoequb.f dgbequb.f dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f - dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f ) + dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f + dgelqt.f dgelqt3.f dgemlqt.f + dgetsls.f dgeqr.f dlatsqr.f dlamtsqr.f dgemqr.f + dgelq.f dlaswlq.f dlamswlq.f dgemlq.f + dtplqt.f dtplqt2.f dtpmlqt.f + dsytrd_2stage.f dsytrd_sy2sb.f dsytrd_sb2st.F dsb2st_kernels.f + dsyevd_2stage.f dsyev_2stage.f dsyevx_2stage.f dsyevr_2stage.f + dsbev_2stage.f dsbevx_2stage.f dsbevd_2stage.f dsygv_2stage.f) -set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f - dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f - dla_syrfsx_extended.f dla_syamv.f dla_syrcond.f dla_syrpvgrw.f - dposvxx.f dporfsx.f dla_porfsx_extended.f dla_porcond.f - dla_porpvgrw.f dgbsvxx.f dgbrfsx.f dla_gbrfsx_extended.f - dla_gbamv.f dla_gbrcond.f dla_gbrpvgrw.f dla_lin_berr.f dlarscl2.f +set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f + dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f + dla_syrfsx_extended.f dla_syamv.f dla_syrcond.f dla_syrpvgrw.f + dposvxx.f dporfsx.f dla_porfsx_extended.f dla_porcond.f + dla_porpvgrw.f dgbsvxx.f dgbrfsx.f dla_gbrfsx_extended.f + dla_gbamv.f dla_gbrcond.f dla_gbrpvgrw.f dla_lin_berr.f dlarscl2.f dlascl2.f dla_wwaddw.f) -set(ZLASRC - zbdsqr.f zgbbrd.f zgbcon.f zgbequ.f zgbrfs.f zgbsv.f zgbsvx.f - zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f - zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f - zgehd2.f zgehrd.f zgelq2.f zgelqf.f - zgels.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f - zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f +set(ZLASRC + zbdsqr.f zgbbrd.f zgbcon.f zgbequ.f zgbrfs.f zgbsv.f zgbsvx.f + zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f + zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f + zgehd2.f zgehrd.f zgelq2.f zgelqf.f + zgels.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f + zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f zgesc2.f zgesdd.f zgesv.f zgesvd.f zgesvdx.f zgesvx.f zgesvj.f zgejsv.f zgsvj0.f zgsvj1.f zgetc2.f zgetf2.f zgetrf.f zgetrf2.f - zgetri.f zgetrs.f + zgetri.f zgetrs.f zggbak.f zggbal.f zgges.f zgges3.f zggesx.f zggev.f zggev3.f zggevx.f - zggglm.f zgghrd.f zgghd3.f zgglse.f zggqrf.f zggrqf.f - zggsvd3.f zggsvp3.f - zgtcon.f zgtrfs.f zgtsv.f zgtsvx.f zgttrf.f zgttrs.f zgtts2.f zhbev.f - zhbevd.f zhbevx.f zhbgst.f zhbgv.f zhbgvd.f zhbgvx.f zhbtrd.f - zhecon.f zheev.f zheevd.f zheevr.f zheevx.f zhegs2.f zhegst.f - zhegv.f zhegvd.f zhegvx.f zherfs.f zhesv.f zhesvx.f zhetd2.f - zhetf2.f zhetrd.f + zggglm.f zgghrd.f zgghd3.f zgglse.f zggqrf.f zggrqf.f + zggsvd3.f zggsvp3.f + zgtcon.f zgtrfs.f zgtsv.f zgtsvx.f zgttrf.f zgttrs.f zgtts2.f zhbev.f + zhbevd.f zhbevx.f zhbgst.f zhbgv.f zhbgvd.f zhbgvx.f zhbtrd.f + zhecon.f zheev.f zheevd.f zheevr.f zheevx.f zhegs2.f zhegst.f + zhegv.f zhegvd.f zhegvx.f zherfs.f zhesv.f zhesvx.f zhetd2.f + zhetf2.f zhetrd.f zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f zhetrs.f zhetrs2.f - zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f - zhgeqz.f zhpcon.f zhpev.f zhpevd.f - zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f - zhpsvx.f - zhptrd.f zhptrf.f zhptri.f zhptrs.f zhsein.f zhseqr.f zlabrd.f - zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f - zlaed0.f zlaed7.f zlaed8.f - zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f - zlahef.f zlahef_rook.f zlahqr.f - zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f - zlangt.f zlanhb.f - zlanhe.f - zlanhp.f zlanhs.f zlanht.f zlansb.f zlansp.f zlansy.f zlantb.f - zlantp.f zlantr.f zlapll.f zlapmt.f zlaqgb.f zlaqge.f - zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqsb.f - zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f - zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f - zlarcm.f zlarf.f zlarfb.f + zhetf2_rook.f zhetrf_rook.f zhetri_rook.f + zhetrs_rook.f zhecon_rook.f zhesv_rook.f + zhetf2_rk.f zhetrf_rk.f zhetri_3.f zhetri_3x.f + zhetrs_3.f zhecon_3.f zhesv_rk.f + zhesv_aa.f zhetrf_aa.f zhetrs_aa.f + zhgeqz.f zhpcon.f zhpev.f zhpevd.f + zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f + zhpsvx.f + zhptrd.f zhptrf.f zhptri.f zhptrs.f zhsein.f zhseqr.f zlabrd.f + zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f + zlaed0.f zlaed7.f zlaed8.f + zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f + zlahef.f zlahef_rook.f zlahef_rk.f zlahef_aa.f zlahqr.f + zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f + zlangt.f zlanhb.f + zlanhe.f + zlanhp.f zlanhs.f zlanht.f zlansb.f zlansp.f zlansy.f zlantb.f + zlantp.f zlantr.f zlapll.f zlapmt.f zlaqgb.f zlaqge.f + zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqsb.f + zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f + zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f + zlarcm.f zlarf.f zlarfb.f zlarfg.f zlarfgp.f zlarft.f - zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f - zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f - zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f - zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f - zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f - zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f - zposv.f zposvx.f zpotf2.f zpotrf.f zpotrf2.f zpotri.f zpotrs.f zpstrf.f zpstf2.f - zppcon.f zppequ.f zpprfs.f zppsv.f zppsvx.f zpptrf.f zpptri.f zpptrs.f - zptcon.f zpteqr.f zptrfs.f zptsv.f zptsvx.f zpttrf.f zpttrs.f zptts2.f - zrot.f zspcon.f zspmv.f zspr.f zsprfs.f zspsv.f - zspsvx.f zsptrf.f zsptri.f zsptrs.f zdrscl.f zstedc.f - zstegr.f zstein.f zsteqr.f zsycon.f zsymv.f - zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f + zlarfx.f zlarfy.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f + zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f + zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f zlasyf_rk.f zlasyf_aa.f + zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f + zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f + zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f + zposv.f zposvx.f zpotf2.f zpotrf.f zpotrf2.f zpotri.f zpotrs.f zpstrf.f zpstf2.f + zppcon.f zppequ.f zpprfs.f zppsv.f zppsvx.f zpptrf.f zpptri.f zpptrs.f + zptcon.f zpteqr.f zptrfs.f zptsv.f zptsvx.f zpttrf.f zpttrs.f zptts2.f + zrot.f zspcon.f zspmv.f zspr.f zsprfs.f zspsv.f + zspsvx.f zsptrf.f zsptri.f zsptrs.f zdrscl.f zstedc.f + zstegr.f zstein.f zsteqr.f zsycon.f zsymv.f + zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f zsytri2.f zsytri2x.f zsyswapr.f - zsytrs.f zsytrs2.f zsyconv.f - zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f + zsytrs.f zsytrs2.f + zsyconv.f zsyconvf.f zsyconvf_rook.f + zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f zsytrs_aa.f zsytri_rook.f zsycon_rook.f zsysv_rook.f - ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f - ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f - ztprfs.f ztptri.f - ztptrs.f ztrcon.f ztrevc.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f - ztrsyl.f ztrti2.f ztrtri.f ztrtrs.f ztzrzf.f zung2l.f - zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f zungqr.f zungr2.f + zsytf2_rk.f zsytrf_rk.f zsytrf_aa.f zsytrs_3.f + zsytri_3.f zsytri_3x.f zsycon_3.f zsysv_rk.f zsysv_aa.f + ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f + ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f + ztprfs.f ztptri.f + ztptrs.f ztrcon.f ztrevc.f ztrevc3.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f + ztrsyl.f ztrti2.f ztrtri.f ztrtrs.f ztzrzf.f zung2l.f + zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f zungqr.f zungr2.f zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f zunm22.f - zunmlq.f zunmql.f zunmqr.f zunmr2.f zunmr3.f zunmrq.f zunmrz.f - zunmtr.f zupgtr.f - zupmtr.f izmax1.f dzsum1.f zstemr.f - zcgesv.f zcposv.f zlag2c.f clag2z.f zlat2c.f - zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f - ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f + zunmlq.f zunmql.f zunmqr.f zunmr2.f zunmr3.f zunmrq.f zunmrz.f + zunmtr.f zupgtr.f + zupmtr.f izmax1.f dzsum1.f zstemr.f + zcgesv.f zcposv.f zlag2c.f clag2z.f zlat2c.f + zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f + ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f zgeequb.f zgbequb.f zsyequb.f zpoequb.f zheequb.f zbbcsd.f zlapmr.f zunbdb.f zunbdb1.f zunbdb2.f zunbdb3.f zunbdb4.f zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f - ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f) + ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f + ztplqt.f ztplqt2.f ztpmlqt.f + zgelqt.f zgelqt3.f zgemlqt.f + zgetsls.f zgeqr.f zlatsqr.f zlamtsqr.f zgemqr.f + zgelq.f zlaswlq.f zlamswlq.f zgemlq.f + zhetrd_2stage.f zhetrd_he2hb.f zhetrd_hb2st.F zhb2st_kernels.f + zheevd_2stage.f zheev_2stage.f zheevx_2stage.f zheevr_2stage.f + zhbev_2stage.f zhbevx_2stage.f zhbevd_2stage.f zhegv_2stage.f) -set(ZXLASRC zgesvxx.f zgerfsx.f zla_gerfsx_extended.f zla_geamv.f - zla_gercond_c.f zla_gercond_x.f zla_gerpvgrw.f zsysvxx.f zsyrfsx.f - zla_syrfsx_extended.f zla_syamv.f zla_syrcond_c.f zla_syrcond_x.f - zla_syrpvgrw.f zposvxx.f zporfsx.f zla_porfsx_extended.f - zla_porcond_c.f zla_porcond_x.f zla_porpvgrw.f zgbsvxx.f zgbrfsx.f - zla_gbrfsx_extended.f zla_gbamv.f zla_gbrcond_c.f zla_gbrcond_x.f - zla_gbrpvgrw.f zhesvxx.f zherfsx.f zla_herfsx_extended.f - zla_heamv.f zla_hercond_c.f zla_hercond_x.f zla_herpvgrw.f +set(ZXLASRC zgesvxx.f zgerfsx.f zla_gerfsx_extended.f zla_geamv.f + zla_gercond_c.f zla_gercond_x.f zla_gerpvgrw.f zsysvxx.f zsyrfsx.f + zla_syrfsx_extended.f zla_syamv.f zla_syrcond_c.f zla_syrcond_x.f + zla_syrpvgrw.f zposvxx.f zporfsx.f zla_porfsx_extended.f + zla_porcond_c.f zla_porcond_x.f zla_porpvgrw.f zgbsvxx.f zgbrfsx.f + zla_gbrfsx_extended.f zla_gbamv.f zla_gbrcond_c.f zla_gbrcond_x.f + zla_gbrpvgrw.f zhesvxx.f zherfsx.f zla_herfsx_extended.f + zla_heamv.f zla_hercond_c.f zla_hercond_x.f zla_herpvgrw.f zla_lin_berr.f zlarscl2.f zlascl2.f zla_wwaddw.f) -if( USE_XBLAS) - set(ALLXOBJ ${SXLASRC} ${DXLASRC} ${CXLASRC} ${ZXLASRC} ${ALLXAUX}) +if(USE_XBLAS) + set(ALLXOBJ ${SXLASRC} ${DXLASRC} ${CXLASRC} ${ZXLASRC}) endif() if(BUILD_DEPRECATED) - LIST(APPEND SLASRC DEPRECATED/sgegs.f DEPRECATED/sgegv.f + list(APPEND SLASRC DEPRECATED/sgegs.f DEPRECATED/sgegv.f DEPRECATED/sgeqpf.f DEPRECATED/sgelsx.f DEPRECATED/sggsvd.f DEPRECATED/sggsvp.f DEPRECATED/slahrd.f DEPRECATED/slatzm.f DEPRECATED/stzrqf.f) - LIST(APPEND DLASRC DEPRECATED/dgegs.f DEPRECATED/dgegv.f + list(APPEND DLASRC DEPRECATED/dgegs.f DEPRECATED/dgegv.f DEPRECATED/dgeqpf.f DEPRECATED/dgelsx.f DEPRECATED/dggsvd.f - DEPRECATED/dggsvp.f DEPRECATED/dlahrd.f DEPRECATED/dlatzm.f DEPRECATED/dtzrqf.f ) - LIST(APPEND CLASRC DEPRECATED/cgegs.f DEPRECATED/cgegv.f + DEPRECATED/dggsvp.f DEPRECATED/dlahrd.f DEPRECATED/dlatzm.f DEPRECATED/dtzrqf.f) + list(APPEND CLASRC DEPRECATED/cgegs.f DEPRECATED/cgegv.f DEPRECATED/cgeqpf.f DEPRECATED/cgelsx.f DEPRECATED/cggsvd.f DEPRECATED/cggsvp.f DEPRECATED/clahrd.f DEPRECATED/clatzm.f DEPRECATED/ctzrqf.f) - LIST(APPEND ZLASRC DEPRECATED/zgegs.f DEPRECATED/zgegv.f + list(APPEND ZLASRC DEPRECATED/zgegs.f DEPRECATED/zgegv.f DEPRECATED/zgeqpf.f DEPRECATED/zgelsx.f DEPRECATED/zggsvd.f DEPRECATED/zggsvp.f DEPRECATED/zlahrd.f DEPRECATED/zlatzm.f DEPRECATED/ztzrqf.f) - message(STATUS "Building deprecated routines") + message(STATUS "Building deprecated routines") endif() if(BUILD_SINGLE) -set(ALLOBJ ${SLASRC} ${ALLAUX} ${SCLAUX} ) -message(STATUS "Building Single Precision") + set(ALLOBJ ${SLASRC} ${ALLAUX} ${SCLAUX}) + message(STATUS "Building Single Precision") endif() if(BUILD_DOUBLE) set(ALLOBJ ${ALLOBJ} ${DLASRC} ${ALLAUX} ${DZLAUX} ${DSLASRC}) -message(STATUS "Building Double Precision") + message(STATUS "Building Double Precision") endif() if(BUILD_COMPLEX) - set(ALLOBJ ${ALLOBJ} ${CLASRC} ${ALLAUX} ${SCLAUX} ) -message(STATUS "Building Complex Precision") + set(ALLOBJ ${ALLOBJ} ${CLASRC} ${ALLAUX} ${SCLAUX}) + message(STATUS "Building Complex Precision") endif() if(BUILD_COMPLEX16) - set(ALLOBJ ${ALLOBJ} ${ZLASRC} ${ALLAUX} ${DZLAUX} ${ZCLASRC}) -message(STATUS "Building Double Complex Precision") + set(ALLOBJ ${ALLOBJ} ${ZLASRC} ${ALLAUX} ${DZLAUX} ${ZCLASRC}) + message(STATUS "Building Double Complex Precision") endif() -if (NOT ALLOBJ) - message(FATAL_ERROR "-->LAPACK SRC BUILD: NOTHING TO BUILD, NO PRECISION SELECTED: +if(NOT ALLOBJ) + message(FATAL_ERROR "-->LAPACK SRC BUILD: NOTHING TO BUILD, NO PRECISION SELECTED: PLEASE ENABLE AT LEAST ONE OF THOSE: BUILD_SINGLE, BUILD_COMPLEX, BUILD_DOUBLE, BUILD_COMPLEX16.") endif() diff --git a/lapack-netlib/SRC/DEPRECATED/cgegs.f b/lapack-netlib/SRC/DEPRECATED/cgegs.f index b005ab49b7..4e75e20255 100644 --- a/lapack-netlib/SRC/DEPRECATED/cgegs.f +++ b/lapack-netlib/SRC/DEPRECATED/cgegs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, * VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N @@ -32,7 +32,7 @@ * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -45,13 +45,13 @@ *> left and or/right Schur vectors of a complex matrix pair (A,B). *> Given two square matrices A and B, the generalized Schur *> factorization has the form -*> +*> *> A = Q*S*Z**H, B = Q*T*Z**H -*> +*> *> where Q and Z are unitary matrices and S and T are upper triangular. *> The columns of Q are the left Schur vectors *> and the columns of Z are the right Schur vectors. -*> +*> *> If only the eigenvalues of (A,B) are needed, the driver routine *> CGEGV should be used instead. See CGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem @@ -211,12 +211,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEeigen * @@ -225,10 +225,10 @@ SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR diff --git a/lapack-netlib/SRC/DEPRECATED/cgegv.f b/lapack-netlib/SRC/DEPRECATED/cgegv.f index 396745d2cf..81def0db4f 100644 --- a/lapack-netlib/SRC/DEPRECATED/cgegv.f +++ b/lapack-netlib/SRC/DEPRECATED/cgegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, * VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -31,7 +31,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> lambda or mu is zero or small, two values alpha and beta are returned *> for each eigenvalue, such that lambda = alpha/beta and *> mu = beta/alpha. -*> +*> *> The vectors x and y in the above equations are right eigenvectors of *> the matrix pair (A,B). Vectors u and v satisfying *> u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B @@ -138,7 +138,7 @@ *> \verbatim *> BETA is COMPLEX array, dimension (N) *> The complex scalars beta that define the eigenvalues of GNEP. -*> +*> *> Together, the quantities alpha = ALPHA(j) and beta = BETA(j) *> represent the j-th eigenvalue of the matrix pair (A,B), in *> one of the forms lambda = alpha/beta or mu = beta/alpha. @@ -237,12 +237,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEeigen * @@ -282,10 +282,10 @@ SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR diff --git a/lapack-netlib/SRC/DEPRECATED/cgelsx.f b/lapack-netlib/SRC/DEPRECATED/cgelsx.f index 39380e6ac4..22d2358ba6 100644 --- a/lapack-netlib/SRC/DEPRECATED/cgelsx.f +++ b/lapack-netlib/SRC/DEPRECATED/cgelsx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, M, N, NRHS, RANK * REAL RCOND @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -171,12 +171,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEsolve * @@ -184,10 +184,10 @@ SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/DEPRECATED/cgeqpf.f b/lapack-netlib/SRC/DEPRECATED/cgeqpf.f index a4aaf6df16..2cbd1951e1 100644 --- a/lapack-netlib/SRC/DEPRECATED/cgeqpf.f +++ b/lapack-netlib/SRC/DEPRECATED/cgeqpf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQPF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQPF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -28,7 +28,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -148,10 +148,10 @@ * ===================================================================== SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -286,11 +286,11 @@ SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. -* +* TEMP = ABS( A( I, J ) ) / RWORK( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) diff --git a/lapack-netlib/SRC/DEPRECATED/cggsvd.f b/lapack-netlib/SRC/DEPRECATED/cggsvd.f index 080ef0acbe..e7ece14c36 100644 --- a/lapack-netlib/SRC/DEPRECATED/cggsvd.f +++ b/lapack-netlib/SRC/DEPRECATED/cggsvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGSVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGSVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -318,12 +318,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsing * @@ -338,10 +338,10 @@ SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/cggsvp.f b/lapack-netlib/SRC/DEPRECATED/cggsvp.f index daf67eb92b..24bb09a390 100644 --- a/lapack-netlib/SRC/DEPRECATED/cggsvp.f +++ b/lapack-netlib/SRC/DEPRECATED/cggsvp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGSVP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGSVP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, RWORK, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. +*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -241,12 +241,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -262,10 +262,10 @@ SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/clahrd.f b/lapack-netlib/SRC/DEPRECATED/clahrd.f index 2c92a89938..7be3f2a1db 100644 --- a/lapack-netlib/SRC/DEPRECATED/clahrd.f +++ b/lapack-netlib/SRC/DEPRECATED/clahrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB diff --git a/lapack-netlib/SRC/DEPRECATED/clatzm.f b/lapack-netlib/SRC/DEPRECATED/clatzm.f index 4e0fa79c43..377eef725d 100644 --- a/lapack-netlib/SRC/DEPRECATED/clatzm.f +++ b/lapack-netlib/SRC/DEPRECATED/clatzm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATZM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,22 +140,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/DEPRECATED/ctzrqf.f b/lapack-netlib/SRC/DEPRECATED/ctzrqf.f index f8a6f91681..5ed47d7e7a 100644 --- a/lapack-netlib/SRC/DEPRECATED/ctzrqf.f +++ b/lapack-netlib/SRC/DEPRECATED/ctzrqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTZRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTZRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/DEPRECATED/dgegs.f b/lapack-netlib/SRC/DEPRECATED/dgegs.f index 95faf08e1b..eb404484d3 100644 --- a/lapack-netlib/SRC/DEPRECATED/dgegs.f +++ b/lapack-netlib/SRC/DEPRECATED/dgegs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, * ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N @@ -31,7 +31,7 @@ * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEeigen * @@ -227,10 +227,10 @@ SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR diff --git a/lapack-netlib/SRC/DEPRECATED/dgegv.f b/lapack-netlib/SRC/DEPRECATED/dgegv.f index c687c413da..e4d469aa5b 100644 --- a/lapack-netlib/SRC/DEPRECATED/dgegv.f +++ b/lapack-netlib/SRC/DEPRECATED/dgegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -30,7 +30,7 @@ * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,7 +151,7 @@ *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> The scalars beta that define the eigenvalues of GNEP. -*> +*> *> Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and *> beta = BETA(j) represent the j-th eigenvalue of the matrix *> pair (A,B), in one of the forms lambda = alpha/beta or @@ -260,12 +260,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEeigen * @@ -306,10 +306,10 @@ SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR diff --git a/lapack-netlib/SRC/DEPRECATED/dgelsx.f b/lapack-netlib/SRC/DEPRECATED/dgelsx.f index 788cce128c..70e5ce7f98 100644 --- a/lapack-netlib/SRC/DEPRECATED/dgelsx.f +++ b/lapack-netlib/SRC/DEPRECATED/dgelsx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -29,7 +29,7 @@ * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * @@ -178,10 +178,10 @@ SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/DEPRECATED/dgeqpf.f b/lapack-netlib/SRC/DEPRECATED/dgeqpf.f index bc5b91c538..58ef56035b 100644 --- a/lapack-netlib/SRC/DEPRECATED/dgeqpf.f +++ b/lapack-netlib/SRC/DEPRECATED/dgeqpf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQPF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQPF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -279,11 +279,11 @@ SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. -* +* TEMP = ABS( A( I, J ) ) / WORK( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) diff --git a/lapack-netlib/SRC/DEPRECATED/dggsvd.f b/lapack-netlib/SRC/DEPRECATED/dggsvd.f index 6d7ace4416..32d232c081 100644 --- a/lapack-netlib/SRC/DEPRECATED/dggsvd.f +++ b/lapack-netlib/SRC/DEPRECATED/dggsvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGSVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGSVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -314,12 +314,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERsing * @@ -334,10 +334,10 @@ SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/dggsvp.f b/lapack-netlib/SRC/DEPRECATED/dggsvp.f index 7e195b0b11..1cc52b7197 100644 --- a/lapack-netlib/SRC/DEPRECATED/dggsvp.f +++ b/lapack-netlib/SRC/DEPRECATED/dggsvp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGSVP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGSVP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. +*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -235,12 +235,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -256,10 +256,10 @@ SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/dlahrd.f b/lapack-netlib/SRC/DEPRECATED/dlahrd.f index a98b172ca2..9aa04ee14a 100644 --- a/lapack-netlib/SRC/DEPRECATED/dlahrd.f +++ b/lapack-netlib/SRC/DEPRECATED/dlahrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB diff --git a/lapack-netlib/SRC/DEPRECATED/dlatzm.f b/lapack-netlib/SRC/DEPRECATED/dlatzm.f index 107a8bc0da..73434a21a0 100644 --- a/lapack-netlib/SRC/DEPRECATED/dlatzm.f +++ b/lapack-netlib/SRC/DEPRECATED/dlatzm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATZM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,22 +139,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/DEPRECATED/dtzrqf.f b/lapack-netlib/SRC/DEPRECATED/dtzrqf.f index 10aec7267b..c1cbdc6abd 100644 --- a/lapack-netlib/SRC/DEPRECATED/dtzrqf.f +++ b/lapack-netlib/SRC/DEPRECATED/dtzrqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTZRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTZRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/DEPRECATED/sgegs.f b/lapack-netlib/SRC/DEPRECATED/sgegs.f index c4e5bdc943..bf4fbc7102 100644 --- a/lapack-netlib/SRC/DEPRECATED/sgegs.f +++ b/lapack-netlib/SRC/DEPRECATED/sgegs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, * ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N @@ -31,7 +31,7 @@ * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -44,7 +44,7 @@ *> left and or/right Schur vectors of a real matrix pair (A,B). *> Given two square matrices A and B, the generalized real Schur *> factorization has the form -*> +*> *> A = Q*S*Z**T, B = Q*T*Z**T *> *> where Q and Z are orthogonal matrices, T is upper triangular, and S @@ -52,7 +52,7 @@ *> blocks, the 2-by-2 blocks corresponding to complex conjugate pairs *> of eigenvalues of (A,B). The columns of Q are the left Schur vectors *> and the columns of Z are the right Schur vectors. -*> +*> *> If only the eigenvalues of (A,B) are needed, the driver routine *> SGEGV should be used instead. See SGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEeigen * @@ -227,10 +227,10 @@ SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR diff --git a/lapack-netlib/SRC/DEPRECATED/sgegv.f b/lapack-netlib/SRC/DEPRECATED/sgegv.f index 0491ca13e3..9ffda665d1 100644 --- a/lapack-netlib/SRC/DEPRECATED/sgegv.f +++ b/lapack-netlib/SRC/DEPRECATED/sgegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -30,7 +30,7 @@ * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,7 +151,7 @@ *> \verbatim *> BETA is REAL array, dimension (N) *> The scalars beta that define the eigenvalues of GNEP. -*> +*> *> Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and *> beta = BETA(j) represent the j-th eigenvalue of the matrix *> pair (A,B), in one of the forms lambda = alpha/beta or @@ -260,12 +260,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEeigen * @@ -306,10 +306,10 @@ SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR diff --git a/lapack-netlib/SRC/DEPRECATED/sgelsx.f b/lapack-netlib/SRC/DEPRECATED/sgelsx.f index cbc19a81a0..f45ff0f668 100644 --- a/lapack-netlib/SRC/DEPRECATED/sgelsx.f +++ b/lapack-netlib/SRC/DEPRECATED/sgelsx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, M, N, NRHS, RANK * REAL RCOND @@ -29,7 +29,7 @@ * INTEGER JPVT( * ) * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -44,7 +44,7 @@ *> using a complete orthogonal factorization of A. A is an M-by-N *> matrix which may be rank-deficient. *> -*> Several right hand side vectors b and solution vectors x can be +*> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * @@ -178,10 +178,10 @@ SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/DEPRECATED/sgeqpf.f b/lapack-netlib/SRC/DEPRECATED/sgeqpf.f index 02950e0805..45828d2fb9 100644 --- a/lapack-netlib/SRC/DEPRECATED/sgeqpf.f +++ b/lapack-netlib/SRC/DEPRECATED/sgeqpf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQPF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQPF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER JPVT( * ) * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -279,11 +279,11 @@ SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. -* +* TEMP = ABS( A( I, J ) ) / WORK( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) diff --git a/lapack-netlib/SRC/DEPRECATED/sggsvd.f b/lapack-netlib/SRC/DEPRECATED/sggsvd.f index 0bf3880634..9ab00119aa 100644 --- a/lapack-netlib/SRC/DEPRECATED/sggsvd.f +++ b/lapack-netlib/SRC/DEPRECATED/sggsvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGSVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGSVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -314,12 +314,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERsing * @@ -334,10 +334,10 @@ SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/sggsvp.f b/lapack-netlib/SRC/DEPRECATED/sggsvp.f index 0bbb30b9c7..b2a71a82af 100644 --- a/lapack-netlib/SRC/DEPRECATED/sggsvp.f +++ b/lapack-netlib/SRC/DEPRECATED/sggsvp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGSVP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGSVP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. +*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -235,12 +235,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -256,10 +256,10 @@ SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/slahrd.f b/lapack-netlib/SRC/DEPRECATED/slahrd.f index e4ba36ec4c..54503de041 100644 --- a/lapack-netlib/SRC/DEPRECATED/slahrd.f +++ b/lapack-netlib/SRC/DEPRECATED/slahrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB diff --git a/lapack-netlib/SRC/DEPRECATED/slatzm.f b/lapack-netlib/SRC/DEPRECATED/slatzm.f index f06bf66842..d523f3a665 100644 --- a/lapack-netlib/SRC/DEPRECATED/slatzm.f +++ b/lapack-netlib/SRC/DEPRECATED/slatzm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATZM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,22 +139,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/DEPRECATED/stzrqf.f b/lapack-netlib/SRC/DEPRECATED/stzrqf.f index f2969fc5a8..57c44198fa 100644 --- a/lapack-netlib/SRC/DEPRECATED/stzrqf.f +++ b/lapack-netlib/SRC/DEPRECATED/stzrqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STZRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STZRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/DEPRECATED/zgegs.f b/lapack-netlib/SRC/DEPRECATED/zgegs.f index 9dc9fa711f..038e95236d 100644 --- a/lapack-netlib/SRC/DEPRECATED/zgegs.f +++ b/lapack-netlib/SRC/DEPRECATED/zgegs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, * VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N @@ -32,7 +32,7 @@ * $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -45,13 +45,13 @@ *> left and or/right Schur vectors of a complex matrix pair (A,B). *> Given two square matrices A and B, the generalized Schur *> factorization has the form -*> +*> *> A = Q*S*Z**H, B = Q*T*Z**H -*> +*> *> where Q and Z are unitary matrices and S and T are upper triangular. *> The columns of Q are the left Schur vectors *> and the columns of Z are the right Schur vectors. -*> +*> *> If only the eigenvalues of (A,B) are needed, the driver routine *> ZGEGV should be used instead. See ZGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem @@ -211,12 +211,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEeigen * @@ -225,10 +225,10 @@ SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR diff --git a/lapack-netlib/SRC/DEPRECATED/zgegv.f b/lapack-netlib/SRC/DEPRECATED/zgegv.f index 905ee72cd3..0f662955da 100644 --- a/lapack-netlib/SRC/DEPRECATED/zgegv.f +++ b/lapack-netlib/SRC/DEPRECATED/zgegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, * VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -31,7 +31,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,7 +138,7 @@ *> \verbatim *> BETA is COMPLEX*16 array, dimension (N) *> The complex scalars beta that define the eigenvalues of GNEP. -*> +*> *> Together, the quantities alpha = ALPHA(j) and beta = BETA(j) *> represent the j-th eigenvalue of the matrix pair (A,B), in *> one of the forms lambda = alpha/beta or mu = beta/alpha. @@ -237,12 +237,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEeigen * @@ -282,10 +282,10 @@ SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR diff --git a/lapack-netlib/SRC/DEPRECATED/zgelsx.f b/lapack-netlib/SRC/DEPRECATED/zgelsx.f index f53f0fe11f..fc8d28895c 100644 --- a/lapack-netlib/SRC/DEPRECATED/zgelsx.f +++ b/lapack-netlib/SRC/DEPRECATED/zgelsx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -171,12 +171,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEsolve * @@ -184,10 +184,10 @@ SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/DEPRECATED/zgeqpf.f b/lapack-netlib/SRC/DEPRECATED/zgeqpf.f index 5f1a707075..7dffc7a0c0 100644 --- a/lapack-netlib/SRC/DEPRECATED/zgeqpf.f +++ b/lapack-netlib/SRC/DEPRECATED/zgeqpf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQPF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQPF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -148,10 +148,10 @@ * ===================================================================== SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -286,11 +286,11 @@ SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. -* +* TEMP = ABS( A( I, J ) ) / RWORK( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) diff --git a/lapack-netlib/SRC/DEPRECATED/zggsvd.f b/lapack-netlib/SRC/DEPRECATED/zggsvd.f index db82910ebf..dcbb892fd7 100644 --- a/lapack-netlib/SRC/DEPRECATED/zggsvd.f +++ b/lapack-netlib/SRC/DEPRECATED/zggsvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGSVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGSVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -317,12 +317,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsing * @@ -337,10 +337,10 @@ SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/zggsvp.f b/lapack-netlib/SRC/DEPRECATED/zggsvp.f index aff6c66546..f65de92783 100644 --- a/lapack-netlib/SRC/DEPRECATED/zggsvp.f +++ b/lapack-netlib/SRC/DEPRECATED/zggsvp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGSVP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGSVP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, RWORK, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. +*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -241,12 +241,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -265,10 +265,10 @@ SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/DEPRECATED/zlahrd.f b/lapack-netlib/SRC/DEPRECATED/zlahrd.f index 94acc6d440..fb63e96073 100644 --- a/lapack-netlib/SRC/DEPRECATED/zlahrd.f +++ b/lapack-netlib/SRC/DEPRECATED/zlahrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB diff --git a/lapack-netlib/SRC/DEPRECATED/zlatzm.f b/lapack-netlib/SRC/DEPRECATED/zlatzm.f index 8faa883089..f53010a3d8 100644 --- a/lapack-netlib/SRC/DEPRECATED/zlatzm.f +++ b/lapack-netlib/SRC/DEPRECATED/zlatzm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATZM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,22 +140,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/DEPRECATED/ztzrqf.f b/lapack-netlib/SRC/DEPRECATED/ztzrqf.f index 6678312fa5..7bfb2e0b5b 100644 --- a/lapack-netlib/SRC/DEPRECATED/ztzrqf.f +++ b/lapack-netlib/SRC/DEPRECATED/ztzrqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTZRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTZRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 22799769ab..d3273595df 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -26,9 +26,9 @@ include ../make.inc # precision. # ZLASRC -- Double precision complex LAPACK routines # ZXLASRC -- Double precision complex LAPACK routines using extra -# precision. +# precision. # -# DEPRECATED -- Deprecated routines in all precisions +# DEPRECATED -- Deprecated routines in all precisions # # The library can be set up to include routines for any combination # of the four precisions. To create or add to the library, enter make @@ -56,9 +56,9 @@ include ../make.inc # ####################################################################### -ALLAUX = ilaenv.o ieeeck.o lsamen.o xerbla_array.o iparmq.o \ - ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \ - ../INSTALL/ilaver.o ../INSTALL/slamch.o +ALLAUX_O = ilaenv.o ieeeck.o lsamen.o xerbla.o xerbla_array.o iparmq.o iparam2stage.o\ + ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \ + ../INSTALL/ilaver.o ../INSTALL/lsame.o ../INSTALL/slamch.o SCLAUX = \ sbdsdc.o \ @@ -76,7 +76,7 @@ SCLAUX = \ slasr.o slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \ ssteqr.o ssterf.o slaisnan.o sisnan.o \ slartgp.o slartgs.o \ - ../INSTALL/second_$(TIMER).o + ../INSTALL/second_$(TIMER).o DZLAUX = \ dbdsdc.o \ @@ -96,20 +96,20 @@ DZLAUX = \ dlartgp.o dlartgs.o \ ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o -SLASRC = \ - spotrf2.o sbdsvdx.o sgetrf2.o \ - sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o \ +SLASRC_O = \ + sbdsvdx.o spotrf2.o sgetrf2.o \ + sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o \ sgbsvx.o sgbtf2.o sgbtrf.o sgbtrs.o sgebak.o sgebal.o sgebd2.o \ sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \ sgehd2.o sgehrd.o sgelq2.o sgelqf.o \ sgels.o sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \ sgeqp3.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ - sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesvd.o sgesvdx.o sgesvx.o \ - sgetc2.o sgetri.o \ + sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvdx.o sgesvx.o \ + sgetc2.o sgetf2.o sgetri.o \ sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ sggev.o sggev3.o sggevx.o \ sggglm.o sgghrd.o sgghd3.o sgglse.o sggqrf.o \ - sggrqf.o sggsvd3.o sggsvp3.o sgtcon.o sgtrfs.o sgtsv.o \ + sggrqf.o sggsvd3.o sggsvp3.o sgtcon.o sgtrfs.o sgtsv.o \ sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \ shsein.o shseqr.o slabrd.o slacon.o slacn2.o \ slaein.o slaexc.o slag2.o slags2.o slagtm.o slagv2.o slahqr.o \ @@ -120,21 +120,22 @@ SLASRC = \ slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ - slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slargv.o \ - slarrv.o slartv.o \ - slarz.o slarzb.o slarzt.o slasy2.o slasyf.o slasyf_rook.o \ + slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \ + slarrv.o slartv.o \ + slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ + slasyf_rk.o \ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \ - sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ + slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ sorgrq.o sorgtr.o sorm2l.o sorm2r.o sorm22.o \ sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \ sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \ spbstf.o spbsv.o spbsvx.o \ - spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o \ - sposvx.o spotri.o spstrf.o spstf2.o \ + spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o \ + sposvx.o spotf2.o spotri.o spstrf.o spstf2.o \ sppcon.o sppequ.o \ spprfs.o sppsv.o sppsvx.o spptrf.o spptri.o spptrs.o sptcon.o \ - spteqr.o sptrfs.o sptsv.o sptsvx.o spttrs.o sptts2.o srscl.o \ + spteqr.o sptrfs.o sptsv.o sptsvx.o spttrs.o sptts2.o srscl.o \ ssbev.o ssbevd.o ssbevx.o ssbgst.o ssbgv.o ssbgvd.o ssbgvx.o \ ssbtrd.o sspcon.o sspev.o sspevd.o sspevx.o sspgst.o \ sspgv.o sspgvd.o sspgvx.o ssprfs.o sspsv.o sspsvx.o ssptrd.o \ @@ -143,37 +144,47 @@ SLASRC = \ ssycon.o ssyev.o ssyevd.o ssyevr.o ssyevx.o ssygs2.o \ ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \ ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ - ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \ + ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o ssyconvf_rook.o \ ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ ssytri_rook.o ssycon_rook.o ssysv_rook.o \ + ssytf2_rk.o ssytrf_rk.o ssytrs_3.o \ + ssytri_3.o ssytri_3x.o ssycon_3.o ssysv_rk.o \ + slasyf_aa.o ssysv_aa.o ssytrf_aa.o ssytrs_aa.o \ stbcon.o \ stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \ stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \ stptrs.o \ - strcon.o strevc.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \ - strtrs.o stzrzf.o sstemr.o \ + strcon.o strevc.o strevc3.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \ + strti2.o strtri.o strtrs.o stzrzf.o sstemr.o \ slansf.o spftrf.o spftri.o spftrs.o ssfrk.o stfsm.o stftri.o stfttp.o \ stfttr.o stpttf.o stpttr.o strttf.o strttp.o \ - sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \ + sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \ sgeequb.o ssyequb.o spoequb.o sgbequb.o \ sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \ sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \ sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \ - stpqrt.o stpqrt2.o stpmqrt.o stprfb.o + stpqrt.o stpqrt2.o stpmqrt.o stprfb.o \ + sgelqt.o sgelqt3.o sgemlqt.o \ + sgetsls.o sgeqr.o slatsqr.o slamtsqr.o sgemqr.o \ + sgelq.o slaswlq.o slamswlq.o sgemlq.o \ + stplqt.o stplqt2.o stpmlqt.o \ + ssytrd_2stage.o ssytrd_sy2sb.o ssytrd_sb2st.o ssb2st_kernels.o \ + ssyevd_2stage.o ssyev_2stage.o ssyevx_2stage.o ssyevr_2stage.o \ + ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o -DSLASRC = spotrs.o +DSLASRC_O = spotrs.o sgetrs.o spotrf.o sgetrf.o ifdef USEXBLAS -SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \ - sla_gercond.o sla_gerpvgrw.o ssysvxx.o ssyrfsx.o \ - sla_syrfsx_extended.o sla_syamv.o sla_syrcond.o sla_syrpvgrw.o \ - sposvxx.o sporfsx.o sla_porfsx_extended.o sla_porcond.o \ - sla_porpvgrw.o sgbsvxx.o sgbrfsx.o sla_gbrfsx_extended.o \ - sla_gbamv.o sla_gbrcond.o sla_gbrpvgrw.o sla_lin_berr.o slarscl2.o \ +SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \ + sla_gercond.o sla_gerpvgrw.o ssysvxx.o ssyrfsx.o \ + sla_syrfsx_extended.o sla_syamv.o sla_syrcond.o sla_syrpvgrw.o \ + sposvxx.o sporfsx.o sla_porfsx_extended.o sla_porcond.o \ + sla_porpvgrw.o sgbsvxx.o sgbrfsx.o sla_gbrfsx_extended.o \ + sla_gbamv.o sla_gbrcond.o sla_gbrpvgrw.o sla_lin_berr.o slarscl2.o \ slascl2.o sla_wwaddw.o endif -CLASRC = \ +CLASRC_O = \ cpotrf2.o cgetrf2.o \ cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o cgbsvx.o \ cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \ @@ -181,29 +192,33 @@ CLASRC = \ cgehd2.o cgehrd.o cgelq2.o cgelqf.o \ cgels.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \ cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ - cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesvd.o cgesvdx.o \ + cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvdx.o \ cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \ - cgesvx.o cgetc2.o cgetri.o \ + cgesvx.o cgetc2.o cgetf2.o cgetri.o \ cggbak.o cggbal.o cgges.o cgges3.o cggesx.o \ - cggev.o cggev3.o cggevx.o cggglm.o\ + cggev.o cggev3.o cggevx.o cggglm.o \ cgghrd.o cgghd3.o cgglse.o cggqrf.o cggrqf.o \ cggsvd3.o cggsvp3.o \ - cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \ + cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \ chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \ checon.o cheev.o cheevd.o cheevr.o cheevx.o chegs2.o chegst.o \ chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \ chetf2.o chetrd.o \ chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \ chetrs.o chetrs2.o \ - chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \ + chetf2_rook.o chetrf_rook.o chetri_rook.o \ + chetrs_rook.o checon_rook.o chesv_rook.o \ + chetf2_rk.o chetrf_rk.o chetri_3.o chetri_3x.o \ + chetrs_3.o checon_3.o chesv_rk.o \ + chesv_aa.o chetrf_aa.o chetrs_aa.o clahef_aa.o\ chgeqz.o chpcon.o chpev.o chpevd.o \ - chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ + chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ chpsvx.o \ chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \ clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \ claed0.o claed7.o claed8.o \ claein.o claesy.o claev2.o clags2.o clagtm.o \ - clahef.o clahef_rook.o clahqr.o \ + clahef.o clahef_rook.o clahef_rk.o clahqr.o \ clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \ clanhb.o clanhe.o \ clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ @@ -212,27 +227,31 @@ CLASRC = \ claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \ claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \ - clarfx.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ + clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ - clasyf.o clasyf_rook.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ - cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ + claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ + clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ + clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ - cposv.o cposvx.o cpotri.o cpstrf.o cpstf2.o \ + cposv.o cposvx.o cpotf2.o cpotri.o cpstrf.o cpstf2.o \ cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ cptcon.o cpteqr.o cptrfs.o cptsv.o cptsvx.o cpttrf.o cpttrs.o cptts2.o \ - crot.o cspcon.o csprfs.o cspsv.o \ + crot.o cspcon.o cspmv.o cspr.o csprfs.o cspsv.o \ cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \ cstegr.o cstein.o csteqr.o \ - csycon.o \ - csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \ - csyswapr.o csytrs.o csytrs2.o csyconv.o \ + csycon.o csymv.o \ + csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \ + csyswapr.o csytrs.o csytrs2.o \ + csyconv.o csyconvf.o csyconvf_rook.o \ csytf2_rook.o csytrf_rook.o csytrs_rook.o \ csytri_rook.o csycon_rook.o csysv_rook.o \ + csytf2_rk.o csytrf_rk.o csytrf_aa.o csytrs_3.o csytrs_aa.o \ + csytri_3.o csytri_3x.o csycon_3.o csysv_rk.o csysv_aa.o \ ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \ ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \ ctprfs.o ctptri.o \ - ctptrs.o ctrcon.o ctrevc.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \ - ctrsyl.o ctrtrs.o ctzrzf.o cung2l.o cung2r.o \ + ctptrs.o ctrcon.o ctrevc.o ctrevc3.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \ + ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrzf.o cung2l.o cung2r.o \ cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \ cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o cunm22.o \ cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \ @@ -243,7 +262,14 @@ CLASRC = \ cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \ cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \ cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \ - ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o + ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o \ + cgelqt.o cgelqt3.o cgemlqt.o \ + cgetsls.o cgeqr.o clatsqr.o clamtsqr.o cgemqr.o \ + cgelq.o claswlq.o clamswlq.o cgemlq.o \ + ctplqt.o ctplqt2.o ctpmlqt.o \ + chetrd_2stage.o chetrd_he2hb.o chetrd_hb2st.o chb2st_kernels.o \ + cheevd_2stage.o cheev_2stage.o cheevx_2stage.o cheevr_2stage.o \ + chbev_2stage.o chbevx_2stage.o chbevd_2stage.o chegv_2stage.o ifdef USEXBLAS CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \ @@ -259,23 +285,23 @@ CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \ cla_lin_berr.o clarscl2.o clascl2.o cla_wwaddw.o endif -ZCLASRC = cpotrs.o +ZCLASRC_O = cpotrs.o cgetrs.o cpotrf.o cgetrf.o -DLASRC = \ +DLASRC_O = \ dpotrf2.o dgetrf2.o \ dbdsvdx.o \ - dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \ + dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \ dgbsvx.o dgbtf2.o dgbtrf.o dgbtrs.o dgebak.o dgebal.o dgebd2.o \ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ dgels.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ - dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesvd.o dgesvdx.o dgesvx.o \ - dgetc2.o dgetri.o \ - dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ + dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvdx.o dgesvx.o \ + dgetc2.o dgetf2.o dgetrf.o dgetri.o \ + dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ dggev.o dggev3.o dggevx.o \ dggglm.o dgghrd.o dgghd3.o dgglse.o dggqrf.o \ - dggrqf.o dggsvd3.o dggsvp3.o dgtcon.o dgtrfs.o dgtsv.o \ + dggrqf.o dggsvd3.o dggsvp3.o dgtcon.o dgtrfs.o dgtsv.o \ dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \ dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \ dlaein.o dlaexc.o dlag2.o dlags2.o dlagtm.o dlagv2.o dlahqr.o \ @@ -286,23 +312,24 @@ DLASRC = \ dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ - dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o \ - dlargv.o dlarrv.o dlartv.o \ - dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o dlasyf_rook.o \ - dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o \ - dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ + dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ + dlargv.o dlarrv.o dlartv.o \ + dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ + dlasyf.o dlasyf_rook.o dlasyf_rk.o \ + dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \ + dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ dorgrq.o dorgtr.o dorm2l.o dorm2r.o dorm22.o \ dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \ dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \ dpbstf.o dpbsv.o dpbsvx.o \ - dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o \ - dposvx.o dpotri.o dpotrs.o dpstrf.o dpstf2.o \ + dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o \ + dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dpstrf.o dpstf2.o \ dppcon.o dppequ.o \ dpprfs.o dppsv.o dppsvx.o dpptrf.o dpptri.o dpptrs.o dptcon.o \ - dpteqr.o dptrfs.o dptsv.o dptsvx.o dpttrs.o dptts2.o drscl.o \ + dpteqr.o dptrfs.o dptsv.o dptsvx.o dpttrs.o dptts2.o drscl.o \ dsbev.o dsbevd.o dsbevx.o dsbgst.o dsbgv.o dsbgvd.o dsbgvx.o \ - dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \ + dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \ dspgv.o dspgvd.o dspgvx.o dsprfs.o dspsv.o dspsvx.o dsptrd.o \ dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o dstevd.o dstevr.o \ dstevx.o \ @@ -310,35 +337,46 @@ DLASRC = \ dsyevx.o dsygs2.o dsygst.o dsygv.o dsygvd.o dsygvx.o dsyrfs.o \ dsysv.o dsysvx.o \ dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ - dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \ + dsyswapr.o dsytrs.o dsytrs2.o \ + dsyconv.o dsyconvf.o dsyconvf_rook.o \ dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ dsytri_rook.o dsycon_rook.o dsysv_rook.o \ + dsytf2_rk.o dsytrf_rk.o dsytrs_3.o \ + dsytri_3.o dsytri_3x.o dsycon_3.o dsysv_rk.o \ + dlasyf_aa.o dsysv_aa.o dsytrf_aa.o dsytrs_aa.o \ dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \ dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \ dtptrs.o \ - dtrcon.o dtrevc.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \ - dtrtrs.o dtzrzf.o dstemr.o \ + dtrcon.o dtrevc.o dtrevc3.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \ + dtrti2.o dtrtri.o dtrtrs.o dtzrzf.o dstemr.o \ dsgesv.o dsposv.o dlag2s.o slag2d.o dlat2s.o \ dlansf.o dpftrf.o dpftri.o dpftrs.o dsfrk.o dtfsm.o dtftri.o dtfttp.o \ dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \ - dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \ + dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \ dgeequb.o dsyequb.o dpoequb.o dgbequb.o \ dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \ dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \ dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \ - dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o + dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o \ + dgelqt.o dgelqt3.o dgemlqt.o \ + dgetsls.o dgeqr.o dlatsqr.o dlamtsqr.o dgemqr.o \ + dgelq.o dlaswlq.o dlamswlq.o dgemlq.o \ + dtplqt.o dtplqt2.o dtpmlqt.o \ + dsytrd_2stage.o dsytrd_sy2sb.o dsytrd_sb2st.o dsb2st_kernels.o \ + dsyevd_2stage.o dsyev_2stage.o dsyevx_2stage.o dsyevr_2stage.o \ + dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o ifdef USEXBLAS -DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ - dla_gercond.o dla_gerpvgrw.o dsysvxx.o dsyrfsx.o \ - dla_syrfsx_extended.o dla_syamv.o dla_syrcond.o dla_syrpvgrw.o \ - dposvxx.o dporfsx.o dla_porfsx_extended.o dla_porcond.o \ - dla_porpvgrw.o dgbsvxx.o dgbrfsx.o dla_gbrfsx_extended.o \ - dla_gbamv.o dla_gbrcond.o dla_gbrpvgrw.o dla_lin_berr.o dlarscl2.o \ +DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ + dla_gercond.o dla_gerpvgrw.o dsysvxx.o dsyrfsx.o \ + dla_syrfsx_extended.o dla_syamv.o dla_syrcond.o dla_syrpvgrw.o \ + dposvxx.o dporfsx.o dla_porfsx_extended.o dla_porcond.o \ + dla_porpvgrw.o dgbsvxx.o dgbrfsx.o dla_gbrfsx_extended.o \ + dla_gbamv.o dla_gbrcond.o dla_gbrpvgrw.o dla_lin_berr.o dlarscl2.o \ dlascl2.o dla_wwaddw.o endif -ZLASRC = \ +ZLASRC_O = \ zpotrf2.o zgetrf2.o \ zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o zgbsvx.o \ zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \ @@ -346,30 +384,34 @@ ZLASRC = \ zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ zgels.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \ zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ - zgesc2.o zgesdd.o zgesvd.o zgesvdx.o \ + zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ - zgesvx.o zgetc2.o \ - zgetri.o \ - zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \ + zgesvx.o zgetc2.o zgetf2.o zgetrf.o \ + zgetri.o zgetrs.o \ + zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \ zggev.o zggev3.o zggevx.o zggglm.o \ zgghrd.o zgghd3.o zgglse.o zggqrf.o zggrqf.o \ zggsvd3.o zggsvp3.o \ - zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \ + zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \ zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \ zhecon.o zheev.o zheevd.o zheevr.o zheevx.o zhegs2.o zhegst.o \ zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \ zhetf2.o zhetrd.o \ zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \ zhetrs.o zhetrs2.o \ - zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhetf2_rook.o zhetrf_rook.o zhetri_rook.o \ + zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhetf2_rk.o zhetrf_rk.o zhetri_3.o zhetri_3x.o \ + zhetrs_3.o zhecon_3.o zhesv_rk.o \ + zhesv_aa.o zhetrf_aa.o zhetrs_aa.o zlahef_aa.o \ zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ - zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ + zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ zhpsvx.o \ zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \ zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \ zlaed0.o zlaed7.o zlaed8.o \ zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \ - zlahef.o zlahef_rook.o zlahqr.o \ + zlahef.o zlahef_rook.o zlahef_rk.o zlahqr.o \ zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \ zlangt.o zlanhb.o \ zlanhe.o \ @@ -380,28 +422,31 @@ ZLASRC = \ zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ zlarcm.o zlarf.o zlarfb.o \ zlarfg.o zlarft.o zlarfgp.o \ - zlarfx.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ - zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ - zlassq.o zlasyf.o zlasyf_rook.o \ - zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o \ - zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ + zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ + zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ + zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \ + zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlauu2.o \ + zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ - zposv.o zposvx.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ + zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ zptcon.o zpteqr.o zptrfs.o zptsv.o zptsvx.o zpttrf.o zpttrs.o zptts2.o \ - zrot.o zspcon.o zsprfs.o zspsv.o \ + zrot.o zspcon.o zspmv.o zspr.o zsprfs.o zspsv.o \ zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \ zstegr.o zstein.o zsteqr.o \ - zsycon.o \ - zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \ - zsyswapr.o zsytrs.o zsytrs2.o zsyconv.o \ - zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o \ + zsycon.o zsymv.o \ + zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \ + zsyswapr.o zsytrs.o zsytrs2.o \ + zsyconv.o zsyconvf.o zsyconvf_rook.o \ + zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o zsytrs_aa.o \ zsytri_rook.o zsycon_rook.o zsysv_rook.o \ + zsytf2_rk.o zsytrf_rk.o zsytrf_aa.o zsytrs_3.o \ + zsytri_3.o zsytri_3x.o zsycon_3.o zsysv_rk.o zsysv_aa.o \ ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \ ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \ ztprfs.o ztptri.o \ - ztptrs.o ztrcon.o ztrevc.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \ - ztrsyl.o ztrtrs.o ztzrzf.o zung2l.o \ + ztptrs.o ztrcon.o ztrevc.o ztrevc3.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \ + ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrzf.o zung2l.o \ zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \ zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o zunm22.o \ zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \ @@ -414,32 +459,75 @@ ZLASRC = \ zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \ zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \ zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \ - ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o + ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o \ + ztplqt.o ztplqt2.o ztpmlqt.o \ + zgelqt.o zgelqt3.o zgemlqt.o \ + zgetsls.o zgeqr.o zlatsqr.o zlamtsqr.o zgemqr.o \ + zgelq.o zlaswlq.o zlamswlq.o zgemlq.o \ + zhetrd_2stage.o zhetrd_he2hb.o zhetrd_hb2st.o zhb2st_kernels.o \ + zheevd_2stage.o zheev_2stage.o zheevx_2stage.o zheevr_2stage.o \ + zhbev_2stage.o zhbevx_2stage.o zhbevd_2stage.o zhegv_2stage.o ifdef USEXBLAS -ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \ - zla_gercond_c.o zla_gercond_x.o zla_gerpvgrw.o zsysvxx.o zsyrfsx.o \ - zla_syrfsx_extended.o zla_syamv.o zla_syrcond_c.o zla_syrcond_x.o \ - zla_syrpvgrw.o zposvxx.o zporfsx.o zla_porfsx_extended.o \ - zla_porcond_c.o zla_porcond_x.o zla_porpvgrw.o zgbsvxx.o zgbrfsx.o \ - zla_gbrfsx_extended.o zla_gbamv.o zla_gbrcond_c.o zla_gbrcond_x.o \ - zla_gbrpvgrw.o zhesvxx.o zherfsx.o zla_herfsx_extended.o \ - zla_heamv.o zla_hercond_c.o zla_hercond_x.o zla_herpvgrw.o \ +ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \ + zla_gercond_c.o zla_gercond_x.o zla_gerpvgrw.o zsysvxx.o zsyrfsx.o \ + zla_syrfsx_extended.o zla_syamv.o zla_syrcond_c.o zla_syrcond_x.o \ + zla_syrpvgrw.o zposvxx.o zporfsx.o zla_porfsx_extended.o \ + zla_porcond_c.o zla_porcond_x.o zla_porpvgrw.o zgbsvxx.o zgbrfsx.o \ + zla_gbrfsx_extended.o zla_gbamv.o zla_gbrcond_c.o zla_gbrcond_x.o \ + zla_gbrpvgrw.o zhesvxx.o zherfsx.o zla_herfsx_extended.o \ + zla_heamv.o zla_hercond_c.o zla_hercond_x.o zla_herpvgrw.o \ zla_lin_berr.o zlarscl2.o zlascl2.o zla_wwaddw.o endif -DEPRECSRC = DEPRECATED/cgegs.o DEPRECATED/cgegv.o DEPRECATED/cgelsx.o \ - DEPRECATED/cgeqpf.o DEPRECATED/cggsvd.o DEPRECATED/cggsvp.o \ - DEPRECATED/clahrd.o DEPRECATED/clatzm.o DEPRECATED/ctzrqf.o \ - DEPRECATED/dgegs.o DEPRECATED/dgegv.o DEPRECATED/dgelsx.o \ - DEPRECATED/dgeqpf.o DEPRECATED/dggsvd.o DEPRECATED/dggsvp.o \ - DEPRECATED/dlahrd.o DEPRECATED/dlatzm.o DEPRECATED/dtzrqf.o \ - DEPRECATED/sgegs.o DEPRECATED/sgegv.o DEPRECATED/sgelsx.o \ - DEPRECATED/sgeqpf.o DEPRECATED/sggsvd.o DEPRECATED/sggsvp.o \ - DEPRECATED/slahrd.o DEPRECATED/slatzm.o DEPRECATED/stzrqf.o \ - DEPRECATED/zgegs.o DEPRECATED/zgegv.o DEPRECATED/zgelsx.o \ - DEPRECATED/zgeqpf.o DEPRECATED/zggsvd.o DEPRECATED/zggsvp.o \ - DEPRECATED/zlahrd.o DEPRECATED/zlatzm.o DEPRECATED/ztzrqf.o +DEPRECSRC = DEPRECATED/cgegs.o DEPRECATED/cgegv.o DEPRECATED/cgelsx.o \ + DEPRECATED/cgeqpf.o DEPRECATED/cggsvd.o DEPRECATED/cggsvp.o \ + DEPRECATED/clahrd.o DEPRECATED/clatzm.o DEPRECATED/ctzrqf.o \ + DEPRECATED/dgegs.o DEPRECATED/dgegv.o DEPRECATED/dgelsx.o \ + DEPRECATED/dgeqpf.o DEPRECATED/dggsvd.o DEPRECATED/dggsvp.o \ + DEPRECATED/dlahrd.o DEPRECATED/dlatzm.o DEPRECATED/dtzrqf.o \ + DEPRECATED/sgegs.o DEPRECATED/sgegv.o DEPRECATED/sgelsx.o \ + DEPRECATED/sgeqpf.o DEPRECATED/sggsvd.o DEPRECATED/sggsvp.o \ + DEPRECATED/slahrd.o DEPRECATED/slatzm.o DEPRECATED/stzrqf.o \ + DEPRECATED/zgegs.o DEPRECATED/zgegv.o DEPRECATED/zgelsx.o \ + DEPRECATED/zgeqpf.o DEPRECATED/zggsvd.o DEPRECATED/zggsvp.o \ + DEPRECATED/zlahrd.o DEPRECATED/zlatzm.o DEPRECATED/ztzrqf.o + +# filter out optimized codes from OpenBLAS +ALL_AUX_OBJS = xerbla.o ../INSTALL/lsame.o + +SLAPACKOBJS = \ + sgetrf.o sgetrs.o spotrf.o sgetf2.o \ + spotf2.o slaswp.o sgesv.o slauu2.o \ + slauum.o strti2.o strtri.o + +DLAPACKOBJS = \ + dgetrf.o dgetrs.o dpotrf.o dgetf2.o \ + dpotf2.o dlaswp.o dgesv.o dlauu2.o \ + dlauum.o dtrti2.o dtrtri.o + +CLAPACKOBJS = \ + cgetrf.o cgetrs.o cpotrf.o cgetf2.o \ + cpotf2.o claswp.o cgesv.o clauu2.o \ + clauum.o ctrti2.o ctrtri.o + +ZLAPACKOBJS = \ + zgetrf.o zgetrs.o zpotrf.o zgetf2.o \ + zpotf2.o zlaswp.o zgesv.o zlauu2.o \ + zlauum.o ztrti2.o ztrtri.o + + +ALLAUX = $(filter-out $(ALL_AUX_OBJS),$(ALLAUX_O)) +SLASRC = $(filter-out $(SLAPACKOBJS),$(SLASRC_O)) +DLASRC = $(filter-out $(DLAPACKOBJS),$(DLASRC_O)) +CLASRC = $(filter-out $(CLAPACKOBJS),$(CLASRC_O)) +ZLASRC = $(filter-out $(ZLAPACKOBJS),$(ZLASRC_O)) +DSLASRC = $(filter-out $(SLAPACKOBJS),$(DSLASRC_O)) +ZCLASRC = $(filter-out $(CLAPACKOBJS),$(ZCLASRC_O)) + +OPTS1 = $(filter-out -fopenmp, $(OPTS)) +#end filter out + ALLOBJ = $(SLASRC) $(DLASRC) $(DSLASRC) $(CLASRC) $(ZLASRC) $(ZCLASRC) \ $(SCLAUX) $(DZLAUX) $(ALLAUX) @@ -460,22 +548,22 @@ all: ../$(LAPACKLIB) single: $(SLASRC) $(DSLASRC) $(SXLASRC) $(SCLAUX) $(ALLAUX) $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(SLASRC) $(DSLASRC) \ - $(SXLASRC) $(SCLAUX) $(ALLAUX) $(ALLXAUX) + $(SXLASRC) $(SCLAUX) $(ALLAUX) $(RANLIB) ../$(LAPACKLIB) complex: $(CLASRC) $(ZCLASRC) $(CXLASRC) $(SCLAUX) $(ALLAUX) $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(CLASRC) $(ZCLASRC) \ - $(CXLASRC) $(SCLAUX) $(ALLAUX) $(ALLXAUX) + $(CXLASRC) $(SCLAUX) $(ALLAUX) $(RANLIB) ../$(LAPACKLIB) double: $(DLASRC) $(DSLASRC) $(DXLASRC) $(DZLAUX) $(ALLAUX) $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(DLASRC) $(DSLASRC) \ - $(DXLASRC) $(DZLAUX) $(ALLAUX) $(ALLXAUX) + $(DXLASRC) $(DZLAUX) $(ALLAUX) $(RANLIB) ../$(LAPACKLIB) complex16: $(ZLASRC) $(ZCLASRC) $(ZXLASRC) $(DZLAUX) $(ALLAUX) $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(ZLASRC) $(ZCLASRC) \ - $(ZXLASRC) $(DZLAUX) $(ALLAUX) $(ALLXAUX) + $(ZXLASRC) $(DZLAUX) $(ALLAUX) $(RANLIB) ../$(LAPACKLIB) $(ALLAUX): $(FRC) @@ -500,13 +588,15 @@ FRC: clean: rm -f *.o DEPRECATED/*.o -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ - -slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -dlaruv.o: dlaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -sla_wwaddw.o: sla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -dla_wwaddw.o: dla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -cla_wwaddw.o: cla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ -zla_wwaddw.o: zla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +.f.o: + $(FORTRAN) $(OPTS1) -c -o $@ $< +.F.o: + $(FORTRAN) $(OPTS1) -c $< -o $@ + +slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dlaruv.o: dlaruv.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +sla_wwaddw.o: sla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dla_wwaddw.o: dla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +cla_wwaddw.o: cla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +zla_wwaddw.o: zla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< diff --git a/lapack-netlib/SRC/VARIANTS/Makefile b/lapack-netlib/SRC/VARIANTS/Makefile index 42446eb559..6db97e9510 100644 --- a/lapack-netlib/SRC/VARIANTS/Makefile +++ b/lapack-netlib/SRC/VARIANTS/Makefile @@ -8,7 +8,7 @@ include ../../make.inc # LUCR -- Crout Level 3 BLAS version of LU factorization # LULL -- left-looking Level 3 BLAS version of LU factorization # QRLL -- left-looking Level 3 BLAS version of QR factorization -# LUREC -- an iterative version of Sivan Toledo's recursive LU algorithm[1]. +# LUREC -- an iterative version of Sivan Toledo's recursive LU algorithm[1]. # For square matrices, this iterative versions should # be within a factor of two of the optimum number of memory transfers. # @@ -17,7 +17,7 @@ include ../../make.inc # 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 ####################################################################### -VARIANTSDIR=LIB +VARIANTSDIR = LIB CHOLRL = cholesky/RL/cpotrf.o cholesky/RL/dpotrf.o cholesky/RL/spotrf.o cholesky/RL/zpotrf.o @@ -29,7 +29,7 @@ LULL = lu/LL/cgetrf.o lu/LL/dgetrf.o lu/LL/sgetrf.o lu/LL/zgetrf.o LUREC = lu/REC/cgetrf.o lu/REC/dgetrf.o lu/REC/sgetrf.o lu/REC/zgetrf.o -QRLL = qr/LL/cgeqrf.o qr/LL/dgeqrf.o qr/LL/sgeqrf.o qr/LL/zgeqrf.o qr/LL/sceil.o +QRLL = qr/LL/cgeqrf.o qr/LL/dgeqrf.o qr/LL/sgeqrf.o qr/LL/zgeqrf.o qr/LL/sceil.o all: cholrl choltop lucr lull lurec qrll @@ -53,15 +53,15 @@ lull: $(LULL) lurec: $(LUREC) $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lurec.a $(LUREC) $(RANLIB) $(VARIANTSDIR)/lurec.a - + qrll: $(QRLL) - $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/qrll.a $(QRLL) + $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/qrll.a $(QRLL) $(RANLIB) $(VARIANTSDIR)/qrll.a -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ - +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< + clean: rm -f $(CHOLRL) $(CHOLTOP) $(LUCR) $(LULL) $(LUREC) $(QRLL) \ - $(VARIANTSDIR)/*.a \ No newline at end of file + $(VARIANTSDIR)/*.a diff --git a/lapack-netlib/SRC/VARIANTS/README b/lapack-netlib/SRC/VARIANTS/README index 64fcdca902..c206215155 100644 --- a/lapack-netlib/SRC/VARIANTS/README +++ b/lapack-netlib/SRC/VARIANTS/README @@ -9,7 +9,7 @@ It is composed of 5 sections: - Testing - Linking your program - Support - + Author: Peng DU and Julie LANGOU, May 2008 =============== @@ -23,16 +23,16 @@ This directory contains several variants of LAPACK routines in single/double/com - [sdcz]geqrf with QR Left Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/qr/LL - [sdcz]potrf with Cholesky Right Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/RL - [sdcz]potrf with Cholesky Top Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/TOP - + References:For a more detailed description please refer to - [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 - [2]LAWN XXX - + ========= = BUILD = ========= - + These variants are compiled by default in the build process but they are not tested by default. The build process creates one new library per variants in the four arithmetics (singel/double/comple/double complex). The libraries are in the SRC/VARIANTS/LIB directory. @@ -44,7 +44,7 @@ Corresponding libraries created in SRC/VARIANTS/LIB: - QR Left Looking : qrll.a - Cholesky Right Looking : cholrl.a - Cholesky Top : choltop.a - + =========== = TESTING = diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/RL/cpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/RL/cpotrf.f index 0f45856ac7..8cec8809ff 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/RL/cpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/RL/cpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -190,11 +190,11 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * * Updating the trailing submatrix. * - CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', + CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), $ LDA, A( J, J+JB ), LDA ) - CALL CHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, - $ JB, -ONE, A( J, J+JB ), LDA, + CALL CHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, + $ JB, -ONE, A( J, J+JB ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 10 CONTINUE @@ -219,12 +219,12 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * * Updating the trailing submatrix. * - CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', + CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), $ LDA, A( J+JB, J ), LDA ) - CALL CHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, - $ -ONE, A( J+JB, J ), LDA, + CALL CHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, + $ -ONE, A( J+JB, J ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 20 CONTINUE diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/RL/dpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/RL/dpotrf.f index ce323b4b5e..400fbf7e53 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/RL/dpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/RL/dpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -193,7 +193,7 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) CALL DSYRK( 'Upper', 'Transpose', N-J-JB+1, JB, -ONE, - $ A( J, J+JB ), LDA, + $ A( J, J+JB ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 10 CONTINUE @@ -222,8 +222,8 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) $ N-J-JB+1, JB, ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) - CALL DSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, - $ -ONE, A( J+JB, J ), LDA, + CALL DSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, + $ -ONE, A( J+JB, J ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 20 CONTINUE diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/RL/spotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/RL/spotrf.f index 21b0b41a46..090e528aed 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/RL/spotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/RL/spotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -193,7 +193,7 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) CALL SSYRK( 'Upper', 'Transpose', N-J-JB+1, JB, -ONE, - $ A( J, J+JB ), LDA, + $ A( J, J+JB ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 10 CONTINUE @@ -222,8 +222,8 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) $ N-J-JB+1, JB, ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) - CALL SSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, - $ -ONE, A( J+JB, J ), LDA, + CALL SSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, + $ -ONE, A( J+JB, J ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 20 CONTINUE diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/RL/zpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/RL/zpotrf.f index 39e72c83bc..149eaacc28 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/RL/zpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/RL/zpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -190,11 +190,11 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * * Updating the trailing submatrix. * - CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', + CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), $ LDA, A( J, J+JB ), LDA ) - CALL ZHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, - $ JB, -ONE, A( J, J+JB ), LDA, + CALL ZHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, + $ JB, -ONE, A( J, J+JB ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 10 CONTINUE @@ -219,12 +219,12 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * * Updating the trailing submatrix. * - CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', + CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), $ LDA, A( J+JB, J ), LDA ) - CALL ZHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, - $ -ONE, A( J+JB, J ), LDA, + CALL ZHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, + $ -ONE, A( J+JB, J ), LDA, $ ONE, A( J+JB, J+JB ), LDA ) END IF 20 CONTINUE diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/cpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/cpotrf.f index e42a78f954..fd2b13e61c 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/cpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/cpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -180,11 +180,11 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * * Compute the current block. * - CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', + CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', $ 'Non-unit', J-1, JB, CONE, A( 1, 1 ), LDA, $ A( 1, J ), LDA ) - CALL CHERK( 'Upper', 'Conjugate Transpose', JB, J-1, + CALL CHERK( 'Upper', 'Conjugate Transpose', JB, J-1, $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test @@ -206,12 +206,12 @@ SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO ) * * Compute the current block. * - CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', + CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', $ 'Non-unit', JB, J-1, CONE, A( 1, 1 ), LDA, $ A( J, 1 ), LDA ) - CALL CHERK( 'Lower', 'No Transpose', JB, J-1, - $ -ONE, A( J, 1 ), LDA, + CALL CHERK( 'Lower', 'No Transpose', JB, J-1, + $ -ONE, A( J, 1 ), LDA, $ ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/dpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/dpotrf.f index c91669b562..dbb51c415f 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/dpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/dpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -184,7 +184,7 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) $ A( 1, J ), LDA ) CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, + $ A( 1, J ), LDA, $ ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test @@ -210,10 +210,10 @@ SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO ) $ JB, J-1, ONE, A( 1, 1 ), LDA, $ A( J, 1 ), LDA ) - CALL DSYRK( 'Lower', 'No Transpose', JB, J-1, - $ -ONE, A( J, 1 ), LDA, + CALL DSYRK( 'Lower', 'No Transpose', JB, J-1, + $ -ONE, A( J, 1 ), LDA, $ ONE, A( J, J ), LDA ) - + * * Update and factorize the current diagonal block and test * for non-positive-definiteness. diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/spotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/spotrf.f index 4a46f723dc..81034df37d 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/spotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/spotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -184,7 +184,7 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) $ A( 1, J ), LDA ) CALL SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, + $ A( 1, J ), LDA, $ ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test @@ -210,8 +210,8 @@ SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO ) $ JB, J-1, ONE, A( 1, 1 ), LDA, $ A( J, 1 ), LDA ) - CALL SSYRK( 'Lower', 'No Transpose', JB, J-1, - $ -ONE, A( J, 1 ), LDA, + CALL SSYRK( 'Lower', 'No Transpose', JB, J-1, + $ -ONE, A( J, 1 ), LDA, $ ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test diff --git a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/zpotrf.f b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/zpotrf.f index 9d4f636a38..0096670905 100644 --- a/lapack-netlib/SRC/VARIANTS/cholesky/TOP/zpotrf.f +++ b/lapack-netlib/SRC/VARIANTS/cholesky/TOP/zpotrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsPOcomputational * @@ -103,7 +103,7 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -180,11 +180,11 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * * Compute the current block. * - CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', + CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', $ 'Non-unit', J-1, JB, CONE, A( 1, 1 ), LDA, $ A( 1, J ), LDA ) - CALL ZHERK( 'Upper', 'Conjugate Transpose', JB, J-1, + CALL ZHERK( 'Upper', 'Conjugate Transpose', JB, J-1, $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test @@ -206,12 +206,12 @@ SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO ) * * Compute the current block. * - CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', + CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', $ 'Non-unit', JB, J-1, CONE, A( 1, 1 ), LDA, $ A( J, 1 ), LDA ) - CALL ZHERK( 'Lower', 'No Transpose', JB, J-1, - $ -ONE, A( J, 1 ), LDA, + CALL ZHERK( 'Lower', 'No Transpose', JB, J-1, + $ -ONE, A( J, 1 ), LDA, $ ONE, A( J, J ), LDA ) * * Update and factorize the current diagonal block and test diff --git a/lapack-netlib/SRC/VARIANTS/lu/CR/cgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/CR/cgetrf.f index 665ef82dd5..2bddb4452c 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/CR/cgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/CR/cgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -171,11 +171,11 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) * * Update current block. * - CALL CGEMM( 'No transpose', 'No transpose', - $ M-J+1, JB, J-1, -ONE, + CALL CGEMM( 'No transpose', 'No transpose', + $ M-J+1, JB, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J ), LDA, ONE, $ A( J, J ), LDA ) - + * * Factor diagonal and subdiagonal blocks and test for exact * singularity. @@ -189,27 +189,27 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE -* -* Apply interchanges to column 1:J-1 +* +* Apply interchanges to column 1:J-1 * CALL CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF ( J+JB.LE.N ) THEN -* -* Apply interchanges to column J+JB:N * - CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, +* Apply interchanges to column J+JB:N +* + CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) -* - CALL CGEMM( 'No transpose', 'No transpose', - $ JB, N-J-JB+1, J-1, -ONE, +* + CALL CGEMM( 'No transpose', 'No transpose', + $ JB, N-J-JB+1, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE, $ A( J, J+JB ), LDA ) * * Compute block row of U. * CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/CR/dgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/CR/dgetrf.f index d6381567b1..ce0ab2243f 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/CR/dgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/CR/dgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -171,11 +171,11 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) * * Update current block. * - CALL DGEMM( 'No transpose', 'No transpose', - $ M-J+1, JB, J-1, -ONE, + CALL DGEMM( 'No transpose', 'No transpose', + $ M-J+1, JB, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J ), LDA, ONE, $ A( J, J ), LDA ) - + * * Factor diagonal and subdiagonal blocks and test for exact * singularity. @@ -189,27 +189,27 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE -* -* Apply interchanges to column 1:J-1 +* +* Apply interchanges to column 1:J-1 * CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF ( J+JB.LE.N ) THEN -* -* Apply interchanges to column J+JB:N * - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, +* Apply interchanges to column J+JB:N +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) -* - CALL DGEMM( 'No transpose', 'No transpose', - $ JB, N-J-JB+1, J-1, -ONE, +* + CALL DGEMM( 'No transpose', 'No transpose', + $ JB, N-J-JB+1, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE, $ A( J, J+JB ), LDA ) * * Compute block row of U. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/CR/sgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/CR/sgetrf.f index d5aeae468f..bb65431397 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/CR/sgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/CR/sgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -171,11 +171,11 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) * * Update current block. * - CALL SGEMM( 'No transpose', 'No transpose', - $ M-J+1, JB, J-1, -ONE, + CALL SGEMM( 'No transpose', 'No transpose', + $ M-J+1, JB, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J ), LDA, ONE, $ A( J, J ), LDA ) - + * * Factor diagonal and subdiagonal blocks and test for exact * singularity. @@ -189,27 +189,27 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE -* -* Apply interchanges to column 1:J-1 +* +* Apply interchanges to column 1:J-1 * CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF ( J+JB.LE.N ) THEN -* -* Apply interchanges to column J+JB:N * - CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, +* Apply interchanges to column J+JB:N +* + CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) -* - CALL SGEMM( 'No transpose', 'No transpose', - $ JB, N-J-JB+1, J-1, -ONE, +* + CALL SGEMM( 'No transpose', 'No transpose', + $ JB, N-J-JB+1, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE, $ A( J, J+JB ), LDA ) * * Compute block row of U. * CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/CR/zgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/CR/zgetrf.f index 3178aacfca..39090e6f30 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/CR/zgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/CR/zgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -171,11 +171,11 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) * * Update current block. * - CALL ZGEMM( 'No transpose', 'No transpose', - $ M-J+1, JB, J-1, -ONE, + CALL ZGEMM( 'No transpose', 'No transpose', + $ M-J+1, JB, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J ), LDA, ONE, $ A( J, J ), LDA ) - + * * Factor diagonal and subdiagonal blocks and test for exact * singularity. @@ -189,27 +189,27 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE -* -* Apply interchanges to column 1:J-1 +* +* Apply interchanges to column 1:J-1 * CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF ( J+JB.LE.N ) THEN -* -* Apply interchanges to column J+JB:N * - CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, +* Apply interchanges to column J+JB:N +* + CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) -* - CALL ZGEMM( 'No transpose', 'No transpose', - $ JB, N-J-JB+1, J-1, -ONE, +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ JB, N-J-JB+1, J-1, -ONE, $ A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE, $ A( J, J+JB ), LDA ) * * Compute block row of U. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/LL/cgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/LL/cgetrf.f index 9787f43bb1..77c747246d 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/LL/cgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/LL/cgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -174,21 +174,21 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) * Update before factoring the current panel * DO 30 K = 1, J-NB, NB -* +* * Apply interchanges to rows K:K+NB-1. -* +* CALL CLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 ) * * Compute block row of U. * CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ NB, JB, ONE, A( K, K ), LDA, + $ NB, JB, ONE, A( K, K ), LDA, $ A( K, J ), LDA ) * * Update trailing submatrix. * - CALL CGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, JB, NB, -ONE, + CALL CGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, JB, NB, -ONE, $ A( K+NB, K ), LDA, A( K, J ), LDA, ONE, $ A( K+NB, J ), LDA ) 30 CONTINUE @@ -212,9 +212,9 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) * Apply interchanges to the left-overs * DO 40 K = 1, MIN( M, N ), NB - CALL CLASWP( K-1, A( 1, 1 ), LDA, K, + CALL CLASWP( K-1, A( 1, 1 ), LDA, K, $ MIN (K+NB-1, MIN ( M, N )), IPIV, 1 ) - 40 CONTINUE + 40 CONTINUE * * Apply update to the M+1:N columns when N > M * @@ -227,17 +227,17 @@ SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO) JB = MIN( M-K+1, NB ) * CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-M, ONE, A( K, K ), LDA, + $ JB, N-M, ONE, A( K, K ), LDA, $ A( K, M+1 ), LDA ) -* +* IF ( K+NB.LE.M ) THEN - CALL CGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, N-M, NB, -ONE, + CALL CGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, N-M, NB, -ONE, $ A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE, $ A( K+NB, M+1 ), LDA ) END IF - 50 CONTINUE + 50 CONTINUE END IF * END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/LL/dgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/LL/dgetrf.f index 3df00dcbc7..9f25abd924 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/LL/dgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/LL/dgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -173,21 +173,21 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) * Update before factoring the current panel * DO 30 K = 1, J-NB, NB -* +* * Apply interchanges to rows K:K+NB-1. -* +* CALL DLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 ) * * Compute block row of U. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ NB, JB, ONE, A( K, K ), LDA, + $ NB, JB, ONE, A( K, K ), LDA, $ A( K, J ), LDA ) * * Update trailing submatrix. * - CALL DGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, JB, NB, -ONE, + CALL DGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, JB, NB, -ONE, $ A( K+NB, K ), LDA, A( K, J ), LDA, ONE, $ A( K+NB, J ), LDA ) 30 CONTINUE @@ -211,9 +211,9 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) * Apply interchanges to the left-overs * DO 40 K = 1, MIN( M, N ), NB - CALL DLASWP( K-1, A( 1, 1 ), LDA, K, + CALL DLASWP( K-1, A( 1, 1 ), LDA, K, $ MIN (K+NB-1, MIN ( M, N )), IPIV, 1 ) - 40 CONTINUE + 40 CONTINUE * * Apply update to the M+1:N columns when N > M * @@ -226,17 +226,17 @@ SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO) JB = MIN( M-K+1, NB ) * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-M, ONE, A( K, K ), LDA, + $ JB, N-M, ONE, A( K, K ), LDA, $ A( K, M+1 ), LDA ) -* +* IF ( K+NB.LE.M ) THEN - CALL DGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, N-M, NB, -ONE, + CALL DGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, N-M, NB, -ONE, $ A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE, $ A( K+NB, M+1 ), LDA ) END IF - 50 CONTINUE + 50 CONTINUE END IF * END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/LL/sgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/LL/sgetrf.f index c36d8e78e9..765caccb00 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/LL/sgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/LL/sgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -174,21 +174,21 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) * Update before factoring the current panel * DO 30 K = 1, J-NB, NB -* +* * Apply interchanges to rows K:K+NB-1. -* +* CALL SLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 ) * * Compute block row of U. * CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ NB, JB, ONE, A( K, K ), LDA, + $ NB, JB, ONE, A( K, K ), LDA, $ A( K, J ), LDA ) * * Update trailing submatrix. * - CALL SGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, JB, NB, -ONE, + CALL SGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, JB, NB, -ONE, $ A( K+NB, K ), LDA, A( K, J ), LDA, ONE, $ A( K+NB, J ), LDA ) 30 CONTINUE @@ -212,9 +212,9 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) * Apply interchanges to the left-overs * DO 40 K = 1, MIN( M, N ), NB - CALL SLASWP( K-1, A( 1, 1 ), LDA, K, + CALL SLASWP( K-1, A( 1, 1 ), LDA, K, $ MIN (K+NB-1, MIN ( M, N )), IPIV, 1 ) - 40 CONTINUE + 40 CONTINUE * * Apply update to the M+1:N columns when N > M * @@ -227,17 +227,17 @@ SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO) JB = MIN( M-K+1, NB ) * CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-M, ONE, A( K, K ), LDA, + $ JB, N-M, ONE, A( K, K ), LDA, $ A( K, M+1 ), LDA ) -* +* IF ( K+NB.LE.M ) THEN - CALL SGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, N-M, NB, -ONE, + CALL SGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, N-M, NB, -ONE, $ A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE, $ A( K+NB, M+1 ), LDA ) END IF - 50 CONTINUE + 50 CONTINUE END IF * END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/LL/zgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/LL/zgetrf.f index 3b2199bf17..ef3fbf418a 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/LL/zgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/LL/zgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -88,12 +88,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -103,7 +103,7 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -174,21 +174,21 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) * Update before factoring the current panel * DO 30 K = 1, J-NB, NB -* +* * Apply interchanges to rows K:K+NB-1. -* +* CALL ZLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 ) * * Compute block row of U. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ NB, JB, ONE, A( K, K ), LDA, + $ NB, JB, ONE, A( K, K ), LDA, $ A( K, J ), LDA ) * * Update trailing submatrix. * - CALL ZGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, JB, NB, -ONE, + CALL ZGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, JB, NB, -ONE, $ A( K+NB, K ), LDA, A( K, J ), LDA, ONE, $ A( K+NB, J ), LDA ) 30 CONTINUE @@ -212,9 +212,9 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) * Apply interchanges to the left-overs * DO 40 K = 1, MIN( M, N ), NB - CALL ZLASWP( K-1, A( 1, 1 ), LDA, K, + CALL ZLASWP( K-1, A( 1, 1 ), LDA, K, $ MIN (K+NB-1, MIN ( M, N )), IPIV, 1 ) - 40 CONTINUE + 40 CONTINUE * * Apply update to the M+1:N columns when N > M * @@ -227,17 +227,17 @@ SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO) JB = MIN( M-K+1, NB ) * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, N-M, ONE, A( K, K ), LDA, + $ JB, N-M, ONE, A( K, K ), LDA, $ A( K, M+1 ), LDA ) -* +* IF ( K+NB.LE.M ) THEN - CALL ZGEMM( 'No transpose', 'No transpose', - $ M-K-NB+1, N-M, NB, -ONE, + CALL ZGEMM( 'No transpose', 'No transpose', + $ M-K-NB+1, N-M, NB, -ONE, $ A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE, $ A( K+NB, M+1 ), LDA ) END IF - 50 CONTINUE + 50 CONTINUE END IF * END IF diff --git a/lapack-netlib/SRC/VARIANTS/lu/REC/cgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/REC/cgetrf.f index a46bad118c..9daab38729 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/REC/cgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/REC/cgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -122,12 +122,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -137,7 +137,7 @@ SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO ) * -- LAPACK computational routine (version 3.X) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/VARIANTS/lu/REC/dgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/REC/dgetrf.f index 318c166dcd..db6cece24c 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/REC/dgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/REC/dgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -122,12 +122,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -137,7 +137,7 @@ SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -- LAPACK computational routine (version 3.X) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/VARIANTS/lu/REC/sgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/REC/sgetrf.f index 9df7d5b93d..379ad1c9af 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/REC/sgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/REC/sgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -122,12 +122,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -137,7 +137,7 @@ SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) * -- LAPACK computational routine (version 3.X) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/VARIANTS/lu/REC/zgetrf.f b/lapack-netlib/SRC/VARIANTS/lu/REC/zgetrf.f index fe698e1c77..dc42c83f45 100644 --- a/lapack-netlib/SRC/VARIANTS/lu/REC/zgetrf.f +++ b/lapack-netlib/SRC/VARIANTS/lu/REC/zgetrf.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * Purpose * ======= * @@ -122,12 +122,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -137,7 +137,7 @@ SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * -- LAPACK computational routine (version 3.X) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/VARIANTS/qr/LL/cgeqrf.f b/lapack-netlib/SRC/VARIANTS/qr/LL/cgeqrf.f index 8a79ebea00..3cbec13c7f 100644 --- a/lapack-netlib/SRC/VARIANTS/qr/LL/cgeqrf.f +++ b/lapack-netlib/SRC/VARIANTS/qr/LL/cgeqrf.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * Purpose * ======= * @@ -84,12 +84,12 @@ C> The dimension of the array WORK. The dimension can be divided into three parts. C> \endverbatim C> \verbatim -C> 1) The part for the triangular factor T. If the very last T is not bigger -C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, -C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T +C> 1) The part for the triangular factor T. If the very last T is not bigger +C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, +C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T C> \endverbatim C> \verbatim -C> 2) The part for the very last T when T is bigger than any of the rest T. +C> 2) The part for the very last T when T is bigger than any of the rest T. C> The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, C> where K = min(M,N), NX is calculated by C> NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) ) @@ -118,12 +118,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -152,7 +152,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -198,7 +198,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: * * NB=3 2NB=6 K=10 -* | | | +* | | | * 1--2--3--4--5--6--7--8--9--10 * | \________/ * K-NX=5 NT=4 @@ -215,7 +215,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) IF ( NT.GT.NB ) THEN - LBWORK = K-NT + LBWORK = K-NT * * Optimal workspace for dlarfb = MAX(1,N)*NT * @@ -225,7 +225,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) ELSE LBWORK = SCEIL(REAL(K)/REAL(NB))*NB - LWKOPT = (LBWORK+LLWORK-NB)*NB + LWKOPT = (LBWORK+LLWORK-NB)*NB WORK( 1 ) = LWKOPT END IF @@ -301,16 +301,16 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL CLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, IB, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ IB) -20 CONTINUE +20 CONTINUE * * Compute the QR factorization of the current block * A(I:M,I:I+IB-1) * - CALL CGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), + CALL CGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1), IINFO ) IF( I+IB.LE.N ) THEN @@ -319,7 +319,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * H = H(i) H(i+1) . . . H(i+ib-1) * CALL CLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(I), LBWORK ) * END IF @@ -331,7 +331,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Use unblocked code to factor the last or only block. * IF( I.LE.K ) THEN - + IF ( I .NE. 1 ) THEN DO 30 J = 1, I - NB, NB @@ -340,19 +340,19 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL CLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, K-I+1, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ K-I+1) -30 CONTINUE +30 CONTINUE - CALL CGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), + CALL CGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1),IINFO ) ELSE * * Use unblocked code to factor the last or only block. * - CALL CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), + CALL CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), $ WORK,IINFO ) END IF @@ -372,7 +372,7 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) $ A( I, I ), LDA, TAU( I ), WORK(I), LBWORK ) ELSE CALL CLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+1), NT ) END IF @@ -385,27 +385,27 @@ SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) CALL CLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, IB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) -40 CONTINUE - +40 CONTINUE + IF ( NT.LE.NB ) THEN CALL CLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) - ELSE + ELSE CALL CLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, - $ WORK(LBWORK*NB+1), + $ A( J, J ), LDA, + $ WORK(LBWORK*NB+1), $ NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) END IF - + END IF WORK( 1 ) = IWS diff --git a/lapack-netlib/SRC/VARIANTS/qr/LL/dgeqrf.f b/lapack-netlib/SRC/VARIANTS/qr/LL/dgeqrf.f index b6fa5aceda..8f1979da33 100644 --- a/lapack-netlib/SRC/VARIANTS/qr/LL/dgeqrf.f +++ b/lapack-netlib/SRC/VARIANTS/qr/LL/dgeqrf.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * Purpose * ======= * @@ -84,12 +84,12 @@ C> The dimension of the array WORK. The dimension can be divided into three parts. C> \endverbatim C> \verbatim -C> 1) The part for the triangular factor T. If the very last T is not bigger -C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, -C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T +C> 1) The part for the triangular factor T. If the very last T is not bigger +C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, +C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T C> \endverbatim C> \verbatim -C> 2) The part for the very last T when T is bigger than any of the rest T. +C> 2) The part for the very last T when T is bigger than any of the rest T. C> The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, C> where K = min(M,N), NX is calculated by C> NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) @@ -118,12 +118,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -152,7 +152,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -198,7 +198,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: * * NB=3 2NB=6 K=10 -* | | | +* | | | * 1--2--3--4--5--6--7--8--9--10 * | \________/ * K-NX=5 NT=4 @@ -215,7 +215,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) IF ( NT.GT.NB ) THEN - LBWORK = K-NT + LBWORK = K-NT * * Optimal workspace for dlarfb = MAX(1,N)*NT * @@ -225,7 +225,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) ELSE LBWORK = SCEIL(REAL(K)/REAL(NB))*NB - LWKOPT = (LBWORK+LLWORK-NB)*NB + LWKOPT = (LBWORK+LLWORK-NB)*NB WORK( 1 ) = LWKOPT END IF @@ -301,16 +301,16 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, IB, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ IB) -20 CONTINUE +20 CONTINUE * * Compute the QR factorization of the current block * A(I:M,I:I+IB-1) * - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), + CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1), IINFO ) IF( I+IB.LE.N ) THEN @@ -319,7 +319,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(I), LBWORK ) * END IF @@ -331,7 +331,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Use unblocked code to factor the last or only block. * IF( I.LE.K ) THEN - + IF ( I .NE. 1 ) THEN DO 30 J = 1, I - NB, NB @@ -340,19 +340,19 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, K-I+1, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ K-I+1) -30 CONTINUE +30 CONTINUE - CALL DGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), + CALL DGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1),IINFO ) ELSE * * Use unblocked code to factor the last or only block. * - CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), + CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), $ WORK,IINFO ) END IF @@ -372,7 +372,7 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) $ A( I, I ), LDA, TAU( I ), WORK(I), LBWORK ) ELSE CALL DLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+1), NT ) END IF @@ -385,27 +385,27 @@ SUBROUTINE DGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, IB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) -40 CONTINUE - +40 CONTINUE + IF ( NT.LE.NB ) THEN CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) - ELSE + ELSE CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, - $ WORK(LBWORK*NB+1), + $ A( J, J ), LDA, + $ WORK(LBWORK*NB+1), $ NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) END IF - + END IF WORK( 1 ) = IWS diff --git a/lapack-netlib/SRC/VARIANTS/qr/LL/sceil.f b/lapack-netlib/SRC/VARIANTS/qr/LL/sceil.f index 397b7df219..86394cc989 100644 --- a/lapack-netlib/SRC/VARIANTS/qr/LL/sceil.f +++ b/lapack-netlib/SRC/VARIANTS/qr/LL/sceil.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SCEIL( A ) -* +* * .. Scalar Arguments .. * REAL A * .. -* +* * ===================================================================== -* +* * .. Intrinsic Functions .. * INTRINSIC INT * .. * .. Executable Statements ..* -* +* * IF (A-INT(A).EQ.0) THEN * SCEIL = A * ELSE IF (A.GT.0) THEN @@ -28,9 +28,9 @@ * ELSE * SCEIL = INT(A) * END IF -* +* * RETURN -* +* * END * Purpose * ======= @@ -46,12 +46,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsOTHERcomputational * @@ -61,7 +61,7 @@ REAL FUNCTION SCEIL( A ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments ..* REAL A @@ -73,7 +73,7 @@ REAL FUNCTION SCEIL( A ) INTRINSIC INT * .. * .. Executable Statements ..* -* +* IF (A-INT(A).EQ.0) THEN SCEIL = A ELSE IF (A.GT.0) THEN diff --git a/lapack-netlib/SRC/VARIANTS/qr/LL/sgeqrf.f b/lapack-netlib/SRC/VARIANTS/qr/LL/sgeqrf.f index 1d22897e77..7b0227193d 100644 --- a/lapack-netlib/SRC/VARIANTS/qr/LL/sgeqrf.f +++ b/lapack-netlib/SRC/VARIANTS/qr/LL/sgeqrf.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * Purpose * ======= * @@ -84,12 +84,12 @@ C> The dimension of the array WORK. The dimension can be divided into three parts. C> \endverbatim C> \verbatim -C> 1) The part for the triangular factor T. If the very last T is not bigger -C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, -C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T +C> 1) The part for the triangular factor T. If the very last T is not bigger +C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, +C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T C> \endverbatim C> \verbatim -C> 2) The part for the very last T when T is bigger than any of the rest T. +C> 2) The part for the very last T when T is bigger than any of the rest T. C> The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, C> where K = min(M,N), NX is calculated by C> NX = MAX( 0, ILAENV( 3, 'SGEQRF', ' ', M, N, -1, -1 ) ) @@ -118,12 +118,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -152,7 +152,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -198,7 +198,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: * * NB=3 2NB=6 K=10 -* | | | +* | | | * 1--2--3--4--5--6--7--8--9--10 * | \________/ * K-NX=5 NT=4 @@ -215,7 +215,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) IF ( NT.GT.NB ) THEN - LBWORK = K-NT + LBWORK = K-NT * * Optimal workspace for dlarfb = MAX(1,N)*NT * @@ -225,7 +225,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) ELSE LBWORK = SCEIL(REAL(K)/REAL(NB))*NB - LWKOPT = (LBWORK+LLWORK-NB)*NB + LWKOPT = (LBWORK+LLWORK-NB)*NB WORK( 1 ) = LWKOPT END IF @@ -301,16 +301,16 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, IB, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ IB) -20 CONTINUE +20 CONTINUE * * Compute the QR factorization of the current block * A(I:M,I:I+IB-1) * - CALL SGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), + CALL SGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1), IINFO ) IF( I+IB.LE.N ) THEN @@ -319,7 +319,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * H = H(i) H(i+1) . . . H(i+ib-1) * CALL SLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(I), LBWORK ) * END IF @@ -331,7 +331,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Use unblocked code to factor the last or only block. * IF( I.LE.K ) THEN - + IF ( I .NE. 1 ) THEN DO 30 J = 1, I - NB, NB @@ -340,19 +340,19 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, K-I+1, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ K-I+1) -30 CONTINUE +30 CONTINUE - CALL SGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), + CALL SGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1),IINFO ) ELSE * * Use unblocked code to factor the last or only block. * - CALL SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), + CALL SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), $ WORK,IINFO ) END IF @@ -372,7 +372,7 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) $ A( I, I ), LDA, TAU( I ), WORK(I), LBWORK ) ELSE CALL SLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+1), NT ) END IF @@ -385,27 +385,27 @@ SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, IB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) -40 CONTINUE - +40 CONTINUE + IF ( NT.LE.NB ) THEN CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) - ELSE + ELSE CALL SLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, - $ WORK(LBWORK*NB+1), + $ A( J, J ), LDA, + $ WORK(LBWORK*NB+1), $ NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) END IF - + END IF WORK( 1 ) = IWS diff --git a/lapack-netlib/SRC/VARIANTS/qr/LL/zgeqrf.f b/lapack-netlib/SRC/VARIANTS/qr/LL/zgeqrf.f index 576d9fa23d..4ddad00d61 100644 --- a/lapack-netlib/SRC/VARIANTS/qr/LL/zgeqrf.f +++ b/lapack-netlib/SRC/VARIANTS/qr/LL/zgeqrf.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * Purpose * ======= * @@ -84,12 +84,12 @@ C> The dimension of the array WORK. The dimension can be divided into three parts. C> \endverbatim C> \verbatim -C> 1) The part for the triangular factor T. If the very last T is not bigger -C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, -C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T +C> 1) The part for the triangular factor T. If the very last T is not bigger +C> than any of the rest, then this part is NB x ceiling(K/NB), otherwise, +C> NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T C> \endverbatim C> \verbatim -C> 2) The part for the very last T when T is bigger than any of the rest T. +C> 2) The part for the very last T when T is bigger than any of the rest T. C> The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, C> where K = min(M,N), NX is calculated by C> NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) @@ -118,12 +118,12 @@ * Authors: * ======== * -C> \author Univ. of Tennessee -C> \author Univ. of California Berkeley -C> \author Univ. of Colorado Denver -C> \author NAG Ltd. +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. * -C> \date November 2011 +C> \date December 2016 * C> \ingroup variantsGEcomputational * @@ -152,7 +152,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -- LAPACK computational routine (version 3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -198,7 +198,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: * * NB=3 2NB=6 K=10 -* | | | +* | | | * 1--2--3--4--5--6--7--8--9--10 * | \________/ * K-NX=5 NT=4 @@ -215,7 +215,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) IF ( NT.GT.NB ) THEN - LBWORK = K-NT + LBWORK = K-NT * * Optimal workspace for dlarfb = MAX(1,N)*NT * @@ -225,7 +225,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) ELSE LBWORK = SCEIL(REAL(K)/REAL(NB))*NB - LWKOPT = (LBWORK+LLWORK-NB)*NB + LWKOPT = (LBWORK+LLWORK-NB)*NB WORK( 1 ) = LWKOPT END IF @@ -301,16 +301,16 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL ZLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, IB, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ IB) -20 CONTINUE +20 CONTINUE * * Compute the QR factorization of the current block * A(I:M,I:I+IB-1) * - CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), + CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1), IINFO ) IF( I+IB.LE.N ) THEN @@ -319,7 +319,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(I), LBWORK ) * END IF @@ -331,7 +331,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * Use unblocked code to factor the last or only block. * IF( I.LE.K ) THEN - + IF ( I .NE. 1 ) THEN DO 30 J = 1, I - NB, NB @@ -340,19 +340,19 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * CALL ZLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, K-I+1, NB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1), $ K-I+1) -30 CONTINUE +30 CONTINUE - CALL ZGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), + CALL ZGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+NT*NT+1),IINFO ) ELSE * * Use unblocked code to factor the last or only block. * - CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), + CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), $ WORK,IINFO ) END IF @@ -372,7 +372,7 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) $ A( I, I ), LDA, TAU( I ), WORK(I), LBWORK ) ELSE CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1, - $ A( I, I ), LDA, TAU( I ), + $ A( I, I ), LDA, TAU( I ), $ WORK(LBWORK*NB+1), NT ) END IF @@ -385,27 +385,27 @@ SUBROUTINE ZGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO ) CALL ZLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, IB, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) -40 CONTINUE - +40 CONTINUE + IF ( NT.LE.NB ) THEN CALL ZLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, WORK(J), LBWORK, + $ A( J, J ), LDA, WORK(J), LBWORK, $ A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) - ELSE + ELSE CALL ZLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-J+1, N-M, K-J+1, - $ A( J, J ), LDA, - $ WORK(LBWORK*NB+1), + $ A( J, J ), LDA, + $ WORK(LBWORK*NB+1), $ NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1), $ N-M) END IF - + END IF WORK( 1 ) = IWS diff --git a/lapack-netlib/SRC/cbbcsd.f b/lapack-netlib/SRC/cbbcsd.f index 2d619cde11..d417567065 100644 --- a/lapack-netlib/SRC/cbbcsd.f +++ b/lapack-netlib/SRC/cbbcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CBBCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CBBCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, * V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, * B22D, B22E, RWORK, LRWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LRWORK, M, P, Q @@ -34,7 +34,7 @@ * COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,7 +149,7 @@ *> \param[in,out] U1 *> \verbatim *> U1 is COMPLEX array, dimension (LDU1,P) -*> On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied +*> On entry, a P-by-P matrix. On exit, U1 is postmultiplied *> by the left singular vector matrix common to [ B11 ; 0 ] and *> [ B12 0 0 ; 0 -I 0 0 ]. *> \endverbatim @@ -157,13 +157,13 @@ *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER -*> The leading dimension of the array U1. +*> The leading dimension of the array U1, LDU1 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] U2 *> \verbatim *> U2 is COMPLEX array, dimension (LDU2,M-P) -*> On entry, an LDU2-by-(M-P) matrix. On exit, U2 is +*> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is *> postmultiplied by the left singular vector matrix common to *> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. *> \endverbatim @@ -171,13 +171,13 @@ *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER -*> The leading dimension of the array U2. +*> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] V1T *> \verbatim *> V1T is COMPLEX array, dimension (LDV1T,Q) -*> On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied +*> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied *> by the conjugate transpose of the right singular vector *> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. *> \endverbatim @@ -185,13 +185,13 @@ *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER -*> The leading dimension of the array V1T. +*> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). *> \endverbatim *> *> \param[in,out] V2T *> \verbatim *> V2T is COMPLEX array, dimenison (LDV2T,M-Q) -*> On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is +*> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is *> premultiplied by the conjugate transpose of the right *> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and *> [ B22 0 0 ; 0 0 I ]. @@ -200,7 +200,7 @@ *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER -*> The leading dimension of the array V2T. +*> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). *> \endverbatim *> *> \param[out] B11D @@ -273,8 +273,8 @@ *> *> \param[out] RWORK *> \verbatim -*> RWORK is REAL array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> RWORK is REAL array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. *> \endverbatim *> *> \param[in] LRWORK @@ -317,12 +317,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -332,10 +332,10 @@ SUBROUTINE CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS diff --git a/lapack-netlib/SRC/cbdsqr.f b/lapack-netlib/SRC/cbdsqr.f index 56bcadcee4..0bda3a3334 100644 --- a/lapack-netlib/SRC/cbdsqr.f +++ b/lapack-netlib/SRC/cbdsqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU @@ -29,7 +29,7 @@ * REAL D( * ), E( * ), RWORK( * ) * COMPLEX C( LDC, * ), U( LDU, * ), VT( LDVT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,9 +40,9 @@ *> left singular vectors from the singular value decomposition (SVD) of *> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit *> zero-shift QR algorithm. The SVD of B has the form -*> +*> *> B = Q * S * P**H -*> +*> *> where S is the diagonal matrix of singular values, Q is an orthogonal *> matrix of left singular vectors, and P is an orthogonal matrix of *> right singular vectors. If left singular vectors are requested, this @@ -51,9 +51,9 @@ *> P**H, for given complex input matrices U and VT. When U and VT are *> the unitary matrices that reduce a general matrix A to bidiagonal *> form: A = U*B*VT, as computed by CGEBRD, then -*> +*> *> A = (U*Q) * S * (P**H*VT) -*> +*> *> is the SVD of A. Optionally, the subroutine may also compute Q**H*C *> for a given complex input matrix C. *> @@ -209,12 +209,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -222,10 +222,10 @@ SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -321,7 +321,7 @@ SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, CALL SLASQ1( N, D, E, RWORK, INFO ) * * If INFO equals 2, dqds didn't finish, try to finish -* +* IF( INFO .NE. 2 ) RETURN INFO = 0 END IF diff --git a/lapack-netlib/SRC/cgbbrd.f b/lapack-netlib/SRC/cgbbrd.f index 08af198aa1..e4e820aa48 100644 --- a/lapack-netlib/SRC/cgbbrd.f +++ b/lapack-netlib/SRC/cgbbrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, * LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC @@ -30,7 +30,7 @@ * COMPLEX AB( LDAB, * ), C( LDC, * ), PT( LDPT, * ), * $ Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -180,12 +180,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -193,10 +193,10 @@ SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER VECT diff --git a/lapack-netlib/SRC/cgbcon.f b/lapack-netlib/SRC/cgbcon.f index 1cf57e824b..1d32a68999 100644 --- a/lapack-netlib/SRC/cgbcon.f +++ b/lapack-netlib/SRC/cgbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, KL, KU, LDAB, N @@ -31,7 +31,7 @@ * REAL RWORK( * ) * COMPLEX AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -147,10 +147,10 @@ SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/cgbequ.f b/lapack-netlib/SRC/cgbequ.f index c171b567e2..100f920e1e 100644 --- a/lapack-netlib/SRC/cgbequ.f +++ b/lapack-netlib/SRC/cgbequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * REAL AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * REAL C( * ), R( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -154,10 +154,10 @@ SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/cgbequb.f b/lapack-netlib/SRC/cgbequb.f index 0e2875fe8a..fd69a575b3 100644 --- a/lapack-netlib/SRC/cgbequb.f +++ b/lapack-netlib/SRC/cgbequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * REAL AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * REAL C( * ), R( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,9 +49,9 @@ *> number of A but works well in practice. *> *> This routine differs from CGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -84,7 +84,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> AB is COMPLEX array, dimension (LDAB,N) *> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. *> The j-th column of A is stored in the j-th column of the *> array AB as follows: @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexGBcomputational * @@ -161,10 +161,10 @@ SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/cgbrfs.f b/lapack-netlib/SRC/cgbrfs.f index 0b447330af..464128b848 100644 --- a/lapack-netlib/SRC/cgbrfs.f +++ b/lapack-netlib/SRC/cgbrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -206,10 +206,10 @@ SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgbrfsx.f b/lapack-netlib/SRC/cgbrfsx.f index fc73496910..041b6a1b64 100644 --- a/lapack-netlib/SRC/cgbrfsx.f +++ b/lapack-netlib/SRC/cgbrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -424,10 +424,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -440,7 +440,7 @@ SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -498,11 +498,10 @@ SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C REAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. @@ -642,7 +641,7 @@ SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, * * Perform refinement on each right-hand side * - IF ( REF_TYPE .NE. 0 ) THEN + IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN PREC_TYPE = ILAPREC( 'D' ) diff --git a/lapack-netlib/SRC/cgbsv.f b/lapack-netlib/SRC/cgbsv.f index 3adaeb1a03..7368783ada 100644 --- a/lapack-netlib/SRC/cgbsv.f +++ b/lapack-netlib/SRC/cgbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS diff --git a/lapack-netlib/SRC/cgbsvx.f b/lapack-netlib/SRC/cgbsvx.f index e124148369..1c102cb6da 100644 --- a/lapack-netlib/SRC/cgbsvx.f +++ b/lapack-netlib/SRC/cgbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -356,10 +356,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -370,7 +370,7 @@ SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -390,7 +390,7 @@ SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * * ===================================================================== * Moved setting of INFO = N+1 so INFO does not subsequently get -* overwritten. Sven, 17 Mar 05. +* overwritten. Sven, 17 Mar 05. * ===================================================================== * * .. Parameters .. diff --git a/lapack-netlib/SRC/cgbsvxx.f b/lapack-netlib/SRC/cgbsvxx.f index 654b1810bc..2e113f99cd 100644 --- a/lapack-netlib/SRC/cgbsvxx.f +++ b/lapack-netlib/SRC/cgbsvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RCOND, RPVGRW, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -547,10 +547,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -563,7 +563,7 @@ SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cgbtf2.f b/lapack-netlib/SRC/cgbtf2.f index e4ea08496e..cd34d284dc 100644 --- a/lapack-netlib/SRC/cgbtf2.f +++ b/lapack-netlib/SRC/cgbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/cgbtrf.f b/lapack-netlib/SRC/cgbtrf.f index bd5d95f3a7..601d063f24 100644 --- a/lapack-netlib/SRC/cgbtrf.f +++ b/lapack-netlib/SRC/cgbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/cgbtrs.f b/lapack-netlib/SRC/cgbtrs.f index 878718b834..75d195316e 100644 --- a/lapack-netlib/SRC/cgbtrs.f +++ b/lapack-netlib/SRC/cgbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -138,10 +138,10 @@ SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgebak.f b/lapack-netlib/SRC/cgebak.f index 442134273f..63c73bfa71 100644 --- a/lapack-netlib/SRC/cgebak.f +++ b/lapack-netlib/SRC/cgebak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -29,7 +29,7 @@ * REAL SCALE( * ) * COMPLEX V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -131,10 +131,10 @@ SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/cgebal.f b/lapack-netlib/SRC/cgebal.f index bb2a3c90d7..9f3c25c053 100644 --- a/lapack-netlib/SRC/cgebal.f +++ b/lapack-netlib/SRC/cgebal.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N @@ -28,7 +28,7 @@ * REAL SCALE( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -161,10 +161,10 @@ * ===================================================================== SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB @@ -190,7 +190,6 @@ SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) INTEGER I, ICA, IEXC, IRA, J, K, L, M REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 - COMPLEX CDUM * .. * .. External Functions .. LOGICAL SISNAN, LSAME diff --git a/lapack-netlib/SRC/cgebd2.f b/lapack-netlib/SRC/cgebd2.f index 42d06e0d13..e874120235 100644 --- a/lapack-netlib/SRC/cgebd2.f +++ b/lapack-netlib/SRC/cgebd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,19 +120,19 @@ *> \param[out] INFO *> \verbatim *> INFO is INTEGER -*> = 0: successful exit +*> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @precisions normal c -> s d z @@ -190,10 +190,10 @@ * ===================================================================== SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgebrd.f b/lapack-netlib/SRC/cgebrd.f index e63c6ea136..d01e228a5b 100644 --- a/lapack-netlib/SRC/cgebrd.f +++ b/lapack-netlib/SRC/cgebrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -206,10 +206,10 @@ SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgecon.f b/lapack-netlib/SRC/cgecon.f index e5806d10c5..fb57da2e13 100644 --- a/lapack-netlib/SRC/cgecon.f +++ b/lapack-netlib/SRC/cgecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -124,10 +124,10 @@ SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/cgeequ.f b/lapack-netlib/SRC/cgeequ.f index 5a15dcc2a8..75aa2d7db8 100644 --- a/lapack-netlib/SRC/cgeequ.f +++ b/lapack-netlib/SRC/cgeequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * REAL AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * REAL C( * ), R( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -140,10 +140,10 @@ SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgeequb.f b/lapack-netlib/SRC/cgeequb.f index 205b0c54f4..3f738b83d8 100644 --- a/lapack-netlib/SRC/cgeequb.f +++ b/lapack-netlib/SRC/cgeequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * REAL AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * REAL C( * ), R( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,9 +49,9 @@ *> number of A but works well in practice. *> *> This routine differs from CGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -147,10 +147,10 @@ SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgees.f b/lapack-netlib/SRC/cgees.f index cbc3bc7611..4da2cdf3b0 100644 --- a/lapack-netlib/SRC/cgees.f +++ b/lapack-netlib/SRC/cgees.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, * LDVS, WORK, LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -34,7 +34,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEeigen * @@ -197,10 +197,10 @@ SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT diff --git a/lapack-netlib/SRC/cgeesx.f b/lapack-netlib/SRC/cgeesx.f index 81157717a0..dd833ae7e9 100644 --- a/lapack-netlib/SRC/cgeesx.f +++ b/lapack-netlib/SRC/cgeesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, * VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, * BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SENSE, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -36,7 +36,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -83,7 +83,7 @@ *> *> \param[in] SELECT *> \verbatim -*> SELECT is procedure) LOGICAL FUNCTION of one COMPLEX argument +*> SELECT is a LOGICAL FUNCTION of one COMPLEX argument *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to order *> to the top left of the Schur form. @@ -225,12 +225,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexGEeigen * @@ -239,10 +239,10 @@ SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT diff --git a/lapack-netlib/SRC/cgeev.f b/lapack-netlib/SRC/cgeev.f index 0f48322a8e..bdd75e4f1e 100644 --- a/lapack-netlib/SRC/cgeev.f +++ b/lapack-netlib/SRC/cgeev.f @@ -2,35 +2,35 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. -* REAL RWORK( * ) -* COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -164,64 +164,67 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date November 2011 +* @generated from zgeev.f, fortran z -> c, Tue Apr 19 01:47:44 2016 * *> \ingroup complexGEeigen * * ===================================================================== SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. - REAL RWORK( * ) - COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + REAL RWORK( * ) + COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE + REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, - $ IWRK, K, MAXWRK, MINWRK, NOUT - REAL ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM - COMPLEX TMP + $ IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT + REAL ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX TMP * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) - REAL DUM( 1 ) + REAL DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY, CLASCL, - $ CSCAL, CSSCAL, CTREVC, CUNGHR, SLABAD, XERBLA + EXTERNAL SLABAD, XERBLA, CSSCAL, CGEBAK, CGEBAL, CGEHRD, + $ CHSEQR, CLACPY, CLASCL, CSCAL, CTREVC3, CUNGHR * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV, ISAMAX - REAL CLANGE, SCNRM2, SLAMCH - EXTERNAL LSAME, ILAENV, ISAMAX, CLANGE, SCNRM2, SLAMCH + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SCNRM2, CLANGE + EXTERNAL LSAME, ISAMAX, ILAENV, SLAMCH, SCNRM2, CLANGE * .. * .. Intrinsic Functions .. - INTRINSIC AIMAG, CMPLX, CONJG, MAX, REAL, SQRT + INTRINSIC REAL, CMPLX, CONJG, AIMAG, MAX, SQRT * .. * .. Executable Statements .. * @@ -244,7 +247,6 @@ SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN INFO = -10 END IF - * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the @@ -267,18 +269,28 @@ SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, IF( WANTVL ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'CUNGHR', $ ' ', N, 1, N, -1 ) ) + CALL CTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'CUNGHR', $ ' ', N, 1, N, -1 ) ) + CALL CTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) ELSE CALL CHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) END IF WORK( 1 ) = MAXWRK @@ -413,12 +425,13 @@ SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (CWorkspace: need 2*N) +* (CWorkspace: need 2*N, prefer N + 2*N*NB) * (RWorkspace: need 2*N) * IRWORK = IBAL + N - CALL CTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) + CALL CTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, + $ RWORK( IRWORK ), N, IERR ) END IF * IF( WANTVL ) THEN diff --git a/lapack-netlib/SRC/cgeevx.f b/lapack-netlib/SRC/cgeevx.f index 539a7b95fa..2a7a5f2c87 100644 --- a/lapack-netlib/SRC/cgeevx.f +++ b/lapack-netlib/SRC/cgeevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,19 +21,19 @@ * SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, * LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, * RCONDV, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N -* REAL ABNRM +* REAL ABNRM * .. * .. Array Arguments .. -* REAL RCONDE( * ), RCONDV( * ), RWORK( * ), +* REAL RCONDE( * ), RCONDV( * ), RWORK( * ), * $ SCALE( * ) -* COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +* COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,7 +134,7 @@ *> A is COMPLEX array, dimension (LDA,N) *> On entry, the N-by-N matrix A. *> On exit, A has been overwritten. If JOBVL = 'V' or -*> JOBVR = 'V', A contains the Schur form of the balanced +*> JOBVR = 'V', A contains the Schur form of the balanced *> version of the matrix A. *> \endverbatim *> @@ -271,12 +271,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date November 2011 +* @generated from zgeevx.f, fortran z -> c, Tue Apr 19 01:47:44 2016 * *> \ingroup complexGEeigen * @@ -284,56 +286,57 @@ SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, $ RCONDV, WORK, LWORK, RWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N - REAL ABNRM + REAL ABNRM * .. * .. Array Arguments .. - REAL RCONDE( * ), RCONDV( * ), RWORK( * ), + REAL RCONDE( * ), RCONDV( * ), RWORK( * ), $ SCALE( * ) - COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + COMPLEX A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE + REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, $ WNTSNN, WNTSNV CHARACTER JOB, SIDE - INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK, - $ MINWRK, NOUT - REAL ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM - COMPLEX TMP + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT + REAL ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX TMP * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) - REAL DUM( 1 ) + REAL DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY, CLASCL, - $ CSCAL, CSSCAL, CTREVC, CTRSNA, CUNGHR, SLABAD, - $ SLASCL, XERBLA + EXTERNAL SLABAD, SLASCL, XERBLA, CSSCAL, CGEBAK, CGEBAL, + $ CGEHRD, CHSEQR, CLACPY, CLASCL, CSCAL, CTREVC3, + $ CTRSNA, CUNGHR * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV, ISAMAX - REAL CLANGE, SCNRM2, SLAMCH - EXTERNAL LSAME, ILAENV, ISAMAX, CLANGE, SCNRM2, SLAMCH + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SCNRM2, CLANGE + EXTERNAL LSAME, ISAMAX, ILAENV, SLAMCH, SCNRM2, CLANGE * .. * .. Intrinsic Functions .. - INTRINSIC AIMAG, CMPLX, CONJG, MAX, REAL, SQRT + INTRINSIC REAL, CMPLX, CONJG, AIMAG, MAX, SQRT * .. * .. Executable Statements .. * @@ -387,9 +390,19 @@ SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) * IF( WANTVL ) THEN + CALL CTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, LWORK_TREVC ) CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN + CALL CTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, LWORK_TREVC ) CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, $ WORK, -1, INFO ) ELSE @@ -401,7 +414,7 @@ SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ WORK, -1, INFO ) END IF END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) * IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = 2*N @@ -559,19 +572,20 @@ SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * -* If INFO > 0 from CHSEQR, then quit +* If INFO .NE. 0 from CHSEQR, then quit * - IF( INFO.GT.0 ) + IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (CWorkspace: need 2*N) +* (CWorkspace: need 2*N, prefer N + 2*N*NB) * (RWorkspace: need N) * - CALL CTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), RWORK, IERR ) + CALL CTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, + $ RWORK, N, IERR ) END IF * * Compute condition numbers if desired diff --git a/lapack-netlib/SRC/cgehd2.f b/lapack-netlib/SRC/cgehd2.f index 5db9eb3be9..d4d78b4f2b 100644 --- a/lapack-netlib/SRC/cgehd2.f +++ b/lapack-netlib/SRC/cgehd2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEHD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff --git a/lapack-netlib/SRC/cgehrd.f b/lapack-netlib/SRC/cgehrd.f index b2b3fd3961..ca0f2d54d9 100644 --- a/lapack-netlib/SRC/cgehrd.f +++ b/lapack-netlib/SRC/cgehrd.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -186,7 +186,7 @@ SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. @@ -316,7 +316,7 @@ SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL CGEMM( 'No transpose', 'Conjugate transpose', + CALL CGEMM( 'No transpose', 'Conjugate transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) diff --git a/lapack-netlib/SRC/cgejsv.f b/lapack-netlib/SRC/cgejsv.f index 4b3e905653..28804e763c 100644 --- a/lapack-netlib/SRC/cgejsv.f +++ b/lapack-netlib/SRC/cgejsv.f @@ -1,1867 +1,2235 @@ -*> \brief \b CGEJSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download CGEJSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, -* M, N, A, LDA, SVA, U, LDU, V, LDV, -* CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* IMPLICIT NONE -* INTEGER INFO, LDA, LDU, LDV, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) -* REAL SVA( N ), RWORK( LRWORK ) -* INTEGER IWORK( * ) -* CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> CGEJSV computes the singular value decomposition (SVD) of a real M-by-N -*> matrix [A], where M >= N. The SVD of [A] is written as -*> -*> [A] = [U] * [SIGMA] * [V]^*, -*> -*> where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N -*> diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and -*> [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are -*> the singular values of [A]. The columns of [U] and [V] are the left and -*> the right singular vectors of [A], respectively. The matrices [U] and [V] -*> are computed and stored in the arrays U and V, respectively. The diagonal -*> of [SIGMA] is computed and stored in the array SVA. -*> -*> Arguments: -*> ========== -*> -*> \param[in] JOBA -*> \verbatim -*> JOBA is CHARACTER*1 -*> Specifies the level of accuracy: -*> = 'C': This option works well (high relative accuracy) if A = B * D, -*> with well-conditioned B and arbitrary diagonal matrix D. -*> The accuracy cannot be spoiled by COLUMN scaling. The -*> accuracy of the computed output depends on the condition of -*> B, and the procedure aims at the best theoretical accuracy. -*> The relative error max_{i=1:N}|d sigma_i| / sigma_i is -*> bounded by f(M,N)*epsilon* cond(B), independent of D. -*> The input matrix is preprocessed with the QRF with column -*> pivoting. This initial preprocessing and preconditioning by -*> a rank revealing QR factorization is common for all values of -*> JOBA. Additional actions are specified as follows: -*> = 'E': Computation as with 'C' with an additional estimate of the -*> condition number of B. It provides a realistic error bound. -*> = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings -*> D1, D2, and well-conditioned matrix C, this option gives -*> higher accuracy than the 'C' option. If the structure of the -*> input matrix is not known, and relative accuracy is -*> desirable, then this option is advisable. The input matrix A -*> is preprocessed with QR factorization with FULL (row and -*> column) pivoting. -*> = 'G' Computation as with 'F' with an additional estimate of the -*> condition number of B, where A=D*B. If A has heavily weighted -*> rows, then using this condition number gives too pessimistic -*> error bound. -*> = 'A': Small singular values are the noise and the matrix is treated -*> as numerically rank defficient. The error in the computed -*> singular values is bounded by f(m,n)*epsilon*||A||. -*> The computed SVD A = U * S * V^* restores A up to -*> f(m,n)*epsilon*||A||. -*> This gives the procedure the licence to discard (set to zero) -*> all singular values below N*epsilon*||A||. -*> = 'R': Similar as in 'A'. Rank revealing property of the initial -*> QR factorization is used do reveal (using triangular factor) -*> a gap sigma_{r+1} < epsilon * sigma_r in which case the -*> numerical RANK is declared to be r. The SVD is computed with -*> absolute error bounds, but more accurately than with 'A'. -*> \endverbatim -*> -*> \param[in] JOBU -*> \verbatim -*> JOBU is CHARACTER*1 -*> Specifies whether to compute the columns of U: -*> = 'U': N columns of U are returned in the array U. -*> = 'F': full set of M left sing. vectors is returned in the array U. -*> = 'W': U may be used as workspace of length M*N. See the description -*> of U. -*> = 'N': U is not computed. -*> \endverbatim -*> -*> \param[in] JOBV -*> \verbatim -*> JOBV is CHARACTER*1 -*> Specifies whether to compute the matrix V: -*> = 'V': N columns of V are returned in the array V; Jacobi rotations -*> are not explicitly accumulated. -*> = 'J': N columns of V are returned in the array V, but they are -*> computed as the product of Jacobi rotations. This option is -*> allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. -*> = 'W': V may be used as workspace of length N*N. See the description -*> of V. -*> = 'N': V is not computed. -*> \endverbatim -*> -*> \param[in] JOBR -*> \verbatim -*> JOBR is CHARACTER*1 -*> Specifies the RANGE for the singular values. Issues the licence to -*> set to zero small positive singular values if they are outside -*> specified range. If A .NE. 0 is scaled so that the largest singular -*> value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues -*> the licence to kill columns of A whose norm in c*A is less than -*> SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, -*> where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). -*> = 'N': Do not kill small columns of c*A. This option assumes that -*> BLAS and QR factorizations and triangular solvers are -*> implemented to work in that range. If the condition of A -*> is greater than BIG, use CGESVJ. -*> = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] -*> (roughly, as described above). This option is recommended. -*> =========================== -*> For computing the singular values in the FULL range [SFMIN,BIG] -*> use CGESVJ. -*> \endverbatim -*> -*> \param[in] JOBT -*> \verbatim -*> JOBT is CHARACTER*1 -*> If the matrix is square then the procedure may determine to use -*> transposed A if A^* seems to be better with respect to convergence. -*> If the matrix is not square, JOBT is ignored. This is subject to -*> changes in the future. -*> The decision is based on two values of entropy over the adjoint -*> orbit of A^* * A. See the descriptions of WORK(6) and WORK(7). -*> = 'T': transpose if entropy test indicates possibly faster -*> convergence of Jacobi process if A^* is taken as input. If A is -*> replaced with A^*, then the row pivoting is included automatically. -*> = 'N': do not speculate. -*> This option can be used to compute only the singular values, or the -*> full SVD (U, SIGMA and V). For only one set of singular vectors -*> (U or V), the caller should provide both U and V, as one of the -*> matrices is used as workspace if the matrix A is transposed. -*> The implementer can easily remove this constraint and make the -*> code more complicated. See the descriptions of U and V. -*> \endverbatim -*> -*> \param[in] JOBP -*> \verbatim -*> JOBP is CHARACTER*1 -*> Issues the licence to introduce structured perturbations to drown -*> denormalized numbers. This licence should be active if the -*> denormals are poorly implemented, causing slow computation, -*> especially in cases of fast convergence (!). For details see [1,2]. -*> For the sake of simplicity, this perturbations are included only -*> when the full SVD or only the singular values are requested. The -*> implementer/user can easily add the perturbation for the cases of -*> computing one set of singular vectors. -*> = 'P': introduce perturbation -*> = 'N': do not perturb -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the input matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the input matrix A. M >= N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] SVA -*> \verbatim -*> SVA is REAL array, dimension (N) -*> On exit, -*> - For WORK(1)/WORK(2) = ONE: The singular values of A. During the -*> computation SVA contains Euclidean column norms of the -*> iterated matrices in the array A. -*> - For WORK(1) .NE. WORK(2): The singular values of A are -*> (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if -*> sigma_max(A) overflows or if small singular values have been -*> saved from underflow by scaling the input matrix A. -*> - If JOBR='R' then some of the singular values may be returned -*> as exact zeros obtained by "set to zero" because they are -*> below the numerical rank threshold or are denormalized numbers. -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is COMPLEX array, dimension ( LDU, N ) -*> If JOBU = 'U', then U contains on exit the M-by-N matrix of -*> the left singular vectors. -*> If JOBU = 'F', then U contains on exit the M-by-M matrix of -*> the left singular vectors, including an ONB -*> of the orthogonal complement of the Range(A). -*> If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), -*> then U is used as workspace if the procedure -*> replaces A with A^*. In that case, [V] is computed -*> in U as left singular vectors of A^* and then -*> copied back to the V array. This 'W' option is just -*> a reminder to the caller that in this case U is -*> reserved as workspace of length N*N. -*> If JOBU = 'N' U is not referenced. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U, LDU >= 1. -*> IF JOBU = 'U' or 'F' or 'W', then LDU >= M. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is COMPLEX array, dimension ( LDV, N ) -*> If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of -*> the right singular vectors; -*> If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), -*> then V is used as workspace if the pprocedure -*> replaces A with A^*. In that case, [U] is computed -*> in V as right singular vectors of A^* and then -*> copied back to the U array. This 'W' option is just -*> a reminder to the caller that in this case V is -*> reserved as workspace of length N*N. -*> If JOBV = 'N' V is not referenced. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V, LDV >= 1. -*> If JOBV = 'V' or 'J' or 'W', then LDV >= N. -*> \endverbatim -*> -*> \param[out] CWORK -*> \verbatim -*> CWORK is COMPLEX array, dimension at least LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> Length of CWORK to confirm proper allocation of workspace. -*> LWORK depends on the job: -*> -*> 1. If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and -*> 1.1 .. no scaled condition estimate required (JOBE.EQ.'N'): -*> LWORK >= 2*N+1. This is the minimal requirement. -*> ->> For optimal performance (blocked code) the optimal value -*> is LWORK >= N + (N+1)*NB. Here NB is the optimal -*> block size for CGEQP3 and CGEQRF. -*> In general, optimal LWORK is computed as -*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CGEQRF)). -*> 1.2. .. an estimate of the scaled condition number of A is -*> required (JOBA='E', or 'G'). In this case, LWORK the minimal -*> requirement is LWORK >= N*N + 3*N. -*> ->> For optimal performance (blocked code) the optimal value -*> is LWORK >= max(N+(N+1)*NB, N*N+3*N). -*> In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CGEQRF), -*> N+N*N+LWORK(CPOCON)). -*> -*> 2. If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), -*> (JOBU.EQ.'N') -*> -> the minimal requirement is LWORK >= 3*N. -*> -> For optimal performance, LWORK >= max(N+(N+1)*NB, 3*N,2*N+N*NB), -*> where NB is the optimal block size for CGEQP3, CGEQRF, CGELQ, -*> CUNMLQ. In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(CGEQP3), N+LWORK(CPOCON), N+LWORK(CGESVJ), -*> N+LWORK(CGELQF), 2*N+LWORK(CGEQRF), N+LWORK(CUNMLQ)). -*> -*> 3. If SIGMA and the left singular vectors are needed -*> -> the minimal requirement is LWORK >= 3*N. -*> -> For optimal performance: -*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB), -*> where NB is the optimal block size for CGEQP3, CGEQRF, CUNMQR. -*> In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CPOCON), -*> 2*N+LWORK(CGEQRF), N+LWORK(CUNMQR)). -*> -*> 4. If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and -*> 4.1. if JOBV.EQ.'V' -*> the minimal requirement is LWORK >= 5*N+2*N*N. -*> 4.2. if JOBV.EQ.'J' the minimal requirement is -*> LWORK >= 4*N+N*N. -*> In both cases, the allocated CWORK can accomodate blocked runs -*> of CGEQP3, CGEQRF, CGELQF, SUNMQR, CUNMLQ. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is REAL array, dimension at least LRWORK. -*> On exit, -*> RWORK(1) = Determines the scaling factor SCALE = RWORK(2) / RWORK(1) -*> such that SCALE*SVA(1:N) are the computed singular values -*> of A. (See the description of SVA().) -*> RWORK(2) = See the description of RWORK(1). -*> RWORK(3) = SCONDA is an estimate for the condition number of -*> column equilibrated A. (If JOBA .EQ. 'E' or 'G') -*> SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). -*> It is computed using SPOCON. It holds -*> N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA -*> where R is the triangular factor from the QRF of A. -*> However, if R is truncated and the numerical rank is -*> determined to be strictly smaller than N, SCONDA is -*> returned as -1, thus indicating that the smallest -*> singular values might be lost. -*> -*> If full SVD is needed, the following two condition numbers are -*> useful for the analysis of the algorithm. They are provied for -*> a developer/implementer who is familiar with the details of -*> the method. -*> -*> RWORK(4) = an estimate of the scaled condition number of the -*> triangular factor in the first QR factorization. -*> RWORK(5) = an estimate of the scaled condition number of the -*> triangular factor in the second QR factorization. -*> The following two parameters are computed if JOBT .EQ. 'T'. -*> They are provided for a developer/implementer who is familiar -*> with the details of the method. -*> RWORK(6) = the entropy of A^* * A :: this is the Shannon entropy -*> of diag(A^* * A) / Trace(A^* * A) taken as point in the -*> probability simplex. -*> RWORK(7) = the entropy of A * A^*. (See the description of RWORK(6).) -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> Length of RWORK to confirm proper allocation of workspace. -*> LRWORK depends on the job: -*> -*> 1. If only singular values are requested i.e. if -*> LSAME(JOBU,'N') .AND. LSAME(JOBV,'N') -*> then: -*> 1.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 1.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 2. If singular values with the right singular vectors are requested -*> i.e. if -*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) .AND. -*> .NOT.(LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) -*> then: -*> 2.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 2.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 3. If singular values with the left singular vectors are requested, i.e. if -*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. -*> .NOT.(LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) -*> then: -*> 3.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 3.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 4. If singular values with both the left and the right singular vectors -*> are requested, i.e. if -*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. -*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) -*> then: -*> 4.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 4.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, of dimension: -*> If LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), then -*> the dimension of IWORK is max( 3, 2 * N + M ). -*> Otherwise, the dimension of IWORK is -*> -> max( 3, 2*N ) for full SVD -*> -> max( 3, N ) for singular values only or singular -*> values with one set of singular vectors (left or right) -*> On exit, -*> IWORK(1) = the numerical rank determined after the initial -*> QR factorization with pivoting. See the descriptions -*> of JOBA and JOBR. -*> IWORK(2) = the number of the computed nonzero singular values -*> IWORK(3) = if nonzero, a warning message: -*> If IWORK(3).EQ.1 then some of the column norms of A -*> were denormalized floats. The requested high accuracy -*> is not warranted by the data. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> < 0 : if INFO = -i, then the i-th argument had an illegal value. -*> = 0 : successfull exit; -*> > 0 : CGEJSV did not converge in the maximal allowed number -*> of sweeps. The computed values may be inaccurate. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2015 -* -*> \ingroup complexGEsing -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> CGEJSV implements a preconditioned Jacobi SVD algorithm. It uses CGEQP3, -*> CGEQRF, and CGELQF as preprocessors and preconditioners. Optionally, an -*> additional row pivoting can be used as a preprocessor, which in some -*> cases results in much higher accuracy. An example is matrix A with the -*> structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned -*> diagonal matrices and C is well-conditioned matrix. In that case, complete -*> pivoting in the first QR factorizations provides accuracy dependent on the -*> condition number of C, and independent of D1, D2. Such higher accuracy is -*> not completely understood theoretically, but it works well in practice. -*> Further, if A can be written as A = B*D, with well-conditioned B and some -*> diagonal D, then the high accuracy is guaranteed, both theoretically and -*> in software, independent of D. For more details see [1], [2]. -*> The computational range for the singular values can be the full range -*> ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS -*> & LAPACK routines called by CGEJSV are implemented to work in that range. -*> If that is not the case, then the restriction for safe computation with -*> the singular values in the range of normalized IEEE numbers is that the -*> spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not -*> overflow. This code (CGEJSV) is best used in this restricted range, -*> meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are -*> returned as zeros. See JOBR for details on this. -*> Further, this implementation is somewhat slower than the one described -*> in [1,2] due to replacement of some non-LAPACK components, and because -*> the choice of some tuning parameters in the iterative part (CGESVJ) is -*> left to the implementer on a particular machine. -*> The rank revealing QR factorization (in this code: CGEQP3) should be -*> implemented as in [3]. We have a new version of CGEQP3 under development -*> that is more robust than the current one in LAPACK, with a cleaner cut in -*> rank defficient cases. It will be available in the SIGMA library [4]. -*> If M is much larger than N, it is obvious that the inital QRF with -*> column pivoting can be preprocessed by the QRF without pivoting. That -*> well known trick is not used in CGEJSV because in some cases heavy row -*> weighting can be treated with complete pivoting. The overhead in cases -*> M much larger than N is then only due to pivoting, but the benefits in -*> terms of accuracy have prevailed. The implementer/user can incorporate -*> this extra QRF step easily. The implementer can also improve data movement -*> (matrix transpose, matrix copy, matrix transposed copy) - this -*> implementation of CGEJSV uses only the simplest, naive data movement. -* -*> \par Contributors: -* ================== -*> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) -* -*> \par References: -* ================ -*> -*> \verbatim -*> -*> [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. -*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. -*> LAPACK Working note 169. -*> [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. -*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. -*> LAPACK Working note 170. -*> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR -*> factorization software - a case study. -*> ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28. -*> LAPACK Working note 176. -*> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, -*> QSVD, (H,K)-SVD computations. -*> Department of Mathematics, University of Zagreb, 2008. -*> \endverbatim -* -*> \par Bugs, examples and comments: -* ================================= -*> -*> Please report all bugs and send interesting examples and/or comments to -*> drmac@math.hr. Thank you. -*> -* ===================================================================== - SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, - $ M, N, A, LDA, SVA, U, LDU, V, LDV, - $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.6.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 -* -* .. Scalar Arguments .. - IMPLICIT NONE - INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) - REAL SVA( N ), RWORK( * ) - INTEGER IWORK( * ) - CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV -* .. -* -* =========================================================================== -* -* .. Local Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) - COMPLEX CZERO, CONE - PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), CONE = ( 1.0E0, 0.0E0 ) ) -* .. -* .. Local Scalars .. - COMPLEX CTEMP - REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, - $ CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, - $ SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC - INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING - LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC, - $ L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, - $ NOSCAL, ROWPIV, RSVEC, TRANSP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, CONJG, ALOG, AMAX1, AMIN1, CMPLX, FLOAT, - $ MAX0, MIN0, NINT, SIGN, SQRT -* .. -* .. External Functions .. - REAL SLAMCH, SCNRM2 - INTEGER ISAMAX - LOGICAL LSAME - EXTERNAL ISAMAX, LSAME, SLAMCH, SCNRM2 -* .. -* .. External Subroutines .. - EXTERNAL CCOPY, CGELQF, CGEQP3, CGEQRF, CLACPY, CLASCL, - $ CLASET, CLASSQ, CLASWP, CUNGQR, CUNMLQ, - $ CUNMQR, CPOCON, SSCAL, CSSCAL, CSWAP, CTRSM, XERBLA -* - EXTERNAL CGESVJ -* .. -* -* Test the input arguments -* - LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) - JRACC = LSAME( JOBV, 'J' ) - RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC - ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) - L2RANK = LSAME( JOBA, 'R' ) - L2ABER = LSAME( JOBA, 'A' ) - ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) - L2TRAN = LSAME( JOBT, 'T' ) - L2KILL = LSAME( JOBR, 'R' ) - DEFR = LSAME( JOBR, 'N' ) - L2PERT = LSAME( JOBP, 'P' ) -* - IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. - $ ERREST .OR. LSAME( JOBA, 'C' ) )) THEN - INFO = - 1 - ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. - $ LSAME( JOBU, 'W' )) ) THEN - INFO = - 2 - ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. - $ LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN - INFO = - 3 - ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN - INFO = - 4 - ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN - INFO = - 5 - ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN - INFO = - 6 - ELSE IF ( M .LT. 0 ) THEN - INFO = - 7 - ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN - INFO = - 8 - ELSE IF ( LDA .LT. M ) THEN - INFO = - 10 - ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN - INFO = - 13 - ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN - INFO = - 15 - ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. - $ (LWORK .LT. 2*N+1)) .OR. - $ (.NOT.(LSVEC .OR. RSVEC) .AND. ERREST .AND. - $ (LWORK .LT. N*N+3*N)) .OR. - $ (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. 3*N)) - $ .OR. - $ (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. 3*N)) - $ .OR. - $ (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. - $ (LWORK.LT.5*N+2*N*N)) - $ .OR. (LSVEC .AND. RSVEC .AND. JRACC .AND. - $ LWORK.LT.4*N+N*N)) - $ THEN - INFO = - 17 - ELSE IF ( LRWORK.LT. MAX0(N+2*M,7)) THEN - INFO = -19 - ELSE -* #:) - INFO = 0 - END IF -* - IF ( INFO .NE. 0 ) THEN -* #:( - CALL XERBLA( 'CGEJSV', - INFO ) - RETURN - END IF -* -* Quick return for void matrix (Y3K safe) -* #:) - IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN -* -* Determine whether the matrix U should be M x N or M x M -* - IF ( LSVEC ) THEN - N1 = N - IF ( LSAME( JOBU, 'F' ) ) N1 = M - END IF -* -* Set numerical parameters -* -*! NOTE: Make sure SLAMCH() does not fail on the target architecture. -* - EPSLN = SLAMCH('Epsilon') - SFMIN = SLAMCH('SafeMinimum') - SMALL = SFMIN / EPSLN - BIG = SLAMCH('O') -* BIG = ONE / SFMIN -* -* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N -* -*(!) If necessary, scale SVA() to protect the largest norm from -* overflow. It is possible that this scaling pushes the smallest -* column norm left from the underflow threshold (extreme case). -* - SCALEM = ONE / SQRT(FLOAT(M)*FLOAT(N)) - NOSCAL = .TRUE. - GOSCAL = .TRUE. - DO 1874 p = 1, N - AAPP = ZERO - AAQQ = ONE - CALL CLASSQ( M, A(1,p), 1, AAPP, AAQQ ) - IF ( AAPP .GT. BIG ) THEN - INFO = - 9 - CALL XERBLA( 'CGEJSV', -INFO ) - RETURN - END IF - AAQQ = SQRT(AAQQ) - IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN - SVA(p) = AAPP * AAQQ - ELSE - NOSCAL = .FALSE. - SVA(p) = AAPP * ( AAQQ * SCALEM ) - IF ( GOSCAL ) THEN - GOSCAL = .FALSE. - CALL SSCAL( p-1, SCALEM, SVA, 1 ) - END IF - END IF - 1874 CONTINUE -* - IF ( NOSCAL ) SCALEM = ONE -* - AAPP = ZERO - AAQQ = BIG - DO 4781 p = 1, N - AAPP = AMAX1( AAPP, SVA(p) ) - IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) ) - 4781 CONTINUE -* -* Quick return for zero M x N matrix -* #:) - IF ( AAPP .EQ. ZERO ) THEN - IF ( LSVEC ) CALL CLASET( 'G', M, N1, CZERO, CONE, U, LDU ) - IF ( RSVEC ) CALL CLASET( 'G', N, N, CZERO, CONE, V, LDV ) - RWORK(1) = ONE - RWORK(2) = ONE - IF ( ERREST ) RWORK(3) = ONE - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = ONE - RWORK(5) = ONE - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ZERO - RWORK(7) = ZERO - END IF - IWORK(1) = 0 - IWORK(2) = 0 - IWORK(3) = 0 - RETURN - END IF -* -* Issue warning if denormalized column norms detected. Override the -* high relative accuracy request. Issue licence to kill columns -* (set them to zero) whose norm is less than sigma_max / BIG (roughly). -* #:( - WARNING = 0 - IF ( AAQQ .LE. SFMIN ) THEN - L2RANK = .TRUE. - L2KILL = .TRUE. - WARNING = 1 - END IF -* -* Quick return for one-column matrix -* #:) - IF ( N .EQ. 1 ) THEN -* - IF ( LSVEC ) THEN - CALL CLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) - CALL CLACPY( 'A', M, 1, A, LDA, U, LDU ) -* computing all M left singular vectors of the M x 1 matrix - IF ( N1 .NE. N ) THEN - CALL CGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) - CALL CUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) - CALL CCOPY( M, A(1,1), 1, U(1,1), 1 ) - END IF - END IF - IF ( RSVEC ) THEN - V(1,1) = CONE - END IF - IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN - SVA(1) = SVA(1) / SCALEM - SCALEM = ONE - END IF - RWORK(1) = ONE / SCALEM - RWORK(2) = ONE - IF ( SVA(1) .NE. ZERO ) THEN - IWORK(1) = 1 - IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN - IWORK(2) = 1 - ELSE - IWORK(2) = 0 - END IF - ELSE - IWORK(1) = 0 - IWORK(2) = 0 - END IF - IWORK(3) = 0 - IF ( ERREST ) RWORK(3) = ONE - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = ONE - RWORK(5) = ONE - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ZERO - RWORK(7) = ZERO - END IF - RETURN -* - END IF -* - TRANSP = .FALSE. - L2TRAN = L2TRAN .AND. ( M .EQ. N ) -* - AATMAX = -ONE - AATMIN = BIG - IF ( ROWPIV .OR. L2TRAN ) THEN -* -* Compute the row norms, needed to determine row pivoting sequence -* (in the case of heavily row weighted A, row pivoting is strongly -* advised) and to collect information needed to compare the -* structures of A * A^* and A^* * A (in the case L2TRAN.EQ..TRUE.). -* - IF ( L2TRAN ) THEN - DO 1950 p = 1, M - XSC = ZERO - TEMP1 = ONE - CALL CLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) -* CLASSQ gets both the ell_2 and the ell_infinity norm -* in one pass through the vector - RWORK(M+N+p) = XSC * SCALEM - RWORK(N+p) = XSC * (SCALEM*SQRT(TEMP1)) - AATMAX = AMAX1( AATMAX, RWORK(N+p) ) - IF (RWORK(N+p) .NE. ZERO) - $ AATMIN = AMIN1(AATMIN,RWORK(N+p)) - 1950 CONTINUE - ELSE - DO 1904 p = 1, M - RWORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) ) - AATMAX = AMAX1( AATMAX, RWORK(M+N+p) ) - AATMIN = AMIN1( AATMIN, RWORK(M+N+p) ) - 1904 CONTINUE - END IF -* - END IF -* -* For square matrix A try to determine whether A^* would be better -* input for the preconditioned Jacobi SVD, with faster convergence. -* The decision is based on an O(N) function of the vector of column -* and row norms of A, based on the Shannon entropy. This should give -* the right choice in most cases when the difference actually matters. -* It may fail and pick the slower converging side. -* - ENTRA = ZERO - ENTRAT = ZERO - IF ( L2TRAN ) THEN -* - XSC = ZERO - TEMP1 = ONE - CALL CLASSQ( N, SVA, 1, XSC, TEMP1 ) - TEMP1 = ONE / TEMP1 -* - ENTRA = ZERO - DO 1113 p = 1, N - BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 - IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1) - 1113 CONTINUE - ENTRA = - ENTRA / ALOG(FLOAT(N)) -* -* Now, SVA().^2/Trace(A^* * A) is a point in the probability simplex. -* It is derived from the diagonal of A^* * A. Do the same with the -* diagonal of A * A^*, compute the entropy of the corresponding -* probability distribution. Note that A * A^* and A^* * A have the -* same trace. -* - ENTRAT = ZERO - DO 1114 p = N+1, N+M - BIG1 = ( ( RWORK(p) / XSC )**2 ) * TEMP1 - IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1) - 1114 CONTINUE - ENTRAT = - ENTRAT / ALOG(FLOAT(M)) -* -* Analyze the entropies and decide A or A^*. Smaller entropy -* usually means better input for the algorithm. -* - TRANSP = ( ENTRAT .LT. ENTRA ) - TRANSP = .TRUE. -* -* If A^* is better than A, take the adjoint of A. -* - IF ( TRANSP ) THEN -* In an optimal implementation, this trivial transpose -* should be replaced with faster transpose. - DO 1115 p = 1, N - 1 - A(p,p) = CONJG(A(p,p)) - DO 1116 q = p + 1, N - CTEMP = CONJG(A(q,p)) - A(q,p) = CONJG(A(p,q)) - A(p,q) = CTEMP - 1116 CONTINUE - 1115 CONTINUE - A(N,N) = CONJG(A(N,N)) - DO 1117 p = 1, N - RWORK(M+N+p) = SVA(p) - SVA(p) = RWORK(N+p) -* previously computed row 2-norms are now column 2-norms -* of the transposed matrix - 1117 CONTINUE - TEMP1 = AAPP - AAPP = AATMAX - AATMAX = TEMP1 - TEMP1 = AAQQ - AAQQ = AATMIN - AATMIN = TEMP1 - KILL = LSVEC - LSVEC = RSVEC - RSVEC = KILL - IF ( LSVEC ) N1 = N -* - ROWPIV = .TRUE. - END IF -* - END IF -* END IF L2TRAN -* -* Scale the matrix so that its maximal singular value remains less -* than SQRT(BIG) -- the matrix is scaled so that its maximal column -* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep -* SQRT(BIG) instead of BIG is the fact that CGEJSV uses LAPACK and -* BLAS routines that, in some implementations, are not capable of -* working in the full interval [SFMIN,BIG] and that they may provoke -* overflows in the intermediate results. If the singular values spread -* from SFMIN to BIG, then CGESVJ will compute them. So, in that case, -* one should use CGESVJ instead of CGEJSV. -* - BIG1 = SQRT( BIG ) - TEMP1 = SQRT( BIG / FLOAT(N) ) -* - CALL CLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) - IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN - AAQQ = ( AAQQ / AAPP ) * TEMP1 - ELSE - AAQQ = ( AAQQ * TEMP1 ) / AAPP - END IF - TEMP1 = TEMP1 * SCALEM - CALL CLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) -* -* To undo scaling at the end of this procedure, multiply the -* computed singular values with USCAL2 / USCAL1. -* - USCAL1 = TEMP1 - USCAL2 = AAPP -* - IF ( L2KILL ) THEN -* L2KILL enforces computation of nonzero singular values in -* the restricted range of condition number of the initial A, -* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). - XSC = SQRT( SFMIN ) - ELSE - XSC = SMALL -* -* Now, if the condition number of A is too big, -* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, -* as a precaution measure, the full SVD is computed using CGESVJ -* with accumulated Jacobi rotations. This provides numerically -* more robust computation, at the cost of slightly increased run -* time. Depending on the concrete implementation of BLAS and LAPACK -* (i.e. how they behave in presence of extreme ill-conditioning) the -* implementor may decide to remove this switch. - IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN - JRACC = .TRUE. - END IF -* - END IF - IF ( AAQQ .LT. XSC ) THEN - DO 700 p = 1, N - IF ( SVA(p) .LT. XSC ) THEN - CALL CLASET( 'A', M, 1, CZERO, CZERO, A(1,p), LDA ) - SVA(p) = ZERO - END IF - 700 CONTINUE - END IF -* -* Preconditioning using QR factorization with pivoting -* - IF ( ROWPIV ) THEN -* Optional row permutation (Bjoerck row pivoting): -* A result by Cox and Higham shows that the Bjoerck's -* row pivoting combined with standard column pivoting -* has similar effect as Powell-Reid complete pivoting. -* The ell-infinity norms of A are made nonincreasing. - DO 1952 p = 1, M - 1 - q = ISAMAX( M-p+1, RWORK(M+N+p), 1 ) + p - 1 - IWORK(2*N+p) = q - IF ( p .NE. q ) THEN - TEMP1 = RWORK(M+N+p) - RWORK(M+N+p) = RWORK(M+N+q) - RWORK(M+N+q) = TEMP1 - END IF - 1952 CONTINUE - CALL CLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 ) - END IF -* -* End of the preparation phase (scaling, optional sorting and -* transposing, optional flushing of small columns). -* -* Preconditioning -* -* If the full SVD is needed, the right singular vectors are computed -* from a matrix equation, and for that we need theoretical analysis -* of the Businger-Golub pivoting. So we use CGEQP3 as the first RR QRF. -* In all other cases the first RR QRF can be chosen by other criteria -* (eg speed by replacing global with restricted window pivoting, such -* as in xGEQPX from TOMS # 782). Good results will be obtained using -* xGEQPX with properly (!) chosen numerical parameters. -* Any improvement of CGEQP3 improves overal performance of CGEJSV. -* -* A * P1 = Q1 * [ R1^* 0]^*: - DO 1963 p = 1, N -* .. all columns are free columns - IWORK(p) = 0 - 1963 CONTINUE - CALL CGEQP3( M, N, A, LDA, IWORK, CWORK, CWORK(N+1), LWORK-N, - $ RWORK, IERR ) -* -* The upper triangular matrix R1 from the first QRF is inspected for -* rank deficiency and possibilities for deflation, or possible -* ill-conditioning. Depending on the user specified flag L2RANK, -* the procedure explores possibilities to reduce the numerical -* rank by inspecting the computed upper triangular factor. If -* L2RANK or L2ABER are up, then CGEJSV will compute the SVD of -* A + dA, where ||dA|| <= f(M,N)*EPSLN. -* - NR = 1 - IF ( L2ABER ) THEN -* Standard absolute error bound suffices. All sigma_i with -* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an -* agressive enforcement of lower numerical rank by introducing a -* backward error of the order of N*EPSLN*||A||. - TEMP1 = SQRT(FLOAT(N))*EPSLN - DO 3001 p = 2, N - IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN - NR = NR + 1 - ELSE - GO TO 3002 - END IF - 3001 CONTINUE - 3002 CONTINUE - ELSE IF ( L2RANK ) THEN -* .. similarly as above, only slightly more gentle (less agressive). -* Sudden drop on the diagonal of R1 is used as the criterion for -* close-to-rank-defficient. - TEMP1 = SQRT(SFMIN) - DO 3401 p = 2, N - IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. - $ ( ABS(A(p,p)) .LT. SMALL ) .OR. - $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 - NR = NR + 1 - 3401 CONTINUE - 3402 CONTINUE -* - ELSE -* The goal is high relative accuracy. However, if the matrix -* has high scaled condition number the relative accuracy is in -* general not feasible. Later on, a condition number estimator -* will be deployed to estimate the scaled condition number. -* Here we just remove the underflowed part of the triangular -* factor. This prevents the situation in which the code is -* working hard to get the accuracy not warranted by the data. - TEMP1 = SQRT(SFMIN) - DO 3301 p = 2, N - IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR. - $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 - NR = NR + 1 - 3301 CONTINUE - 3302 CONTINUE -* - END IF -* - ALMORT = .FALSE. - IF ( NR .EQ. N ) THEN - MAXPRJ = ONE - DO 3051 p = 2, N - TEMP1 = ABS(A(p,p)) / SVA(IWORK(p)) - MAXPRJ = AMIN1( MAXPRJ, TEMP1 ) - 3051 CONTINUE - IF ( MAXPRJ**2 .GE. ONE - FLOAT(N)*EPSLN ) ALMORT = .TRUE. - END IF -* -* - SCONDA = - ONE - CONDR1 = - ONE - CONDR2 = - ONE -* - IF ( ERREST ) THEN - IF ( N .EQ. NR ) THEN - IF ( RSVEC ) THEN -* .. V is available as workspace - CALL CLACPY( 'U', N, N, A, LDA, V, LDV ) - DO 3053 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL CSSCAL( p, ONE/TEMP1, V(1,p), 1 ) - 3053 CONTINUE - CALL CPOCON( 'U', N, V, LDV, ONE, TEMP1, - $ CWORK(N+1), RWORK, IERR ) -* - ELSE IF ( LSVEC ) THEN -* .. U is available as workspace - CALL CLACPY( 'U', N, N, A, LDA, U, LDU ) - DO 3054 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL CSSCAL( p, ONE/TEMP1, U(1,p), 1 ) - 3054 CONTINUE - CALL CPOCON( 'U', N, U, LDU, ONE, TEMP1, - $ CWORK(N+1), RWORK, IERR ) - ELSE - CALL CLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) - DO 3052 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL CSSCAL( p, ONE/TEMP1, CWORK(N+(p-1)*N+1), 1 ) - 3052 CONTINUE -* .. the columns of R are scaled to have unit Euclidean lengths. - CALL CPOCON( 'U', N, CWORK(N+1), N, ONE, TEMP1, - $ CWORK(N+N*N+1), RWORK, IERR ) -* - END IF - SCONDA = ONE / SQRT(TEMP1) -* SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). -* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA - ELSE - SCONDA = - ONE - END IF - END IF -* - L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) ) -* If there is no violent scaling, artificial perturbation is not needed. -* -* Phase 3: -* - IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN -* -* Singular Values only -* -* .. transpose A(1:NR,1:N) - DO 1946 p = 1, MIN0( N-1, NR ) - CALL CCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) - CALL CLACGV( N-p+1, A(p,p), 1 ) - 1946 CONTINUE - IF ( NR .EQ. N ) A(N,N) = CONJG(A(N,N)) -* -* The following two DO-loops introduce small relative perturbation -* into the strict upper triangle of the lower triangular matrix. -* Small entries below the main diagonal are also changed. -* This modification is useful if the computing environment does not -* provide/allow FLUSH TO ZERO underflow, for it prevents many -* annoying denormalized numbers in case of strongly scaled matrices. -* The perturbation is structured so that it does not introduce any -* new perturbation of the singular values, and it does not destroy -* the job done by the preconditioner. -* The licence for this perturbation is in the variable L2PERT, which -* should be .FALSE. if FLUSH TO ZERO underflow is active. -* - IF ( .NOT. ALMORT ) THEN -* - IF ( L2PERT ) THEN -* XSC = SQRT(SMALL) - XSC = EPSLN / FLOAT(N) - DO 4947 q = 1, NR - CTEMP = CMPLX(XSC*ABS(A(q,q)),ZERO) - DO 4949 p = 1, N - IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) - $ .OR. ( p .LT. q ) ) -* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) - $ A(p,q) = CTEMP - 4949 CONTINUE - 4947 CONTINUE - ELSE - CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, A(1,2),LDA ) - END IF -* -* .. second preconditioning using the QR factorization -* - CALL CGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) -* -* .. and transpose upper to lower triangular - DO 1948 p = 1, NR - 1 - CALL CCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) - CALL CLACGV( NR-p+1, A(p,p), 1 ) - 1948 CONTINUE -* - END IF -* -* Row-cyclic Jacobi SVD algorithm with column pivoting -* -* .. again some perturbation (a "background noise") is added -* to drown denormals - IF ( L2PERT ) THEN -* XSC = SQRT(SMALL) - XSC = EPSLN / FLOAT(N) - DO 1947 q = 1, NR - CTEMP = CMPLX(XSC*ABS(A(q,q)),ZERO) - DO 1949 p = 1, NR - IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) - $ .OR. ( p .LT. q ) ) -* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) - $ A(p,q) = CTEMP - 1949 CONTINUE - 1947 CONTINUE - ELSE - CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) - END IF -* -* .. and one-sided Jacobi rotations are started on a lower -* triangular matrix (plus perturbation which is ignored in -* the part which destroys triangular form (confusing?!)) -* - CALL CGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA, - $ N, V, LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) -* - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) -* -* - ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN -* -* -> Singular Values and Right Singular Vectors <- -* - IF ( ALMORT ) THEN -* -* .. in this case NR equals N - DO 1998 p = 1, NR - CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL CLACGV( N-p+1, V(p,p), 1 ) - 1998 CONTINUE - CALL CLASET( 'Upper', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) -* - CALL CGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA, - $ CWORK, LWORK, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - - ELSE -* -* .. two more QR factorizations ( one QRF is not enough, two require -* accumulated product of Jacobi rotations, three are perfect ) -* - CALL CLASET( 'Lower', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) - CALL CGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) - CALL CLACPY( 'Lower', NR, NR, A, LDA, V, LDV ) - CALL CLASET( 'Upper', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) - CALL CGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) - DO 8998 p = 1, NR - CALL CCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) - CALL CLACGV( NR-p+1, V(p,p), 1 ) - 8998 CONTINUE - CALL CLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) -* - CALL CGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U, - $ LDU, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) - CALL CLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) - CALL CLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) - END IF -* - CALL CUNMLQ( 'Left', 'C', N, N, NR, A, LDA, CWORK, - $ V, LDV, CWORK(N+1), LWORK-N, IERR ) -* - END IF -* - DO 8991 p = 1, N - CALL CCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) - 8991 CONTINUE - CALL CLACPY( 'All', N, N, A, LDA, V, LDV ) -* - IF ( TRANSP ) THEN - CALL CLACPY( 'All', N, N, V, LDV, U, LDU ) - END IF -* - ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN -* -* .. Singular Values and Left Singular Vectors .. -* -* .. second preconditioning step to avoid need to accumulate -* Jacobi rotations in the Jacobi iterations. - DO 1965 p = 1, NR - CALL CCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) - CALL CLACGV( N-p+1, U(p,p), 1 ) - 1965 CONTINUE - CALL CLASET( 'Upper', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) -* - CALL CGEQRF( N, NR, U, LDU, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) -* - DO 1967 p = 1, NR - 1 - CALL CCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) - CALL CLACGV( N-p+1, U(p,p), 1 ) - 1967 CONTINUE - CALL CLASET( 'Upper', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) -* - CALL CGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, - $ LDA, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) -* - IF ( NR .LT. M ) THEN - CALL CLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) - IF ( NR .LT. N1 ) THEN - CALL CLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) - CALL CLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) - END IF - END IF -* - CALL CUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) -* - IF ( ROWPIV ) - $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - DO 1974 p = 1, N1 - XSC = ONE / SCNRM2( M, U(1,p), 1 ) - CALL CSSCAL( M, XSC, U(1,p), 1 ) - 1974 CONTINUE -* - IF ( TRANSP ) THEN - CALL CLACPY( 'All', N, N, U, LDU, V, LDV ) - END IF -* - ELSE -* -* .. Full SVD .. -* - IF ( .NOT. JRACC ) THEN -* - IF ( .NOT. ALMORT ) THEN -* -* Second Preconditioning Step (QRF [with pivoting]) -* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is -* equivalent to an LQF CALL. Since in many libraries the QRF -* seems to be better optimized than the LQF, we do explicit -* transpose and use the QRF. This is subject to changes in an -* optimized implementation of CGEJSV. -* - DO 1968 p = 1, NR - CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL CLACGV( N-p+1, V(p,p), 1 ) - 1968 CONTINUE -* -* .. the following two loops perturb small entries to avoid -* denormals in the second QR factorization, where they are -* as good as zeros. This is done to avoid painfully slow -* computation with denormals. The relative size of the perturbation -* is a parameter that can be changed by the implementer. -* This perturbation device will be obsolete on machines with -* properly implemented arithmetic. -* To switch it off, set L2PERT=.FALSE. To remove it from the -* code, remove the action under L2PERT=.TRUE., leave the ELSE part. -* The following two loops should be blocked and fused with the -* transposed copy above. -* - IF ( L2PERT ) THEN - XSC = SQRT(SMALL) - DO 2969 q = 1, NR - CTEMP = CMPLX(XSC*ABS( V(q,q) ),ZERO) - DO 2968 p = 1, N - IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) - $ .OR. ( p .LT. q ) ) -* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) - $ V(p,q) = CTEMP - IF ( p .LT. q ) V(p,q) = - V(p,q) - 2968 CONTINUE - 2969 CONTINUE - ELSE - CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) - END IF -* -* Estimate the row scaled condition number of R1 -* (If R1 is rectangular, N > NR, then the condition number -* of the leading NR x NR submatrix is estimated.) -* - CALL CLACPY( 'L', NR, NR, V, LDV, CWORK(2*N+1), NR ) - DO 3950 p = 1, NR - TEMP1 = SCNRM2(NR-p+1,CWORK(2*N+(p-1)*NR+p),1) - CALL CSSCAL(NR-p+1,ONE/TEMP1,CWORK(2*N+(p-1)*NR+p),1) - 3950 CONTINUE - CALL CPOCON('Lower',NR,CWORK(2*N+1),NR,ONE,TEMP1, - $ CWORK(2*N+NR*NR+1),RWORK,IERR) - CONDR1 = ONE / SQRT(TEMP1) -* .. here need a second oppinion on the condition number -* .. then assume worst case scenario -* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N) -* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N)) -* - COND_OK = SQRT(SQRT(FLOAT(NR))) -*[TP] COND_OK is a tuning parameter. -* - IF ( CONDR1 .LT. COND_OK ) THEN -* .. the second QRF without pivoting. Note: in an optimized -* implementation, this QRF should be implemented as the QRF -* of a lower triangular matrix. -* R1^* = Q2 * R2 - CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) -* - IF ( L2PERT ) THEN - XSC = SQRT(SMALL)/EPSLN - DO 3959 p = 2, NR - DO 3958 q = 1, p - 1 - CTEMP=CMPLX(XSC*AMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) - IF ( ABS(V(q,p)) .LE. TEMP1 ) -* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) - $ V(q,p) = CTEMP - 3958 CONTINUE - 3959 CONTINUE - END IF -* - IF ( NR .NE. N ) - $ CALL CLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) -* .. save ... -* -* .. this transposed copy should be better than naive - DO 1969 p = 1, NR - 1 - CALL CCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) - CALL CLACGV(NR-p+1, V(p,p), 1 ) - 1969 CONTINUE - V(NR,NR)=CONJG(V(NR,NR)) -* - CONDR2 = CONDR1 -* - ELSE -* -* .. ill-conditioned case: second QRF with pivoting -* Note that windowed pivoting would be equaly good -* numerically, and more run-time efficient. So, in -* an optimal implementation, the next call to CGEQP3 -* should be replaced with eg. CALL CGEQPX (ACM TOMS #782) -* with properly (carefully) chosen parameters. -* -* R1^* * P2 = Q2 * R2 - DO 3003 p = 1, NR - IWORK(N+p) = 0 - 3003 CONTINUE - CALL CGEQP3( N, NR, V, LDV, IWORK(N+1), CWORK(N+1), - $ CWORK(2*N+1), LWORK-2*N, RWORK, IERR ) -** CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), -** $ LWORK-2*N, IERR ) - IF ( L2PERT ) THEN - XSC = SQRT(SMALL) - DO 3969 p = 2, NR - DO 3968 q = 1, p - 1 - CTEMP=CMPLX(XSC*AMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) - IF ( ABS(V(q,p)) .LE. TEMP1 ) -* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) - $ V(q,p) = CTEMP - 3968 CONTINUE - 3969 CONTINUE - END IF -* - CALL CLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) -* - IF ( L2PERT ) THEN - XSC = SQRT(SMALL) - DO 8970 p = 2, NR - DO 8971 q = 1, p - 1 - CTEMP=CMPLX(XSC*AMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) -* V(p,q) = - TEMP1*( V(q,p) / ABS(V(q,p)) ) - V(p,q) = - CTEMP - 8971 CONTINUE - 8970 CONTINUE - ELSE - CALL CLASET( 'L',NR-1,NR-1,CZERO,CZERO,V(2,1),LDV ) - END IF -* Now, compute R2 = L3 * Q3, the LQ factorization. - CALL CGELQF( NR, NR, V, LDV, CWORK(2*N+N*NR+1), - $ CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) -* .. and estimate the condition number - CALL CLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) - DO 4950 p = 1, NR - TEMP1 = SCNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) - CALL CSSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) - 4950 CONTINUE - CALL CPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, - $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) - CONDR2 = ONE / SQRT(TEMP1) -* -* - IF ( CONDR2 .GE. COND_OK ) THEN -* .. save the Householder vectors used for Q3 -* (this overwrittes the copy of R2, as it will not be -* needed in this branch, but it does not overwritte the -* Huseholder vectors of Q2.). - CALL CLACPY( 'U', NR, NR, V, LDV, CWORK(2*N+1), N ) -* .. and the rest of the information on Q3 is in -* WORK(2*N+N*NR+1:2*N+N*NR+N) - END IF -* - END IF -* - IF ( L2PERT ) THEN - XSC = SQRT(SMALL) - DO 4968 q = 2, NR - CTEMP = XSC * V(q,q) - DO 4969 p = 1, q - 1 -* V(p,q) = - SIGN( TEMP1, V(q,p) ) -* V(p,q) = - TEMP1*( V(p,q) / ABS(V(p,q)) ) - V(p,q) = - CTEMP - 4969 CONTINUE - 4968 CONTINUE - ELSE - CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) - END IF -* -* Second preconditioning finished; continue with Jacobi SVD -* The input matrix is lower trinagular. -* -* Recover the right singular vectors as solution of a well -* conditioned triangular matrix equation. -* - IF ( CONDR1 .LT. COND_OK ) THEN -* - CALL CGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, LDU, - $ CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,RWORK, - $ LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 3970 p = 1, NR - CALL CCOPY( NR, V(1,p), 1, U(1,p), 1 ) - CALL CSSCAL( NR, SVA(p), V(1,p), 1 ) - 3970 CONTINUE - -* .. pick the right matrix equation and solve it -* - IF ( NR .EQ. N ) THEN -* :)) .. best case, R1 is inverted. The solution of this matrix -* equation is Q2*V2 = the product of the Jacobi rotations -* used in CGESVJ, premultiplied with the orthogonal matrix -* from the second QR factorization. - CALL CTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) - ELSE -* .. R1 is well conditioned, but non-square. Adjoint of R2 -* is inverted to get the product of the Jacobi rotations -* used in CGESVJ. The Q-factor from the second QR -* factorization is then built in explicitly. - CALL CTRSM('L','U','C','N',NR,NR,CONE,CWORK(2*N+1), - $ N,V,LDV) - IF ( NR .LT. N ) THEN - CALL CLASET('A',N-NR,NR,ZERO,CZERO,V(NR+1,1),LDV) - CALL CLASET('A',NR,N-NR,ZERO,CZERO,V(1,NR+1),LDV) - CALL CLASET('A',N-NR,N-NR,ZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL CUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) - END IF -* - ELSE IF ( CONDR2 .LT. COND_OK ) THEN -* -* The matrix R2 is inverted. The solution of the matrix equation -* is Q3^* * V3 = the product of the Jacobi rotations (appplied to -* the lower triangular L3 from the LQ factorization of -* R2=L3*Q3), pre-multiplied with the transposed Q3. - CALL CGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, - $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 3870 p = 1, NR - CALL CCOPY( NR, V(1,p), 1, U(1,p), 1 ) - CALL CSSCAL( NR, SVA(p), U(1,p), 1 ) - 3870 CONTINUE - CALL CTRSM('L','U','N','N',NR,NR,CONE,CWORK(2*N+1),N, - $ U,LDU) -* .. apply the permutation from the second QR factorization - DO 873 q = 1, NR - DO 872 p = 1, NR - CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) - 872 CONTINUE - DO 874 p = 1, NR - U(p,q) = CWORK(2*N+N*NR+NR+p) - 874 CONTINUE - 873 CONTINUE - IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) - ELSE -* Last line of defense. -* #:( This is a rather pathological case: no scaled condition -* improvement after two pivoted QR factorizations. Other -* possibility is that the rank revealing QR factorization -* or the condition estimator has failed, or the COND_OK -* is set very close to ONE (which is unnecessary). Normally, -* this branch should never be executed, but in rare cases of -* failure of the RRQR or condition estimator, the last line of -* defense ensures that CGEJSV completes the task. -* Compute the full SVD of L3 using CGESVJ with explicit -* accumulation of Jacobi rotations. - CALL CGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, - $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) -* - CALL CUNMLQ( 'L', 'C', NR, NR, NR, CWORK(2*N+1), N, - $ CWORK(2*N+N*NR+1), U, LDU, CWORK(2*N+N*NR+NR+1), - $ LWORK-2*N-N*NR-NR, IERR ) - DO 773 q = 1, NR - DO 772 p = 1, NR - CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) - 772 CONTINUE - DO 774 p = 1, NR - U(p,q) = CWORK(2*N+N*NR+NR+p) - 774 CONTINUE - 773 CONTINUE -* - END IF -* -* Permute the rows of V using the (column) permutation from the -* first QRF. Also, scale the columns to make them unit in -* Euclidean norm. This applies to all cases. -* - TEMP1 = SQRT(FLOAT(N)) * EPSLN - DO 1972 q = 1, N - DO 972 p = 1, N - CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) - 972 CONTINUE - DO 973 p = 1, N - V(p,q) = CWORK(2*N+N*NR+NR+p) - 973 CONTINUE - XSC = ONE / SCNRM2( N, V(1,q), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL CSSCAL( N, XSC, V(1,q), 1 ) - 1972 CONTINUE -* At this moment, V contains the right singular vectors of A. -* Next, assemble the left singular vector matrix U (M x N). - IF ( NR .LT. M ) THEN - CALL CLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) - IF ( NR .LT. N1 ) THEN - CALL CLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) - CALL CLASET('A',M-NR,N1-NR,CZERO,CONE, - $ U(NR+1,NR+1),LDU) - END IF - END IF -* -* The Q matrix from the first QRF is built into the left singular -* matrix U. This applies to all cases. -* - CALL CUNMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) - -* The columns of U are normalized. The cost is O(M*N) flops. - TEMP1 = SQRT(FLOAT(M)) * EPSLN - DO 1973 p = 1, NR - XSC = ONE / SCNRM2( M, U(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL CSSCAL( M, XSC, U(1,p), 1 ) - 1973 CONTINUE -* -* If the initial QRF is computed with row pivoting, the left -* singular vectors must be adjusted. -* - IF ( ROWPIV ) - $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - ELSE -* -* .. the initial matrix A has almost orthogonal columns and -* the second QRF is not needed -* - CALL CLACPY( 'Upper', N, N, A, LDA, CWORK(N+1), N ) - IF ( L2PERT ) THEN - XSC = SQRT(SMALL) - DO 5970 p = 2, N - CTEMP = XSC * CWORK( N + (p-1)*N + p ) - DO 5971 q = 1, p - 1 -* CWORK(N+(q-1)*N+p)=-TEMP1 * ( CWORK(N+(p-1)*N+q) / -* $ ABS(CWORK(N+(p-1)*N+q)) ) - CWORK(N+(q-1)*N+p)=-CTEMP - 5971 CONTINUE - 5970 CONTINUE - ELSE - CALL CLASET( 'Lower',N-1,N-1,CZERO,CZERO,CWORK(N+2),N ) - END IF -* - CALL CGESVJ( 'Upper', 'U', 'N', N, N, CWORK(N+1), N, SVA, - $ N, U, LDU, CWORK(N+N*N+1), LWORK-N-N*N, RWORK, LRWORK, - $ INFO ) -* - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 6970 p = 1, N - CALL CCOPY( N, CWORK(N+(p-1)*N+1), 1, U(1,p), 1 ) - CALL CSSCAL( N, SVA(p), CWORK(N+(p-1)*N+1), 1 ) - 6970 CONTINUE -* - CALL CTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N, - $ CONE, A, LDA, CWORK(N+1), N ) - DO 6972 p = 1, N - CALL CCOPY( N, CWORK(N+p), N, V(IWORK(p),1), LDV ) - 6972 CONTINUE - TEMP1 = SQRT(FLOAT(N))*EPSLN - DO 6971 p = 1, N - XSC = ONE / SCNRM2( N, V(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL CSSCAL( N, XSC, V(1,p), 1 ) - 6971 CONTINUE -* -* Assemble the left singular vector matrix U (M x N). -* - IF ( N .LT. M ) THEN - CALL CLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) - IF ( N .LT. N1 ) THEN - CALL CLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) - CALL CLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) - END IF - END IF - CALL CUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) - TEMP1 = SQRT(FLOAT(M))*EPSLN - DO 6973 p = 1, N1 - XSC = ONE / SCNRM2( M, U(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL CSSCAL( M, XSC, U(1,p), 1 ) - 6973 CONTINUE -* - IF ( ROWPIV ) - $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - END IF -* -* end of the >> almost orthogonal case << in the full SVD -* - ELSE -* -* This branch deploys a preconditioned Jacobi SVD with explicitly -* accumulated rotations. It is included as optional, mainly for -* experimental purposes. It does perfom well, and can also be used. -* In this implementation, this branch will be automatically activated -* if the condition number sigma_max(A) / sigma_min(A) is predicted -* to be greater than the overflow threshold. This is because the -* a posteriori computation of the singular vectors assumes robust -* implementation of BLAS and some LAPACK procedures, capable of working -* in presence of extreme values. Since that is not always the case, ... -* - DO 7968 p = 1, NR - CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL CLACGV( N-p+1, V(p,p), 1 ) - 7968 CONTINUE -* - IF ( L2PERT ) THEN - XSC = SQRT(SMALL/EPSLN) - DO 5969 q = 1, NR - CTEMP = CMPLX(XSC*ABS( V(q,q) ),ZERO) - DO 5968 p = 1, N - IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) - $ .OR. ( p .LT. q ) ) -* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) - $ V(p,q) = CTEMP - IF ( p .LT. q ) V(p,q) = - V(p,q) - 5968 CONTINUE - 5969 CONTINUE - ELSE - CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) - END IF - - CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) - CALL CLACPY( 'L', N, NR, V, LDV, CWORK(2*N+1), N ) -* - DO 7969 p = 1, NR - CALL CCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) - CALL CLACGV( NR-p+1, U(p,p), 1 ) - 7969 CONTINUE - - IF ( L2PERT ) THEN - XSC = SQRT(SMALL/EPSLN) - DO 9970 q = 2, NR - DO 9971 p = 1, q - 1 - CTEMP = CMPLX(XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q))), - $ ZERO) -* U(p,q) = - TEMP1 * ( U(q,p) / ABS(U(q,p)) ) - U(p,q) = - CTEMP - 9971 CONTINUE - 9970 CONTINUE - ELSE - CALL CLASET('U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) - END IF - - CALL CGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA, - $ N, V, LDV, CWORK(2*N+N*NR+1), LWORK-2*N-N*NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - - IF ( NR .LT. N ) THEN - CALL CLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) - CALL CLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) - CALL CLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) - END IF - - CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) -* -* Permute the rows of V using the (column) permutation from the -* first QRF. Also, scale the columns to make them unit in -* Euclidean norm. This applies to all cases. -* - TEMP1 = SQRT(FLOAT(N)) * EPSLN - DO 7972 q = 1, N - DO 8972 p = 1, N - CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) - 8972 CONTINUE - DO 8973 p = 1, N - V(p,q) = CWORK(2*N+N*NR+NR+p) - 8973 CONTINUE - XSC = ONE / SCNRM2( N, V(1,q), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL CSSCAL( N, XSC, V(1,q), 1 ) - 7972 CONTINUE -* -* At this moment, V contains the right singular vectors of A. -* Next, assemble the left singular vector matrix U (M x N). -* - IF ( NR .LT. M ) THEN - CALL CLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) - IF ( NR .LT. N1 ) THEN - CALL CLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) - CALL CLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) - END IF - END IF -* - CALL CUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) -* - IF ( ROWPIV ) - $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* -* - END IF - IF ( TRANSP ) THEN -* .. swap U and V because the procedure worked on A^* - DO 6974 p = 1, N - CALL CSWAP( N, U(1,p), 1, V(1,p), 1 ) - 6974 CONTINUE - END IF -* - END IF -* end of the full SVD -* -* Undo scaling, if necessary (and possible) -* - IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN - CALL CLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) - USCAL1 = ONE - USCAL2 = ONE - END IF -* - IF ( NR .LT. N ) THEN - DO 3004 p = NR+1, N - SVA(p) = ZERO - 3004 CONTINUE - END IF -* - RWORK(1) = USCAL2 * SCALEM - RWORK(2) = USCAL1 - IF ( ERREST ) RWORK(3) = SCONDA - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = CONDR1 - RWORK(5) = CONDR2 - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ENTRA - RWORK(7) = ENTRAT - END IF -* - IWORK(1) = NR - IWORK(2) = NUMRANK - IWORK(3) = WARNING -* - RETURN -* .. -* .. END OF CGEJSV -* .. - END -* +*> \brief \b CGEJSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGEJSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, +* M, N, A, LDA, SVA, U, LDU, V, LDV, +* CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* IMPLICIT NONE +* INTEGER INFO, LDA, LDU, LDV, LWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) +* REAL SVA( N ), RWORK( LRWORK ) +* INTEGER IWORK( * ) +* CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEJSV computes the singular value decomposition (SVD) of a complex M-by-N +*> matrix [A], where M >= N. The SVD of [A] is written as +*> +*> [A] = [U] * [SIGMA] * [V]^*, +*> +*> where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N +*> diagonal elements, [U] is an M-by-N (or M-by-M) unitary matrix, and +*> [V] is an N-by-N unitary matrix. The diagonal elements of [SIGMA] are +*> the singular values of [A]. The columns of [U] and [V] are the left and +*> the right singular vectors of [A], respectively. The matrices [U] and [V] +*> are computed and stored in the arrays U and V, respectively. The diagonal +*> of [SIGMA] is computed and stored in the array SVA. +*> \endverbatim +*> +*> Arguments: +*> ========== +*> +*> \param[in] JOBA +*> \verbatim +*> JOBA is CHARACTER*1 +*> Specifies the level of accuracy: +*> = 'C': This option works well (high relative accuracy) if A = B * D, +*> with well-conditioned B and arbitrary diagonal matrix D. +*> The accuracy cannot be spoiled by COLUMN scaling. The +*> accuracy of the computed output depends on the condition of +*> B, and the procedure aims at the best theoretical accuracy. +*> The relative error max_{i=1:N}|d sigma_i| / sigma_i is +*> bounded by f(M,N)*epsilon* cond(B), independent of D. +*> The input matrix is preprocessed with the QRF with column +*> pivoting. This initial preprocessing and preconditioning by +*> a rank revealing QR factorization is common for all values of +*> JOBA. Additional actions are specified as follows: +*> = 'E': Computation as with 'C' with an additional estimate of the +*> condition number of B. It provides a realistic error bound. +*> = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings +*> D1, D2, and well-conditioned matrix C, this option gives +*> higher accuracy than the 'C' option. If the structure of the +*> input matrix is not known, and relative accuracy is +*> desirable, then this option is advisable. The input matrix A +*> is preprocessed with QR factorization with FULL (row and +*> column) pivoting. +*> = 'G' Computation as with 'F' with an additional estimate of the +*> condition number of B, where A=B*D. If A has heavily weighted +*> rows, then using this condition number gives too pessimistic +*> error bound. +*> = 'A': Small singular values are not well determined by the data +*> and are considered as noisy; the matrix is treated as +*> numerically rank defficient. The error in the computed +*> singular values is bounded by f(m,n)*epsilon*||A||. +*> The computed SVD A = U * S * V^* restores A up to +*> f(m,n)*epsilon*||A||. +*> This gives the procedure the licence to discard (set to zero) +*> all singular values below N*epsilon*||A||. +*> = 'R': Similar as in 'A'. Rank revealing property of the initial +*> QR factorization is used do reveal (using triangular factor) +*> a gap sigma_{r+1} < epsilon * sigma_r in which case the +*> numerical RANK is declared to be r. The SVD is computed with +*> absolute error bounds, but more accurately than with 'A'. +*> \endverbatim +*> +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> Specifies whether to compute the columns of U: +*> = 'U': N columns of U are returned in the array U. +*> = 'F': full set of M left sing. vectors is returned in the array U. +*> = 'W': U may be used as workspace of length M*N. See the description +*> of U. +*> = 'N': U is not computed. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether to compute the matrix V: +*> = 'V': N columns of V are returned in the array V; Jacobi rotations +*> are not explicitly accumulated. +*> = 'J': N columns of V are returned in the array V, but they are +*> computed as the product of Jacobi rotations, if JOBT .EQ. 'N'. +*> = 'W': V may be used as workspace of length N*N. See the description +*> of V. +*> = 'N': V is not computed. +*> \endverbatim +*> +*> \param[in] JOBR +*> \verbatim +*> JOBR is CHARACTER*1 +*> Specifies the RANGE for the singular values. Issues the licence to +*> set to zero small positive singular values if they are outside +*> specified range. If A .NE. 0 is scaled so that the largest singular +*> value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues +*> the licence to kill columns of A whose norm in c*A is less than +*> SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, +*> where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). +*> = 'N': Do not kill small columns of c*A. This option assumes that +*> BLAS and QR factorizations and triangular solvers are +*> implemented to work in that range. If the condition of A +*> is greater than BIG, use CGESVJ. +*> = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] +*> (roughly, as described above). This option is recommended. +*> =========================== +*> For computing the singular values in the FULL range [SFMIN,BIG] +*> use CGESVJ. +*> \endverbatim +*> +*> \param[in] JOBT +*> \verbatim +*> JOBT is CHARACTER*1 +*> If the matrix is square then the procedure may determine to use +*> transposed A if A^* seems to be better with respect to convergence. +*> If the matrix is not square, JOBT is ignored. +*> The decision is based on two values of entropy over the adjoint +*> orbit of A^* * A. See the descriptions of WORK(6) and WORK(7). +*> = 'T': transpose if entropy test indicates possibly faster +*> convergence of Jacobi process if A^* is taken as input. If A is +*> replaced with A^*, then the row pivoting is included automatically. +*> = 'N': do not speculate. +*> The option 'T' can be used to compute only the singular values, or +*> the full SVD (U, SIGMA and V). For only one set of singular vectors +*> (U or V), the caller should provide both U and V, as one of the +*> matrices is used as workspace if the matrix A is transposed. +*> The implementer can easily remove this constraint and make the +*> code more complicated. See the descriptions of U and V. +*> In general, this option is considered experimental, and 'N'; should +*> be preferred. This is subject to changes in the future. +*> \endverbatim +*> +*> \param[in] JOBP +*> \verbatim +*> JOBP is CHARACTER*1 +*> Issues the licence to introduce structured perturbations to drown +*> denormalized numbers. This licence should be active if the +*> denormals are poorly implemented, causing slow computation, +*> especially in cases of fast convergence (!). For details see [1,2]. +*> For the sake of simplicity, this perturbations are included only +*> when the full SVD or only the singular values are requested. The +*> implementer/user can easily add the perturbation for the cases of +*> computing one set of singular vectors. +*> = 'P': introduce perturbation +*> = 'N': do not perturb +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] SVA +*> \verbatim +*> SVA is REAL array, dimension (N) +*> On exit, +*> - For WORK(1)/WORK(2) = ONE: The singular values of A. During the +*> computation SVA contains Euclidean column norms of the +*> iterated matrices in the array A. +*> - For WORK(1) .NE. WORK(2): The singular values of A are +*> (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if +*> sigma_max(A) overflows or if small singular values have been +*> saved from underflow by scaling the input matrix A. +*> - If JOBR='R' then some of the singular values may be returned +*> as exact zeros obtained by "set to zero" because they are +*> below the numerical rank threshold or are denormalized numbers. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX array, dimension ( LDU, N ) or ( LDU, M ) +*> If JOBU = 'U', then U contains on exit the M-by-N matrix of +*> the left singular vectors. +*> If JOBU = 'F', then U contains on exit the M-by-M matrix of +*> the left singular vectors, including an ONB +*> of the orthogonal complement of the Range(A). +*> If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), +*> then U is used as workspace if the procedure +*> replaces A with A^*. In that case, [V] is computed +*> in U as left singular vectors of A^* and then +*> copied back to the V array. This 'W' option is just +*> a reminder to the caller that in this case U is +*> reserved as workspace of length N*N. +*> If JOBU = 'N' U is not referenced, unless JOBT='T'. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U, LDU >= 1. +*> IF JOBU = 'U' or 'F' or 'W', then LDU >= M. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX array, dimension ( LDV, N ) +*> If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of +*> the right singular vectors; +*> If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), +*> then V is used as workspace if the pprocedure +*> replaces A with A^*. In that case, [U] is computed +*> in V as right singular vectors of A^* and then +*> copied back to the U array. This 'W' option is just +*> a reminder to the caller that in this case V is +*> reserved as workspace of length N*N. +*> If JOBV = 'N' V is not referenced, unless JOBT='T'. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV >= 1. +*> If JOBV = 'V' or 'J' or 'W', then LDV >= N. +*> \endverbatim +*> +*> \param[out] CWORK +*> \verbatim +*> CWORK is COMPLEX array, dimension (MAX(2,LWORK)) +*> If the call to CGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit CWORK(1) contains the required length of +*> CWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> Length of CWORK to confirm proper allocation of workspace. +*> LWORK depends on the job: +*> +*> 1. If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and +*> 1.1 .. no scaled condition estimate required (JOBA.NE.'E'.AND.JOBA.NE.'G'): +*> LWORK >= 2*N+1. This is the minimal requirement. +*> ->> For optimal performance (blocked code) the optimal value +*> is LWORK >= N + (N+1)*NB. Here NB is the optimal +*> block size for CGEQP3 and CGEQRF. +*> In general, optimal LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CGEQRF), LWORK(CGESVJ)). +*> 1.2. .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). In this case, LWORK the minimal +*> requirement is LWORK >= N*N + 2*N. +*> ->> For optimal performance (blocked code) the optimal value +*> is LWORK >= max(N+(N+1)*NB, N*N+2*N)=N**2+2*N. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CGEQRF), LWORK(CGESVJ), +*> N*N+LWORK(CPOCON)). +*> 2. If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), +*> (JOBU.EQ.'N') +*> 2.1 .. no scaled condition estimate requested (JOBE.EQ.'N'): +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance, +*> LWORK >= max(N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for CGEQP3, CGEQRF, CGELQ, +*> CUNMLQ. In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3), N+LWORK(CGESVJ), +*> N+LWORK(CGELQF), 2*N+LWORK(CGEQRF), N+LWORK(CUNMLQ)). +*> 2.2 .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance, +*> LWORK >= max(N+(N+1)*NB, 2*N,2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for CGEQP3, CGEQRF, CGELQ, +*> CUNMLQ. In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3), LWORK(CPOCON), N+LWORK(CGESVJ), +*> N+LWORK(CGELQF), 2*N+LWORK(CGEQRF), N+LWORK(CUNMLQ)). +*> 3. If SIGMA and the left singular vectors are needed +*> 3.1 .. no scaled condition estimate requested (JOBE.EQ.'N'): +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance: +*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for CGEQP3, CGEQRF, CUNMQR. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3), 2*N+LWORK(CGEQRF), N+LWORK(CUNMQR)). +*> 3.2 .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance: +*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for CGEQP3, CGEQRF, CUNMQR. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(CGEQP3),N+LWORK(CPOCON), +*> 2*N+LWORK(CGEQRF), N+LWORK(CUNMQR)). +*> +*> 4. If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and +*> 4.1. if JOBV.EQ.'V' +*> the minimal requirement is LWORK >= 5*N+2*N*N. +*> 4.2. if JOBV.EQ.'J' the minimal requirement is +*> LWORK >= 4*N+N*N. +*> In both cases, the allocated CWORK can accommodate blocked runs +*> of CGEQP3, CGEQRF, CGELQF, CUNMQR, CUNMLQ. +*> +*> If the call to CGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit CWORK(1) contains the optimal and CWORK(2) contains the +*> minimal length of CWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (MAX(7,LWORK)) +*> On exit, +*> RWORK(1) = Determines the scaling factor SCALE = RWORK(2) / RWORK(1) +*> such that SCALE*SVA(1:N) are the computed singular values +*> of A. (See the description of SVA().) +*> RWORK(2) = See the description of RWORK(1). +*> RWORK(3) = SCONDA is an estimate for the condition number of +*> column equilibrated A. (If JOBA .EQ. 'E' or 'G') +*> SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). +*> It is computed using SPOCON. It holds +*> N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA +*> where R is the triangular factor from the QRF of A. +*> However, if R is truncated and the numerical rank is +*> determined to be strictly smaller than N, SCONDA is +*> returned as -1, thus indicating that the smallest +*> singular values might be lost. +*> +*> If full SVD is needed, the following two condition numbers are +*> useful for the analysis of the algorithm. They are provied for +*> a developer/implementer who is familiar with the details of +*> the method. +*> +*> RWORK(4) = an estimate of the scaled condition number of the +*> triangular factor in the first QR factorization. +*> RWORK(5) = an estimate of the scaled condition number of the +*> triangular factor in the second QR factorization. +*> The following two parameters are computed if JOBT .EQ. 'T'. +*> They are provided for a developer/implementer who is familiar +*> with the details of the method. +*> RWORK(6) = the entropy of A^* * A :: this is the Shannon entropy +*> of diag(A^* * A) / Trace(A^* * A) taken as point in the +*> probability simplex. +*> RWORK(7) = the entropy of A * A^*. (See the description of RWORK(6).) +*> If the call to CGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit RWORK(1) contains the required length of +*> RWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> Length of RWORK to confirm proper allocation of workspace. +*> LRWORK depends on the job: +*> +*> 1. If only the singular values are requested i.e. if +*> LSAME(JOBU,'N') .AND. LSAME(JOBV,'N') +*> then: +*> 1.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then: LRWORK = max( 7, 2 * M ). +*> 1.2. Otherwise, LRWORK = max( 7, N ). +*> 2. If singular values with the right singular vectors are requested +*> i.e. if +*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) .AND. +*> .NOT.(LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) +*> then: +*> 2.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 2.2. Otherwise, LRWORK = max( 7, N ). +*> 3. If singular values with the left singular vectors are requested, i.e. if +*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. +*> .NOT.(LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) +*> then: +*> 3.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 3.2. Otherwise, LRWORK = max( 7, N ). +*> 4. If singular values with both the left and the right singular vectors +*> are requested, i.e. if +*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. +*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) +*> then: +*> 4.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 4.2. Otherwise, LRWORK = max( 7, N ). +*> +*> If, on entry, LRWORK = -1 or LWORK=-1, a workspace query is assumed and +*> the length of RWORK is returned in RWORK(1). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, of dimension at least 4, that further depends +*> on the job: +*> +*> 1. If only the singular values are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 2. If the singular values and the right singular vectors are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 3. If the singular values and the left singular vectors are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 4. If the singular values with both the left and the right singular vectors +*> are requested, then: +*> 4.1. If LSAME(JOBV,'J') the length of IWORK is determined as follows: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 4.2. If LSAME(JOBV,'V') the length of IWORK is determined as follows: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is 2*N+M; otherwise the length of IWORK is 2*N. +*> +*> On exit, +*> IWORK(1) = the numerical rank determined after the initial +*> QR factorization with pivoting. See the descriptions +*> of JOBA and JOBR. +*> IWORK(2) = the number of the computed nonzero singular values +*> IWORK(3) = if nonzero, a warning message: +*> If IWORK(3).EQ.1 then some of the column norms of A +*> were denormalized floats. The requested high accuracy +*> is not warranted by the data. +*> IWORK(4) = 1 or -1. If IWORK(4) .EQ. 1, then the procedure used A^* to +*> do the job as specified by the JOB parameters. +*> If the call to CGEJSV is a workspace query (indicated by LWORK .EQ. -1 and +*> LRWORK .EQ. -1), then on exit IWORK(1) contains the required length of +*> IWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> < 0 : if INFO = -i, then the i-th argument had an illegal value. +*> = 0 : successful exit; +*> > 0 : CGEJSV did not converge in the maximal allowed number +*> of sweeps. The computed values may be inaccurate. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complexGEsing +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> CGEJSV implements a preconditioned Jacobi SVD algorithm. It uses CGEQP3, +*> CGEQRF, and CGELQF as preprocessors and preconditioners. Optionally, an +*> additional row pivoting can be used as a preprocessor, which in some +*> cases results in much higher accuracy. An example is matrix A with the +*> structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned +*> diagonal matrices and C is well-conditioned matrix. In that case, complete +*> pivoting in the first QR factorizations provides accuracy dependent on the +*> condition number of C, and independent of D1, D2. Such higher accuracy is +*> not completely understood theoretically, but it works well in practice. +*> Further, if A can be written as A = B*D, with well-conditioned B and some +*> diagonal D, then the high accuracy is guaranteed, both theoretically and +*> in software, independent of D. For more details see [1], [2]. +*> The computational range for the singular values can be the full range +*> ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS +*> & LAPACK routines called by CGEJSV are implemented to work in that range. +*> If that is not the case, then the restriction for safe computation with +*> the singular values in the range of normalized IEEE numbers is that the +*> spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not +*> overflow. This code (CGEJSV) is best used in this restricted range, +*> meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are +*> returned as zeros. See JOBR for details on this. +*> Further, this implementation is somewhat slower than the one described +*> in [1,2] due to replacement of some non-LAPACK components, and because +*> the choice of some tuning parameters in the iterative part (CGESVJ) is +*> left to the implementer on a particular machine. +*> The rank revealing QR factorization (in this code: CGEQP3) should be +*> implemented as in [3]. We have a new version of CGEQP3 under development +*> that is more robust than the current one in LAPACK, with a cleaner cut in +*> rank deficient cases. It will be available in the SIGMA library [4]. +*> If M is much larger than N, it is obvious that the initial QRF with +*> column pivoting can be preprocessed by the QRF without pivoting. That +*> well known trick is not used in CGEJSV because in some cases heavy row +*> weighting can be treated with complete pivoting. The overhead in cases +*> M much larger than N is then only due to pivoting, but the benefits in +*> terms of accuracy have prevailed. The implementer/user can incorporate +*> this extra QRF step easily. The implementer can also improve data movement +*> (matrix transpose, matrix copy, matrix transposed copy) - this +*> implementation of CGEJSV uses only the simplest, naive data movement. +*> \endverbatim +* +*> \par Contributor: +* ================== +*> +*> Zlatko Drmac (Zagreb, Croatia) +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +*> LAPACK Working note 169. +*> [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +*> LAPACK Working note 170. +*> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR +*> factorization software - a case study. +*> ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. +*> LAPACK Working note 176. +*> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +*> QSVD, (H,K)-SVD computations. +*> Department of Mathematics, University of Zagreb, 2008, 2016. +*> \endverbatim +* +*> \par Bugs, examples and comments: +* ================================= +*> +*> Please report all bugs and send interesting examples and/or comments to +*> drmac@math.hr. Thank you. +*> +* ===================================================================== + SUBROUTINE CGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, + $ M, N, A, LDA, SVA, U, LDU, V, LDV, + $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* +* -- LAPACK computational 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 .. + IMPLICIT NONE + INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) + REAL SVA( N ), RWORK( LRWORK ) + INTEGER IWORK( * ) + CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* =========================================================================== +* +* .. Local Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + COMPLEX CTEMP + REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, + $ CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, + $ SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC + INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING + LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LQUERY, + $ LSVEC, L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, NOSCAL, + $ ROWPIV, RSVEC, TRANSP +* + INTEGER OPTWRK, MINWRK, MINRWRK, MINIWRK + INTEGER LWCON, LWLQF, LWQP3, LWQRF, LWUNMLQ, LWUNMQR, LWUNMQRM, + $ LWSVDJ, LWSVDJV, LRWQP3, LRWCON, LRWSVDJ, IWOFF + INTEGER LWRK_CGELQF, LWRK_CGEQP3, LWRK_CGEQP3N, LWRK_CGEQRF, + $ LWRK_CGESVJ, LWRK_CGESVJV, LWRK_CGESVJU, LWRK_CUNMLQ, + $ LWRK_CUNMQR, LWRK_CUNMQRM +* .. +* .. Local Arrays + COMPLEX CDUMMY(1) + REAL RDUMMY(1) +* +* .. Intrinsic Functions .. + INTRINSIC ABS, CMPLX, CONJG, ALOG, MAX, MIN, REAL, NINT, SQRT +* .. +* .. External Functions .. + REAL SLAMCH, SCNRM2 + INTEGER ISAMAX, ICAMAX + LOGICAL LSAME + EXTERNAL ISAMAX, ICAMAX, LSAME, SLAMCH, SCNRM2 +* .. +* .. External Subroutines .. + EXTERNAL SLASSQ, CCOPY, CGELQF, CGEQP3, CGEQRF, CLACPY, CLAPMR, + $ CLASCL, SLASCL, CLASET, CLASSQ, CLASWP, CUNGQR, CUNMLQ, + $ CUNMQR, CPOCON, SSCAL, CSSCAL, CSWAP, CTRSM, CLACGV, + $ XERBLA +* + EXTERNAL CGESVJ +* .. +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) + JRACC = LSAME( JOBV, 'J' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC + ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) + L2RANK = LSAME( JOBA, 'R' ) + L2ABER = LSAME( JOBA, 'A' ) + ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) + L2TRAN = LSAME( JOBT, 'T' ) .AND. ( M .EQ. N ) + L2KILL = LSAME( JOBR, 'R' ) + DEFR = LSAME( JOBR, 'N' ) + L2PERT = LSAME( JOBP, 'P' ) +* + LQUERY = ( LWORK .EQ. -1 ) .OR. ( LRWORK .EQ. -1 ) +* + IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. + $ ERREST .OR. LSAME( JOBA, 'C' ) )) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. + $ ( LSAME( JOBU, 'W' ) .AND. RSVEC .AND. L2TRAN ) ) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. + $ ( LSAME( JOBV, 'W' ) .AND. LSVEC .AND. L2TRAN ) ) ) THEN + INFO = - 3 + ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN + INFO = - 4 + ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. LSAME(JOBT,'N') ) ) THEN + INFO = - 5 + ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN + INFO = - 6 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 7 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 8 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 10 + ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN + INFO = - 13 + ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN + INFO = - 15 + ELSE +* #:) + INFO = 0 + END IF +* + IF ( INFO .EQ. 0 ) THEN +* .. compute the minimal and the optimal workspace lengths +* [[The expressions for computing the minimal and the optimal +* values of LCWORK, LRWORK are written with a lot of redundancy and +* can be simplified. However, this verbose form is useful for +* maintenance and modifications of the code.]] +* +* .. minimal workspace length for CGEQP3 of an M x N matrix, +* CGEQRF of an N x N matrix, CGELQF of an N x N matrix, +* CUNMLQ for computing N x N matrix, CUNMQR for computing N x N +* matrix, CUNMQR for computing M x N matrix, respectively. + LWQP3 = N+1 + LWQRF = MAX( 1, N ) + LWLQF = MAX( 1, N ) + LWUNMLQ = MAX( 1, N ) + LWUNMQR = MAX( 1, N ) + LWUNMQRM = MAX( 1, M ) +* .. minimal workspace length for CPOCON of an N x N matrix + LWCON = 2 * N +* .. minimal workspace length for CGESVJ of an N x N matrix, +* without and with explicit accumulation of Jacobi rotations + LWSVDJ = MAX( 2 * N, 1 ) + LWSVDJV = MAX( 2 * N, 1 ) +* .. minimal REAL workspace length for CGEQP3, CPOCON, CGESVJ + LRWQP3 = N + LRWCON = N + LRWSVDJ = N + IF ( LQUERY ) THEN + CALL CGEQP3( M, N, A, LDA, IWORK, CDUMMY, CDUMMY, -1, + $ RDUMMY, IERR ) + LWRK_CGEQP3 = CDUMMY(1) + CALL CGEQRF( N, N, A, LDA, CDUMMY, CDUMMY,-1, IERR ) + LWRK_CGEQRF = CDUMMY(1) + CALL CGELQF( N, N, A, LDA, CDUMMY, CDUMMY,-1, IERR ) + LWRK_CGELQF = CDUMMY(1) + END IF + MINWRK = 2 + OPTWRK = 2 + MINIWRK = N + IF ( .NOT. (LSVEC .OR. RSVEC ) ) THEN +* .. minimal and optimal sizes of the complex workspace if +* only the singular values are requested + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N**2+LWCON, N+LWQRF, LWSVDJ ) + ELSE + MINWRK = MAX( N+LWQP3, N+LWQRF, LWSVDJ ) + END IF + IF ( LQUERY ) THEN + CALL CGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, V, + $ LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_CGEQP3, N**2+LWCON, + $ N+LWRK_CGEQRF, LWRK_CGESVJ ) + ELSE + OPTWRK = MAX( N+LWRK_CGEQP3, N+LWRK_CGEQRF, + $ LWRK_CGESVJ ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWCON, LRWSVDJ ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWCON, LRWSVDJ ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE IF ( RSVEC .AND. (.NOT.LSVEC) ) THEN +* .. minimal and optimal sizes of the complex workspace if the +* singular values and the right singular vectors are requested + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, LWCON, LWSVDJ, N+LWLQF, + $ 2*N+LWQRF, N+LWSVDJ, N+LWUNMLQ ) + ELSE + MINWRK = MAX( N+LWQP3, LWSVDJ, N+LWLQF, 2*N+LWQRF, + $ N+LWSVDJ, N+LWUNMLQ ) + END IF + IF ( LQUERY ) THEN + CALL CGESVJ( 'L', 'U', 'N', N,N, U, LDU, SVA, N, A, + $ LDA, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJ = CDUMMY(1) + CALL CUNMLQ( 'L', 'C', N, N, N, A, LDA, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_CUNMLQ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_CGEQP3, LWCON, LWRK_CGESVJ, + $ N+LWRK_CGELQF, 2*N+LWRK_CGEQRF, + $ N+LWRK_CGESVJ, N+LWRK_CUNMLQ ) + ELSE + OPTWRK = MAX( N+LWRK_CGEQP3, LWRK_CGESVJ,N+LWRK_CGELQF, + $ 2*N+LWRK_CGEQRF, N+LWRK_CGESVJ, + $ N+LWRK_CUNMLQ ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE IF ( LSVEC .AND. (.NOT.RSVEC) ) THEN +* .. minimal and optimal sizes of the complex workspace if the +* singular values and the left singular vectors are requested + IF ( ERREST ) THEN + MINWRK = N + MAX( LWQP3,LWCON,N+LWQRF,LWSVDJ,LWUNMQRM ) + ELSE + MINWRK = N + MAX( LWQP3, N+LWQRF, LWSVDJ, LWUNMQRM ) + END IF + IF ( LQUERY ) THEN + CALL CGESVJ( 'L', 'U', 'N', N,N, U, LDU, SVA, N, A, + $ LDA, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJ = CDUMMY(1) + CALL CUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_CUNMQRM = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = N + MAX( LWRK_CGEQP3, LWCON, N+LWRK_CGEQRF, + $ LWRK_CGESVJ, LWRK_CUNMQRM ) + ELSE + OPTWRK = N + MAX( LWRK_CGEQP3, N+LWRK_CGEQRF, + $ LWRK_CGESVJ, LWRK_CUNMQRM ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE +* .. minimal and optimal sizes of the complex workspace if the +* full SVD is requested + IF ( .NOT. JRACC ) THEN + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N+LWCON, 2*N+N**2+LWCON, + $ 2*N+LWQRF, 2*N+LWQP3, + $ 2*N+N**2+N+LWLQF, 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWSVDJ, 2*N+N**2+N+LWSVDJV, + $ 2*N+N**2+N+LWUNMQR,2*N+N**2+N+LWUNMLQ, + $ N+N**2+LWSVDJ, N+LWUNMQRM ) + ELSE + MINWRK = MAX( N+LWQP3, 2*N+N**2+LWCON, + $ 2*N+LWQRF, 2*N+LWQP3, + $ 2*N+N**2+N+LWLQF, 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWSVDJ, 2*N+N**2+N+LWSVDJV, + $ 2*N+N**2+N+LWUNMQR,2*N+N**2+N+LWUNMLQ, + $ N+N**2+LWSVDJ, N+LWUNMQRM ) + END IF + MINIWRK = MINIWRK + N + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N+LWCON, 2*N+LWQRF, + $ 2*N+N**2+LWSVDJV, 2*N+N**2+N+LWUNMQR, + $ N+LWUNMQRM ) + ELSE + MINWRK = MAX( N+LWQP3, 2*N+LWQRF, + $ 2*N+N**2+LWSVDJV, 2*N+N**2+N+LWUNMQR, + $ N+LWUNMQRM ) + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + END IF + IF ( LQUERY ) THEN + CALL CUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_CUNMQRM = CDUMMY(1) + CALL CUNMQR( 'L', 'N', N, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_CUNMQR = CDUMMY(1) + IF ( .NOT. JRACC ) THEN + CALL CGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, -1, + $ RDUMMY, IERR ) + LWRK_CGEQP3N = CDUMMY(1) + CALL CGESVJ( 'L', 'U', 'N', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJ = CDUMMY(1) + CALL CGESVJ( 'U', 'U', 'N', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJU = CDUMMY(1) + CALL CGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJV = CDUMMY(1) + CALL CUNMLQ( 'L', 'C', N, N, N, A, LDA, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_CUNMLQ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_CGEQP3, N+LWCON, + $ 2*N+N**2+LWCON, 2*N+LWRK_CGEQRF, + $ 2*N+LWRK_CGEQP3N, + $ 2*N+N**2+N+LWRK_CGELQF, + $ 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWRK_CGESVJ, + $ 2*N+N**2+N+LWRK_CGESVJV, + $ 2*N+N**2+N+LWRK_CUNMQR, + $ 2*N+N**2+N+LWRK_CUNMLQ, + $ N+N**2+LWRK_CGESVJU, + $ N+LWRK_CUNMQRM ) + ELSE + OPTWRK = MAX( N+LWRK_CGEQP3, + $ 2*N+N**2+LWCON, 2*N+LWRK_CGEQRF, + $ 2*N+LWRK_CGEQP3N, + $ 2*N+N**2+N+LWRK_CGELQF, + $ 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWRK_CGESVJ, + $ 2*N+N**2+N+LWRK_CGESVJV, + $ 2*N+N**2+N+LWRK_CUNMQR, + $ 2*N+N**2+N+LWRK_CUNMLQ, + $ N+N**2+LWRK_CGESVJU, + $ N+LWRK_CUNMQRM ) + END IF + ELSE + CALL CGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_CGESVJV = CDUMMY(1) + CALL CUNMQR( 'L', 'N', N, N, N, CDUMMY, N, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_CUNMQR = CDUMMY(1) + CALL CUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_CUNMQRM = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_CGEQP3, N+LWCON, + $ 2*N+LWRK_CGEQRF, 2*N+N**2, + $ 2*N+N**2+LWRK_CGESVJV, + $ 2*N+N**2+N+LWRK_CUNMQR,N+LWRK_CUNMQRM ) + ELSE + OPTWRK = MAX( N+LWRK_CGEQP3, 2*N+LWRK_CGEQRF, + $ 2*N+N**2, 2*N+N**2+LWRK_CGESVJV, + $ 2*N+N**2+N+LWRK_CUNMQR, + $ N+LWRK_CUNMQRM ) + END IF + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + END IF + END IF + MINWRK = MAX( 2, MINWRK ) + OPTWRK = MAX( 2, OPTWRK ) + IF ( LWORK .LT. MINWRK .AND. (.NOT.LQUERY) ) INFO = - 17 + IF ( LRWORK .LT. MINRWRK .AND. (.NOT.LQUERY) ) INFO = - 19 + END IF +* + IF ( INFO .NE. 0 ) THEN +* #:( + CALL XERBLA( 'CGEJSV', - INFO ) + RETURN + ELSE IF ( LQUERY ) THEN + CWORK(1) = OPTWRK + CWORK(2) = MINWRK + RWORK(1) = MINRWRK + IWORK(1) = MAX( 4, MINIWRK ) + RETURN + END IF +* +* Quick return for void matrix (Y3K safe) +* #:) + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) THEN + IWORK(1:4) = 0 + RWORK(1:7) = 0 + RETURN + ENDIF +* +* Determine whether the matrix U should be M x N or M x M +* + IF ( LSVEC ) THEN + N1 = N + IF ( LSAME( JOBU, 'F' ) ) N1 = M + END IF +* +* Set numerical parameters +* +*! NOTE: Make sure SLAMCH() does not fail on the target architecture. +* + EPSLN = SLAMCH('Epsilon') + SFMIN = SLAMCH('SafeMinimum') + SMALL = SFMIN / EPSLN + BIG = SLAMCH('O') +* BIG = ONE / SFMIN +* +* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N +* +*(!) If necessary, scale SVA() to protect the largest norm from +* overflow. It is possible that this scaling pushes the smallest +* column norm left from the underflow threshold (extreme case). +* + SCALEM = ONE / SQRT(REAL(M)*REAL(N)) + NOSCAL = .TRUE. + GOSCAL = .TRUE. + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ONE + CALL CLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 9 + CALL XERBLA( 'CGEJSV', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCAL = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALEM ) + IF ( GOSCAL ) THEN + GOSCAL = .FALSE. + CALL SSCAL( p-1, SCALEM, SVA, 1 ) + END IF + END IF + 1874 CONTINUE +* + IF ( NOSCAL ) SCALEM = ONE +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + AAPP = MAX( AAPP, SVA(p) ) + IF ( SVA(p) .NE. ZERO ) AAQQ = MIN( AAQQ, SVA(p) ) + 4781 CONTINUE +* +* Quick return for zero M x N matrix +* #:) + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL CLASET( 'G', M, N1, CZERO, CONE, U, LDU ) + IF ( RSVEC ) CALL CLASET( 'G', N, N, CZERO, CONE, V, LDV ) + RWORK(1) = ONE + RWORK(2) = ONE + IF ( ERREST ) RWORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = ONE + RWORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ZERO + RWORK(7) = ZERO + END IF + IWORK(1) = 0 + IWORK(2) = 0 + IWORK(3) = 0 + IWORK(4) = -1 + RETURN + END IF +* +* Issue warning if denormalized column norms detected. Override the +* high relative accuracy request. Issue licence to kill nonzero columns +* (set them to zero) whose norm is less than sigma_max / BIG (roughly). +* #:( + WARNING = 0 + IF ( AAQQ .LE. SFMIN ) THEN + L2RANK = .TRUE. + L2KILL = .TRUE. + WARNING = 1 + END IF +* +* Quick return for one-column matrix +* #:) + IF ( N .EQ. 1 ) THEN +* + IF ( LSVEC ) THEN + CALL CLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) + CALL CLACPY( 'A', M, 1, A, LDA, U, LDU ) +* computing all M left singular vectors of the M x 1 matrix + IF ( N1 .NE. N ) THEN + CALL CGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) + CALL CUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) + CALL CCOPY( M, A(1,1), 1, U(1,1), 1 ) + END IF + END IF + IF ( RSVEC ) THEN + V(1,1) = CONE + END IF + IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + SVA(1) = SVA(1) / SCALEM + SCALEM = ONE + END IF + RWORK(1) = ONE / SCALEM + RWORK(2) = ONE + IF ( SVA(1) .NE. ZERO ) THEN + IWORK(1) = 1 + IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN + IWORK(2) = 1 + ELSE + IWORK(2) = 0 + END IF + ELSE + IWORK(1) = 0 + IWORK(2) = 0 + END IF + IWORK(3) = 0 + IWORK(4) = -1 + IF ( ERREST ) RWORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = ONE + RWORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ZERO + RWORK(7) = ZERO + END IF + RETURN +* + END IF +* + TRANSP = .FALSE. +* + AATMAX = -ONE + AATMIN = BIG + IF ( ROWPIV .OR. L2TRAN ) THEN +* +* Compute the row norms, needed to determine row pivoting sequence +* (in the case of heavily row weighted A, row pivoting is strongly +* advised) and to collect information needed to compare the +* structures of A * A^* and A^* * A (in the case L2TRAN.EQ..TRUE.). +* + IF ( L2TRAN ) THEN + DO 1950 p = 1, M + XSC = ZERO + TEMP1 = ONE + CALL CLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) +* CLASSQ gets both the ell_2 and the ell_infinity norm +* in one pass through the vector + RWORK(M+p) = XSC * SCALEM + RWORK(p) = XSC * (SCALEM*SQRT(TEMP1)) + AATMAX = MAX( AATMAX, RWORK(p) ) + IF (RWORK(p) .NE. ZERO) + $ AATMIN = MIN(AATMIN,RWORK(p)) + 1950 CONTINUE + ELSE + DO 1904 p = 1, M + RWORK(M+p) = SCALEM*ABS( A(p,ICAMAX(N,A(p,1),LDA)) ) + AATMAX = MAX( AATMAX, RWORK(M+p) ) + AATMIN = MIN( AATMIN, RWORK(M+p) ) + 1904 CONTINUE + END IF +* + END IF +* +* For square matrix A try to determine whether A^* would be better +* input for the preconditioned Jacobi SVD, with faster convergence. +* The decision is based on an O(N) function of the vector of column +* and row norms of A, based on the Shannon entropy. This should give +* the right choice in most cases when the difference actually matters. +* It may fail and pick the slower converging side. +* + ENTRA = ZERO + ENTRAT = ZERO + IF ( L2TRAN ) THEN +* + XSC = ZERO + TEMP1 = ONE + CALL SLASSQ( N, SVA, 1, XSC, TEMP1 ) + TEMP1 = ONE / TEMP1 +* + ENTRA = ZERO + DO 1113 p = 1, N + BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1) + 1113 CONTINUE + ENTRA = - ENTRA / ALOG(REAL(N)) +* +* Now, SVA().^2/Trace(A^* * A) is a point in the probability simplex. +* It is derived from the diagonal of A^* * A. Do the same with the +* diagonal of A * A^*, compute the entropy of the corresponding +* probability distribution. Note that A * A^* and A^* * A have the +* same trace. +* + ENTRAT = ZERO + DO 1114 p = 1, M + BIG1 = ( ( RWORK(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1) + 1114 CONTINUE + ENTRAT = - ENTRAT / ALOG(REAL(M)) +* +* Analyze the entropies and decide A or A^*. Smaller entropy +* usually means better input for the algorithm. +* + TRANSP = ( ENTRAT .LT. ENTRA ) +* +* If A^* is better than A, take the adjoint of A. This is allowed +* only for square matrices, M=N. + IF ( TRANSP ) THEN +* In an optimal implementation, this trivial transpose +* should be replaced with faster transpose. + DO 1115 p = 1, N - 1 + A(p,p) = CONJG(A(p,p)) + DO 1116 q = p + 1, N + CTEMP = CONJG(A(q,p)) + A(q,p) = CONJG(A(p,q)) + A(p,q) = CTEMP + 1116 CONTINUE + 1115 CONTINUE + A(N,N) = CONJG(A(N,N)) + DO 1117 p = 1, N + RWORK(M+p) = SVA(p) + SVA(p) = RWORK(p) +* previously computed row 2-norms are now column 2-norms +* of the transposed matrix + 1117 CONTINUE + TEMP1 = AAPP + AAPP = AATMAX + AATMAX = TEMP1 + TEMP1 = AAQQ + AAQQ = AATMIN + AATMIN = TEMP1 + KILL = LSVEC + LSVEC = RSVEC + RSVEC = KILL + IF ( LSVEC ) N1 = N +* + ROWPIV = .TRUE. + END IF +* + END IF +* END IF L2TRAN +* +* Scale the matrix so that its maximal singular value remains less +* than SQRT(BIG) -- the matrix is scaled so that its maximal column +* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep +* SQRT(BIG) instead of BIG is the fact that CGEJSV uses LAPACK and +* BLAS routines that, in some implementations, are not capable of +* working in the full interval [SFMIN,BIG] and that they may provoke +* overflows in the intermediate results. If the singular values spread +* from SFMIN to BIG, then CGESVJ will compute them. So, in that case, +* one should use CGESVJ instead of CGEJSV. + BIG1 = SQRT( BIG ) + TEMP1 = SQRT( BIG / REAL(N) ) +* >> for future updates: allow bigger range, i.e. the largest column +* will be allowed up to BIG/N and CGESVJ will do the rest. However, for +* this all other (LAPACK) components must allow such a range. +* TEMP1 = BIG/REAL(N) +* TEMP1 = BIG * EPSLN this should 'almost' work with current LAPACK components + CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) + IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN + AAQQ = ( AAQQ / AAPP ) * TEMP1 + ELSE + AAQQ = ( AAQQ * TEMP1 ) / AAPP + END IF + TEMP1 = TEMP1 * SCALEM + CALL CLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) +* +* To undo scaling at the end of this procedure, multiply the +* computed singular values with USCAL2 / USCAL1. +* + USCAL1 = TEMP1 + USCAL2 = AAPP +* + IF ( L2KILL ) THEN +* L2KILL enforces computation of nonzero singular values in +* the restricted range of condition number of the initial A, +* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). + XSC = SQRT( SFMIN ) + ELSE + XSC = SMALL +* +* Now, if the condition number of A is too big, +* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, +* as a precaution measure, the full SVD is computed using CGESVJ +* with accumulated Jacobi rotations. This provides numerically +* more robust computation, at the cost of slightly increased run +* time. Depending on the concrete implementation of BLAS and LAPACK +* (i.e. how they behave in presence of extreme ill-conditioning) the +* implementor may decide to remove this switch. + IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN + JRACC = .TRUE. + END IF +* + END IF + IF ( AAQQ .LT. XSC ) THEN + DO 700 p = 1, N + IF ( SVA(p) .LT. XSC ) THEN + CALL CLASET( 'A', M, 1, CZERO, CZERO, A(1,p), LDA ) + SVA(p) = ZERO + END IF + 700 CONTINUE + END IF +* +* Preconditioning using QR factorization with pivoting +* + IF ( ROWPIV ) THEN +* Optional row permutation (Bjoerck row pivoting): +* A result by Cox and Higham shows that the Bjoerck's +* row pivoting combined with standard column pivoting +* has similar effect as Powell-Reid complete pivoting. +* The ell-infinity norms of A are made nonincreasing. + IF ( ( LSVEC .AND. RSVEC ) .AND. .NOT.( JRACC ) ) THEN + IWOFF = 2*N + ELSE + IWOFF = N + END IF + DO 1952 p = 1, M - 1 + q = ISAMAX( M-p+1, RWORK(M+p), 1 ) + p - 1 + IWORK(IWOFF+p) = q + IF ( p .NE. q ) THEN + TEMP1 = RWORK(M+p) + RWORK(M+p) = RWORK(M+q) + RWORK(M+q) = TEMP1 + END IF + 1952 CONTINUE + CALL CLASWP( N, A, LDA, 1, M-1, IWORK(IWOFF+1), 1 ) + END IF +* +* End of the preparation phase (scaling, optional sorting and +* transposing, optional flushing of small columns). +* +* Preconditioning +* +* If the full SVD is needed, the right singular vectors are computed +* from a matrix equation, and for that we need theoretical analysis +* of the Businger-Golub pivoting. So we use CGEQP3 as the first RR QRF. +* In all other cases the first RR QRF can be chosen by other criteria +* (eg speed by replacing global with restricted window pivoting, such +* as in xGEQPX from TOMS # 782). Good results will be obtained using +* xGEQPX with properly (!) chosen numerical parameters. +* Any improvement of CGEQP3 improves overal performance of CGEJSV. +* +* A * P1 = Q1 * [ R1^* 0]^*: + DO 1963 p = 1, N +* .. all columns are free columns + IWORK(p) = 0 + 1963 CONTINUE + CALL CGEQP3( M, N, A, LDA, IWORK, CWORK, CWORK(N+1), LWORK-N, + $ RWORK, IERR ) +* +* The upper triangular matrix R1 from the first QRF is inspected for +* rank deficiency and possibilities for deflation, or possible +* ill-conditioning. Depending on the user specified flag L2RANK, +* the procedure explores possibilities to reduce the numerical +* rank by inspecting the computed upper triangular factor. If +* L2RANK or L2ABER are up, then CGEJSV will compute the SVD of +* A + dA, where ||dA|| <= f(M,N)*EPSLN. +* + NR = 1 + IF ( L2ABER ) THEN +* Standard absolute error bound suffices. All sigma_i with +* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an +* agressive enforcement of lower numerical rank by introducing a +* backward error of the order of N*EPSLN*||A||. + TEMP1 = SQRT(REAL(N))*EPSLN + DO 3001 p = 2, N + IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN + NR = NR + 1 + ELSE + GO TO 3002 + END IF + 3001 CONTINUE + 3002 CONTINUE + ELSE IF ( L2RANK ) THEN +* .. similarly as above, only slightly more gentle (less agressive). +* Sudden drop on the diagonal of R1 is used as the criterion for +* close-to-rank-defficient. + TEMP1 = SQRT(SFMIN) + DO 3401 p = 2, N + IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. + $ ( ABS(A(p,p)) .LT. SMALL ) .OR. + $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 + NR = NR + 1 + 3401 CONTINUE + 3402 CONTINUE +* + ELSE +* The goal is high relative accuracy. However, if the matrix +* has high scaled condition number the relative accuracy is in +* general not feasible. Later on, a condition number estimator +* will be deployed to estimate the scaled condition number. +* Here we just remove the underflowed part of the triangular +* factor. This prevents the situation in which the code is +* working hard to get the accuracy not warranted by the data. + TEMP1 = SQRT(SFMIN) + DO 3301 p = 2, N + IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR. + $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 + NR = NR + 1 + 3301 CONTINUE + 3302 CONTINUE +* + END IF +* + ALMORT = .FALSE. + IF ( NR .EQ. N ) THEN + MAXPRJ = ONE + DO 3051 p = 2, N + TEMP1 = ABS(A(p,p)) / SVA(IWORK(p)) + MAXPRJ = MIN( MAXPRJ, TEMP1 ) + 3051 CONTINUE + IF ( MAXPRJ**2 .GE. ONE - REAL(N)*EPSLN ) ALMORT = .TRUE. + END IF +* +* + SCONDA = - ONE + CONDR1 = - ONE + CONDR2 = - ONE +* + IF ( ERREST ) THEN + IF ( N .EQ. NR ) THEN + IF ( RSVEC ) THEN +* .. V is available as workspace + CALL CLACPY( 'U', N, N, A, LDA, V, LDV ) + DO 3053 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL CSSCAL( p, ONE/TEMP1, V(1,p), 1 ) + 3053 CONTINUE + IF ( LSVEC )THEN + CALL CPOCON( 'U', N, V, LDV, ONE, TEMP1, + $ CWORK(N+1), RWORK, IERR ) + ELSE + CALL CPOCON( 'U', N, V, LDV, ONE, TEMP1, + $ CWORK, RWORK, IERR ) + END IF +* + ELSE IF ( LSVEC ) THEN +* .. U is available as workspace + CALL CLACPY( 'U', N, N, A, LDA, U, LDU ) + DO 3054 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL CSSCAL( p, ONE/TEMP1, U(1,p), 1 ) + 3054 CONTINUE + CALL CPOCON( 'U', N, U, LDU, ONE, TEMP1, + $ CWORK(N+1), RWORK, IERR ) + ELSE + CALL CLACPY( 'U', N, N, A, LDA, CWORK, N ) +*[] CALL CLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) +* Change: here index shifted by N to the left, CWORK(1:N) +* not needed for SIGMA only computation + DO 3052 p = 1, N + TEMP1 = SVA(IWORK(p)) +*[] CALL CSSCAL( p, ONE/TEMP1, CWORK(N+(p-1)*N+1), 1 ) + CALL CSSCAL( p, ONE/TEMP1, CWORK((p-1)*N+1), 1 ) + 3052 CONTINUE +* .. the columns of R are scaled to have unit Euclidean lengths. +*[] CALL CPOCON( 'U', N, CWORK(N+1), N, ONE, TEMP1, +*[] $ CWORK(N+N*N+1), RWORK, IERR ) + CALL CPOCON( 'U', N, CWORK, N, ONE, TEMP1, + $ CWORK(N*N+1), RWORK, IERR ) +* + END IF + IF ( TEMP1 .NE. ZERO ) THEN + SCONDA = ONE / SQRT(TEMP1) + ELSE + SCONDA = - ONE + END IF +* SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA + ELSE + SCONDA = - ONE + END IF + END IF +* + L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) ) +* If there is no violent scaling, artificial perturbation is not needed. +* +* Phase 3: +* + IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN +* +* Singular Values only +* +* .. transpose A(1:NR,1:N) + DO 1946 p = 1, MIN( N-1, NR ) + CALL CCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) + CALL CLACGV( N-p+1, A(p,p), 1 ) + 1946 CONTINUE + IF ( NR .EQ. N ) A(N,N) = CONJG(A(N,N)) +* +* The following two DO-loops introduce small relative perturbation +* into the strict upper triangle of the lower triangular matrix. +* Small entries below the main diagonal are also changed. +* This modification is useful if the computing environment does not +* provide/allow FLUSH TO ZERO underflow, for it prevents many +* annoying denormalized numbers in case of strongly scaled matrices. +* The perturbation is structured so that it does not introduce any +* new perturbation of the singular values, and it does not destroy +* the job done by the preconditioner. +* The licence for this perturbation is in the variable L2PERT, which +* should be .FALSE. if FLUSH TO ZERO underflow is active. +* + IF ( .NOT. ALMORT ) THEN +* + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / REAL(N) + DO 4947 q = 1, NR + CTEMP = CMPLX(XSC*ABS(A(q,q)),ZERO) + DO 4949 p = 1, N + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + $ .OR. ( p .LT. q ) ) +* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) + $ A(p,q) = CTEMP + 4949 CONTINUE + 4947 CONTINUE + ELSE + CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, A(1,2),LDA ) + END IF +* +* .. second preconditioning using the QR factorization +* + CALL CGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) +* +* .. and transpose upper to lower triangular + DO 1948 p = 1, NR - 1 + CALL CCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) + CALL CLACGV( NR-p+1, A(p,p), 1 ) + 1948 CONTINUE +* + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* +* .. again some perturbation (a "background noise") is added +* to drown denormals + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / REAL(N) + DO 1947 q = 1, NR + CTEMP = CMPLX(XSC*ABS(A(q,q)),ZERO) + DO 1949 p = 1, NR + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + $ .OR. ( p .LT. q ) ) +* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) + $ A(p,q) = CTEMP + 1949 CONTINUE + 1947 CONTINUE + ELSE + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) + END IF +* +* .. and one-sided Jacobi rotations are started on a lower +* triangular matrix (plus perturbation which is ignored in +* the part which destroys triangular form (confusing?!)) +* + CALL CGESVJ( 'L', 'N', 'N', NR, NR, A, LDA, SVA, + $ N, V, LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) +* + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) +* +* + ELSE IF ( ( RSVEC .AND. ( .NOT. LSVEC ) .AND. ( .NOT. JRACC ) ) + $ .OR. + $ ( JRACC .AND. ( .NOT. LSVEC ) .AND. ( NR .NE. N ) ) ) THEN +* +* -> Singular Values and Right Singular Vectors <- +* + IF ( ALMORT ) THEN +* +* .. in this case NR equals N + DO 1998 p = 1, NR + CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL CLACGV( N-p+1, V(p,p), 1 ) + 1998 CONTINUE + CALL CLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) +* + CALL CGESVJ( 'L','U','N', N, NR, V, LDV, SVA, NR, A, LDA, + $ CWORK, LWORK, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + + ELSE +* +* .. two more QR factorizations ( one QRF is not enough, two require +* accumulated product of Jacobi rotations, three are perfect ) +* + CALL CLASET( 'L', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) + CALL CGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) + CALL CLACPY( 'L', NR, NR, A, LDA, V, LDV ) + CALL CLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) + CALL CGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) + DO 8998 p = 1, NR + CALL CCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) + CALL CLACGV( NR-p+1, V(p,p), 1 ) + 8998 CONTINUE + CALL CLASET('U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV) +* + CALL CGESVJ( 'L', 'U','N', NR, NR, V,LDV, SVA, NR, U, + $ LDU, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + IF ( NR .LT. N ) THEN + CALL CLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) + CALL CLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) + CALL CLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) + END IF +* + CALL CUNMLQ( 'L', 'C', N, N, NR, A, LDA, CWORK, + $ V, LDV, CWORK(N+1), LWORK-N, IERR ) +* + END IF +* .. permute the rows of V +* DO 8991 p = 1, N +* CALL CCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) +* 8991 CONTINUE +* CALL CLACPY( 'All', N, N, A, LDA, V, LDV ) + CALL CLAPMR( .FALSE., N, N, V, LDV, IWORK ) +* + IF ( TRANSP ) THEN + CALL CLACPY( 'A', N, N, V, LDV, U, LDU ) + END IF +* + ELSE IF ( JRACC .AND. (.NOT. LSVEC) .AND. ( NR.EQ. N ) ) THEN +* + CALL CLASET( 'L', N-1,N-1, CZERO, CZERO, A(2,1), LDA ) +* + CALL CGESVJ( 'U','N','V', N, N, A, LDA, SVA, N, V, LDV, + $ CWORK, LWORK, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + CALL CLAPMR( .FALSE., N, N, V, LDV, IWORK ) +* + ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN +* +* .. Singular Values and Left Singular Vectors .. +* +* .. second preconditioning step to avoid need to accumulate +* Jacobi rotations in the Jacobi iterations. + DO 1965 p = 1, NR + CALL CCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) + CALL CLACGV( N-p+1, U(p,p), 1 ) + 1965 CONTINUE + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) +* + CALL CGEQRF( N, NR, U, LDU, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) +* + DO 1967 p = 1, NR - 1 + CALL CCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) + CALL CLACGV( N-p+1, U(p,p), 1 ) + 1967 CONTINUE + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) +* + CALL CGESVJ( 'L', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, + $ LDA, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) +* + IF ( NR .LT. M ) THEN + CALL CLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL CLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) + CALL CLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) + END IF + END IF +* + CALL CUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + DO 1974 p = 1, N1 + XSC = ONE / SCNRM2( M, U(1,p), 1 ) + CALL CSSCAL( M, XSC, U(1,p), 1 ) + 1974 CONTINUE +* + IF ( TRANSP ) THEN + CALL CLACPY( 'A', N, N, U, LDU, V, LDV ) + END IF +* + ELSE +* +* .. Full SVD .. +* + IF ( .NOT. JRACC ) THEN +* + IF ( .NOT. ALMORT ) THEN +* +* Second Preconditioning Step (QRF [with pivoting]) +* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is +* equivalent to an LQF CALL. Since in many libraries the QRF +* seems to be better optimized than the LQF, we do explicit +* transpose and use the QRF. This is subject to changes in an +* optimized implementation of CGEJSV. +* + DO 1968 p = 1, NR + CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL CLACGV( N-p+1, V(p,p), 1 ) + 1968 CONTINUE +* +* .. the following two loops perturb small entries to avoid +* denormals in the second QR factorization, where they are +* as good as zeros. This is done to avoid painfully slow +* computation with denormals. The relative size of the perturbation +* is a parameter that can be changed by the implementer. +* This perturbation device will be obsolete on machines with +* properly implemented arithmetic. +* To switch it off, set L2PERT=.FALSE. To remove it from the +* code, remove the action under L2PERT=.TRUE., leave the ELSE part. +* The following two loops should be blocked and fused with the +* transposed copy above. +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 2969 q = 1, NR + CTEMP = CMPLX(XSC*ABS( V(q,q) ),ZERO) + DO 2968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + $ .OR. ( p .LT. q ) ) +* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) + $ V(p,q) = CTEMP + IF ( p .LT. q ) V(p,q) = - V(p,q) + 2968 CONTINUE + 2969 CONTINUE + ELSE + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + END IF +* +* Estimate the row scaled condition number of R1 +* (If R1 is rectangular, N > NR, then the condition number +* of the leading NR x NR submatrix is estimated.) +* + CALL CLACPY( 'L', NR, NR, V, LDV, CWORK(2*N+1), NR ) + DO 3950 p = 1, NR + TEMP1 = SCNRM2(NR-p+1,CWORK(2*N+(p-1)*NR+p),1) + CALL CSSCAL(NR-p+1,ONE/TEMP1,CWORK(2*N+(p-1)*NR+p),1) + 3950 CONTINUE + CALL CPOCON('L',NR,CWORK(2*N+1),NR,ONE,TEMP1, + $ CWORK(2*N+NR*NR+1),RWORK,IERR) + CONDR1 = ONE / SQRT(TEMP1) +* .. here need a second oppinion on the condition number +* .. then assume worst case scenario +* R1 is OK for inverse <=> CONDR1 .LT. REAL(N) +* more conservative <=> CONDR1 .LT. SQRT(REAL(N)) +* + COND_OK = SQRT(SQRT(REAL(NR))) +*[TP] COND_OK is a tuning parameter. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* .. the second QRF without pivoting. Note: in an optimized +* implementation, this QRF should be implemented as the QRF +* of a lower triangular matrix. +* R1^* = Q2 * R2 + CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL)/EPSLN + DO 3959 p = 2, NR + DO 3958 q = 1, p - 1 + CTEMP=CMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) + IF ( ABS(V(q,p)) .LE. TEMP1 ) +* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) + $ V(q,p) = CTEMP + 3958 CONTINUE + 3959 CONTINUE + END IF +* + IF ( NR .NE. N ) + $ CALL CLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) +* .. save ... +* +* .. this transposed copy should be better than naive + DO 1969 p = 1, NR - 1 + CALL CCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) + CALL CLACGV(NR-p+1, V(p,p), 1 ) + 1969 CONTINUE + V(NR,NR)=CONJG(V(NR,NR)) +* + CONDR2 = CONDR1 +* + ELSE +* +* .. ill-conditioned case: second QRF with pivoting +* Note that windowed pivoting would be equaly good +* numerically, and more run-time efficient. So, in +* an optimal implementation, the next call to CGEQP3 +* should be replaced with eg. CALL CGEQPX (ACM TOMS #782) +* with properly (carefully) chosen parameters. +* +* R1^* * P2 = Q2 * R2 + DO 3003 p = 1, NR + IWORK(N+p) = 0 + 3003 CONTINUE + CALL CGEQP3( N, NR, V, LDV, IWORK(N+1), CWORK(N+1), + $ CWORK(2*N+1), LWORK-2*N, RWORK, IERR ) +** CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), +** $ LWORK-2*N, IERR ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 3969 p = 2, NR + DO 3968 q = 1, p - 1 + CTEMP=CMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) + IF ( ABS(V(q,p)) .LE. TEMP1 ) +* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) + $ V(q,p) = CTEMP + 3968 CONTINUE + 3969 CONTINUE + END IF +* + CALL CLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 8970 p = 2, NR + DO 8971 q = 1, p - 1 + CTEMP=CMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) +* V(p,q) = - TEMP1*( V(q,p) / ABS(V(q,p)) ) + V(p,q) = - CTEMP + 8971 CONTINUE + 8970 CONTINUE + ELSE + CALL CLASET( 'L',NR-1,NR-1,CZERO,CZERO,V(2,1),LDV ) + END IF +* Now, compute R2 = L3 * Q3, the LQ factorization. + CALL CGELQF( NR, NR, V, LDV, CWORK(2*N+N*NR+1), + $ CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) +* .. and estimate the condition number + CALL CLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) + DO 4950 p = 1, NR + TEMP1 = SCNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) + CALL CSSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) + 4950 CONTINUE + CALL CPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, + $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) + CONDR2 = ONE / SQRT(TEMP1) +* +* + IF ( CONDR2 .GE. COND_OK ) THEN +* .. save the Householder vectors used for Q3 +* (this overwrittes the copy of R2, as it will not be +* needed in this branch, but it does not overwritte the +* Huseholder vectors of Q2.). + CALL CLACPY( 'U', NR, NR, V, LDV, CWORK(2*N+1), N ) +* .. and the rest of the information on Q3 is in +* WORK(2*N+N*NR+1:2*N+N*NR+N) + END IF +* + END IF +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 4968 q = 2, NR + CTEMP = XSC * V(q,q) + DO 4969 p = 1, q - 1 +* V(p,q) = - TEMP1*( V(p,q) / ABS(V(p,q)) ) + V(p,q) = - CTEMP + 4969 CONTINUE + 4968 CONTINUE + ELSE + CALL CLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) + END IF +* +* Second preconditioning finished; continue with Jacobi SVD +* The input matrix is lower trinagular. +* +* Recover the right singular vectors as solution of a well +* conditioned triangular matrix equation. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* + CALL CGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, LDU, + $ CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,RWORK, + $ LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 3970 p = 1, NR + CALL CCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL CSSCAL( NR, SVA(p), V(1,p), 1 ) + 3970 CONTINUE + +* .. pick the right matrix equation and solve it +* + IF ( NR .EQ. N ) THEN +* :)) .. best case, R1 is inverted. The solution of this matrix +* equation is Q2*V2 = the product of the Jacobi rotations +* used in CGESVJ, premultiplied with the orthogonal matrix +* from the second QR factorization. + CALL CTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) + ELSE +* .. R1 is well conditioned, but non-square. Adjoint of R2 +* is inverted to get the product of the Jacobi rotations +* used in CGESVJ. The Q-factor from the second QR +* factorization is then built in explicitly. + CALL CTRSM('L','U','C','N',NR,NR,CONE,CWORK(2*N+1), + $ N,V,LDV) + IF ( NR .LT. N ) THEN + CALL CLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV) + CALL CLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL CUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) + END IF +* + ELSE IF ( CONDR2 .LT. COND_OK ) THEN +* +* The matrix R2 is inverted. The solution of the matrix equation +* is Q3^* * V3 = the product of the Jacobi rotations (appplied to +* the lower triangular L3 from the LQ factorization of +* R2=L3*Q3), pre-multiplied with the transposed Q3. + CALL CGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 3870 p = 1, NR + CALL CCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL CSSCAL( NR, SVA(p), U(1,p), 1 ) + 3870 CONTINUE + CALL CTRSM('L','U','N','N',NR,NR,CONE,CWORK(2*N+1),N, + $ U,LDU) +* .. apply the permutation from the second QR factorization + DO 873 q = 1, NR + DO 872 p = 1, NR + CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 872 CONTINUE + DO 874 p = 1, NR + U(p,q) = CWORK(2*N+N*NR+NR+p) + 874 CONTINUE + 873 CONTINUE + IF ( NR .LT. N ) THEN + CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) + ELSE +* Last line of defense. +* #:( This is a rather pathological case: no scaled condition +* improvement after two pivoted QR factorizations. Other +* possibility is that the rank revealing QR factorization +* or the condition estimator has failed, or the COND_OK +* is set very close to ONE (which is unnecessary). Normally, +* this branch should never be executed, but in rare cases of +* failure of the RRQR or condition estimator, the last line of +* defense ensures that CGEJSV completes the task. +* Compute the full SVD of L3 using CGESVJ with explicit +* accumulation of Jacobi rotations. + CALL CGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + IF ( NR .LT. N ) THEN + CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL CLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* + CALL CUNMLQ( 'L', 'C', NR, NR, NR, CWORK(2*N+1), N, + $ CWORK(2*N+N*NR+1), U, LDU, CWORK(2*N+N*NR+NR+1), + $ LWORK-2*N-N*NR-NR, IERR ) + DO 773 q = 1, NR + DO 772 p = 1, NR + CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 772 CONTINUE + DO 774 p = 1, NR + U(p,q) = CWORK(2*N+N*NR+NR+p) + 774 CONTINUE + 773 CONTINUE +* + END IF +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(REAL(N)) * EPSLN + DO 1972 q = 1, N + DO 972 p = 1, N + CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 972 CONTINUE + DO 973 p = 1, N + V(p,q) = CWORK(2*N+N*NR+NR+p) + 973 CONTINUE + XSC = ONE / SCNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL CSSCAL( N, XSC, V(1,q), 1 ) + 1972 CONTINUE +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). + IF ( NR .LT. M ) THEN + CALL CLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) + IF ( NR .LT. N1 ) THEN + CALL CLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) + CALL CLASET('A',M-NR,N1-NR,CZERO,CONE, + $ U(NR+1,NR+1),LDU) + END IF + END IF +* +* The Q matrix from the first QRF is built into the left singular +* matrix U. This applies to all cases. +* + CALL CUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) + +* The columns of U are normalized. The cost is O(M*N) flops. + TEMP1 = SQRT(REAL(M)) * EPSLN + DO 1973 p = 1, NR + XSC = ONE / SCNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL CSSCAL( M, XSC, U(1,p), 1 ) + 1973 CONTINUE +* +* If the initial QRF is computed with row pivoting, the left +* singular vectors must be adjusted. +* + IF ( ROWPIV ) + $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + ELSE +* +* .. the initial matrix A has almost orthogonal columns and +* the second QRF is not needed +* + CALL CLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 5970 p = 2, N + CTEMP = XSC * CWORK( N + (p-1)*N + p ) + DO 5971 q = 1, p - 1 +* CWORK(N+(q-1)*N+p)=-TEMP1 * ( CWORK(N+(p-1)*N+q) / +* $ ABS(CWORK(N+(p-1)*N+q)) ) + CWORK(N+(q-1)*N+p)=-CTEMP + 5971 CONTINUE + 5970 CONTINUE + ELSE + CALL CLASET( 'L',N-1,N-1,CZERO,CZERO,CWORK(N+2),N ) + END IF +* + CALL CGESVJ( 'U', 'U', 'N', N, N, CWORK(N+1), N, SVA, + $ N, U, LDU, CWORK(N+N*N+1), LWORK-N-N*N, RWORK, LRWORK, + $ INFO ) +* + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 6970 p = 1, N + CALL CCOPY( N, CWORK(N+(p-1)*N+1), 1, U(1,p), 1 ) + CALL CSSCAL( N, SVA(p), CWORK(N+(p-1)*N+1), 1 ) + 6970 CONTINUE +* + CALL CTRSM( 'L', 'U', 'N', 'N', N, N, + $ CONE, A, LDA, CWORK(N+1), N ) + DO 6972 p = 1, N + CALL CCOPY( N, CWORK(N+p), N, V(IWORK(p),1), LDV ) + 6972 CONTINUE + TEMP1 = SQRT(REAL(N))*EPSLN + DO 6971 p = 1, N + XSC = ONE / SCNRM2( N, V(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL CSSCAL( N, XSC, V(1,p), 1 ) + 6971 CONTINUE +* +* Assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL CLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL CLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) + CALL CLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) + END IF + END IF + CALL CUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) + TEMP1 = SQRT(REAL(M))*EPSLN + DO 6973 p = 1, N1 + XSC = ONE / SCNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL CSSCAL( M, XSC, U(1,p), 1 ) + 6973 CONTINUE +* + IF ( ROWPIV ) + $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + END IF +* +* end of the >> almost orthogonal case << in the full SVD +* + ELSE +* +* This branch deploys a preconditioned Jacobi SVD with explicitly +* accumulated rotations. It is included as optional, mainly for +* experimental purposes. It does perfom well, and can also be used. +* In this implementation, this branch will be automatically activated +* if the condition number sigma_max(A) / sigma_min(A) is predicted +* to be greater than the overflow threshold. This is because the +* a posteriori computation of the singular vectors assumes robust +* implementation of BLAS and some LAPACK procedures, capable of working +* in presence of extreme values, e.g. when the singular values spread from +* the underflow to the overflow threshold. +* + DO 7968 p = 1, NR + CALL CCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL CLACGV( N-p+1, V(p,p), 1 ) + 7968 CONTINUE +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 5969 q = 1, NR + CTEMP = CMPLX(XSC*ABS( V(q,q) ),ZERO) + DO 5968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + $ .OR. ( p .LT. q ) ) +* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) + $ V(p,q) = CTEMP + IF ( p .LT. q ) V(p,q) = - V(p,q) + 5968 CONTINUE + 5969 CONTINUE + ELSE + CALL CLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + END IF + + CALL CGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) + CALL CLACPY( 'L', N, NR, V, LDV, CWORK(2*N+1), N ) +* + DO 7969 p = 1, NR + CALL CCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) + CALL CLACGV( NR-p+1, U(p,p), 1 ) + 7969 CONTINUE + + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 9970 q = 2, NR + DO 9971 p = 1, q - 1 + CTEMP = CMPLX(XSC * MIN(ABS(U(p,p)),ABS(U(q,q))), + $ ZERO) +* U(p,q) = - TEMP1 * ( U(q,p) / ABS(U(q,p)) ) + U(p,q) = - CTEMP + 9971 CONTINUE + 9970 CONTINUE + ELSE + CALL CLASET('U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) + END IF + + CALL CGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA, + $ N, V, LDV, CWORK(2*N+N*NR+1), LWORK-2*N-N*NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + + IF ( NR .LT. N ) THEN + CALL CLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL CLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL CLASET( 'A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV ) + END IF + + CALL CUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(REAL(N)) * EPSLN + DO 7972 q = 1, N + DO 8972 p = 1, N + CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 8972 CONTINUE + DO 8973 p = 1, N + V(p,q) = CWORK(2*N+N*NR+NR+p) + 8973 CONTINUE + XSC = ONE / SCNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL CSSCAL( N, XSC, V(1,q), 1 ) + 7972 CONTINUE +* +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). +* + IF ( NR .LT. M ) THEN + CALL CLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL CLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) + CALL CLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) + END IF + END IF +* + CALL CUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + $ CALL CLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* +* + END IF + IF ( TRANSP ) THEN +* .. swap U and V because the procedure worked on A^* + DO 6974 p = 1, N + CALL CSWAP( N, U(1,p), 1, V(1,p), 1 ) + 6974 CONTINUE + END IF +* + END IF +* end of the full SVD +* +* Undo scaling, if necessary (and possible) +* + IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN + CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + USCAL1 = ONE + USCAL2 = ONE + END IF +* + IF ( NR .LT. N ) THEN + DO 3004 p = NR+1, N + SVA(p) = ZERO + 3004 CONTINUE + END IF +* + RWORK(1) = USCAL2 * SCALEM + RWORK(2) = USCAL1 + IF ( ERREST ) RWORK(3) = SCONDA + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = CONDR1 + RWORK(5) = CONDR2 + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ENTRA + RWORK(7) = ENTRAT + END IF +* + IWORK(1) = NR + IWORK(2) = NUMRANK + IWORK(3) = WARNING + IF ( TRANSP ) THEN + IWORK(4) = 1 + ELSE + IWORK(4) = -1 + END IF + +* + RETURN +* .. +* .. END OF CGEJSV +* .. + END +* diff --git a/lapack-netlib/SRC/cgelq.f b/lapack-netlib/SRC/cgelq.f new file mode 100644 index 0000000000..909162ebc1 --- /dev/null +++ b/lapack-netlib/SRC/cgelq.f @@ -0,0 +1,306 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CGELQ computes a LQ factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-min(M,N) lower trapezoidal matrix L +*> (L is lower triangular if M <= N); +*> the elements above the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any LQ factorization algorithm they wish. The triangular +*> (trapezoidal) L has to be stored in the lower part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> CLASWLQ or CGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, CGELQ will use either +*> CLASWLQ (if the matrix is short-and-wide) or CGELQT to compute +*> the LQ factorization. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGELQT, CLASWLQ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'CGELQ ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'CGELQ ', ' ', M, N, 2, -1 ) + ELSE + MB = 1 + NB = N + END IF + IF( MB.GT.MIN( M, N ) .OR. MB.LT.1 ) MB = 1 + IF( NB.GT.N .OR. NB.LE.M ) NB = N + MINTSZ = M + 5 + IF( NB.GT.M .AND. N.GT.M ) THEN + IF( MOD( N - M, NB - M ).EQ.0 ) THEN + NBLCKS = ( N - M ) / ( NB - M ) + ELSE + NBLCKS = ( N - M ) / ( NB - M ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) .OR. LWORK.LT.MB*M ) + $ .AND. ( LWORK.GE.M ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + MB = 1 + NB = N + END IF + IF( LWORK.LT.MB*M ) THEN + LMINWS = .TRUE. + MB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, M*MB ) ) .AND .( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = MB*M*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, MB*M ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGELQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF( ( N.LE.M ) .OR. ( NB.LE.M ) .OR. ( NB.GE.N ) ) THEN + CALL CGELQT( M, N, MB, A, LDA, T( 6 ), MB, WORK, INFO ) + ELSE + CALL CLASWLQ( M, N, MB, NB, A, LDA, T( 6 ), MB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, MB*M ) +* + RETURN +* +* End of CGELQ +* + END diff --git a/lapack-netlib/SRC/cgelq2.f b/lapack-netlib/SRC/cgelq2.f index 507b8824f4..9742d359b3 100644 --- a/lapack-netlib/SRC/cgelq2.f +++ b/lapack-netlib/SRC/cgelq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgelqf.f b/lapack-netlib/SRC/cgelqf.f index 2b05b79f7a..216630e88e 100644 --- a/lapack-netlib/SRC/cgelqf.f +++ b/lapack-netlib/SRC/cgelqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgelqt.f b/lapack-netlib/SRC/cgelqt.f new file mode 100644 index 0000000000..5bead5355e --- /dev/null +++ b/lapack-netlib/SRC/cgelqt.f @@ -0,0 +1,194 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGELQT computes a blocked LQ factorization of a complex M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is +*> lower triangular if M <= N); the elements above the diagonal +*> are the rows of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K +* .. +* .. External Subroutines .. + EXTERNAL CGELQT3, CLARFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. (MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ))THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGELQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, MB + IB = MIN( K-I+1, MB ) +* +* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) +* + CALL CGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO ) + IF( I+IB.LE.M ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the right +* + CALL CLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, WORK , M-I-IB+1 ) + END IF + END DO + RETURN +* +* End of CGELQT +* + END diff --git a/lapack-netlib/SRC/cgelqt3.f b/lapack-netlib/SRC/cgelqt3.f new file mode 100644 index 0000000000..751cb61325 --- /dev/null +++ b/lapack-netlib/SRC/cgelqt3.f @@ -0,0 +1,244 @@ +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE CGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGELQT3 recursively computes a LQ factorization of a complex M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M =< N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> below the diagonal contain the N-by-N lower triangular matrix L; the +*> elements above the diagonal are the rows of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE CGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = (1.0E+00,0.0E+00) ) + PARAMETER ( ZERO = (0.0E+00,0.0E+00)) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, M1, M2, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL CLARFG, CTRMM, CGEMM, XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( N .LT. M ) THEN + INFO = -2 + ELSE IF( LDA .LT. MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LDT .LT. MAX( 1, M ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGELQT3', -INFO ) + RETURN + END IF +* + IF( M.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL CLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T ) + T(1,1)=CONJG(T(1,1)) +* + ELSE +* +* Otherwise, split A into blocks... +* + M1 = M/2 + M2 = M-M1 + I1 = MIN( M1+1, M ) + J1 = MIN( M+1, N ) +* +* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL CGELQT3( M1, N, A, LDA, T, LDT, IINFO ) +* +* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)] +* + DO I=1,M2 + DO J=1,M1 + T( I+M1, J ) = A( I+M1, J ) + END DO + END DO + CALL CTRMM( 'R', 'U', 'C', 'U', M2, M1, ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + CALL CGEMM( 'N', 'C', M2, M1, N-M1, ONE, A( I1, I1 ), LDA, + & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT) +* + CALL CTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE, + & T, LDT, T( I1, 1 ), LDT ) +* + CALL CGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT, + & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA ) +* + CALL CTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + DO I=1,M2 + DO J=1,M1 + A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J ) + T( I+M1, J )= ZERO + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL CGELQT3( M2, N-M1, A( I1, I1 ), LDA, + & T( I1, I1 ), LDT, IINFO ) +* +* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,M2 + DO J=1,M1 + T( J, I+M1 ) = (A( J, I+M1 )) + END DO + END DO +* + CALL CTRMM( 'R', 'U', 'C', 'U', M1, M2, ONE, + & A( I1, I1 ), LDA, T( 1, I1 ), LDT ) +* + CALL CGEMM( 'N', 'C', M1, M2, N-M, ONE, A( 1, J1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT ) +* + CALL CTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT, + & T( 1, I1 ), LDT ) +* + CALL CTRMM( 'R', 'U', 'N', 'N', M1, M2, ONE, + & T( I1, I1 ), LDT, T( 1, I1 ), LDT ) +* +* +* +* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] +* [ A(1:N1,J1:N) L2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of CGELQT3 +* + END diff --git a/lapack-netlib/SRC/cgels.f b/lapack-netlib/SRC/cgels.f index 8732953926..dbef9fa365 100644 --- a/lapack-netlib/SRC/cgels.f +++ b/lapack-netlib/SRC/cgels.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,7 +49,7 @@ *> an underdetermined system A * X = B. *> *> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of -*> an undetermined system A**H * X = B. +*> an underdetermined system A**H * X = B. *> *> 4. If TRANS = 'C' and m < n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEsolve * @@ -182,10 +182,10 @@ SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -380,7 +380,7 @@ SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * ELSE * -* Overdetermined system of equations A**H * X = B +* Underdetermined system of equations A**T * X = B * * B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS) * diff --git a/lapack-netlib/SRC/cgelsd.f b/lapack-netlib/SRC/cgelsd.f index 38da3093cd..2c29c3d59e 100644 --- a/lapack-netlib/SRC/cgelsd.f +++ b/lapack-netlib/SRC/cgelsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -30,7 +30,7 @@ * REAL RWORK( * ), S( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,10 +50,10 @@ *> *> The problem is solved in three steps: *> (1) Reduce the coefficient matrix A to bidiagonal form with -*> Householder tranformations, reducing the original problem +*> Householder transformations, reducing the original problem *> into a "bidiagonal least squares problem" (BLS) *> (2) Solve the BLS using a divide and conquer approach. -*> (3) Apply back all the Householder tranformations to solve +*> (3) Apply back all the Householder transformations to solve *> the original least squares problem. *> *> The effective rank of A is determined by treating as zero those @@ -205,12 +205,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEsolve * @@ -225,10 +225,10 @@ SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/cgelss.f b/lapack-netlib/SRC/cgelss.f index 2d09053582..84faa29bc3 100644 --- a/lapack-netlib/SRC/cgelss.f +++ b/lapack-netlib/SRC/cgelss.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELSS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -29,7 +29,7 @@ * REAL RWORK( * ), S( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexGEsolve * @@ -178,10 +178,10 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -285,8 +285,8 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * Path 1 - overdetermined or exactly determined * * Compute space needed for CGEBRD - CALL CGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL CGEBRD( MM, N, A, LDA, S, S, DUM(1), DUM(1), DUM(1), + $ -1, INFO ) LWORK_CGEBRD=DUM(1) * Compute space needed for CUNMBR CALL CUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, DUM(1), @@ -296,7 +296,7 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL CUNGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_CUNGBR=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = MAX( MAXWRK, 2*N + LWORK_CGEBRD ) MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR ) MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR ) @@ -315,11 +315,11 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ -1, INFO ) LWORK_CGELQF=DUM(1) * Compute space needed for CGEBRD - CALL CGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL CGEBRD( M, M, A, LDA, S, S, DUM(1), DUM(1), + $ DUM(1), -1, INFO ) LWORK_CGEBRD=DUM(1) * Compute space needed for CUNMBR - CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, + CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_CUNMBR=DUM(1) * Compute space needed for CUNGBR @@ -330,7 +330,7 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL CUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_CUNMLQ=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = M + LWORK_CGELQF MAXWRK = MAX( MAXWRK, 3*M + M*M + LWORK_CGEBRD ) MAXWRK = MAX( MAXWRK, 3*M + M*M + LWORK_CUNMBR ) @@ -346,11 +346,11 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * Path 2 - underdetermined * * Compute space needed for CGEBRD - CALL CGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL CGEBRD( M, N, A, LDA, S, S, DUM(1), DUM(1), + $ DUM(1), -1, INFO ) LWORK_CGEBRD=DUM(1) * Compute space needed for CUNMBR - CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, M, A, LDA, + CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, M, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_CUNMBR=DUM(1) * Compute space needed for CUNGBR diff --git a/lapack-netlib/SRC/cgelsy.f b/lapack-netlib/SRC/cgelsy.f index ffcc7d0337..d235087d42 100644 --- a/lapack-netlib/SRC/cgelsy.f +++ b/lapack-netlib/SRC/cgelsy.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGELSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGELSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -190,19 +190,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEsolve * *> \par Contributors: * ================== *> -*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n *> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> @@ -210,10 +210,10 @@ SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/cgemlq.f b/lapack-netlib/SRC/cgemlq.f new file mode 100644 index 0000000000..2f44e7cfbb --- /dev/null +++ b/lapack-netlib/SRC/cgemlq.f @@ -0,0 +1,283 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMLQ overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> where Q is a complex unitary matrix defined as the product +*> of blocked elementary reflectors computed by short wide +*> LQ factorization (CGELQ) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> Part of the data structure to represent Q as returned by CGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by CGELQ. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> CLASWQR or CGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, CGELQ will use either +*> CLASWLQ (if the matrix is wide-and-short) or CGELQT to compute +*> the LQ factorization. +*> This version of CGEMLQ will use either CLAMSWLQ or CGEMLQT to +*> multiply matrix Q by another matrix. +*> Further Details in CLAMSWLQ or CGEMLQT. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLAMSWLQ, CGEMLQT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * MB + MN = M + ELSE + LW = M * MB + MN = N + END IF +* + IF( ( NB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, NB - K ) .EQ. 0 ) THEN + NBLCKS = ( MN - K ) / ( NB - K ) + ELSE + NBLCKS = ( MN - K ) / ( NB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = REAL( LW ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( NB.LE.K ) .OR. ( NB.GE.MAX( M, N, K ) ) ) THEN + CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T( 6 ), MB, C, LDC, WORK, INFO ) + ELSE + CALL CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ MB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = REAL( LW ) +* + RETURN +* +* End of CGEMLQ +* + END diff --git a/lapack-netlib/SRC/cgemlqt.f b/lapack-netlib/SRC/cgemlqt.f new file mode 100644 index 0000000000..e4c991a722 --- /dev/null +++ b/lapack-netlib/SRC/cgemlqt.f @@ -0,0 +1,272 @@ +* Definition: +* =========== +* +* SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. +* COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMQRT overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q C C Q +*> TRANS = 'C': Q**C C C Q**C +*> +*> where Q is a complex orthogonal matrix defined as the product of K +*> elementary reflectors: +*> +*> Q = H(1) H(2) . . . H(K) = I - V C V**C +*> +*> generated using the compact WY representation as returned by CGELQT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**C from the Left; +*> = 'R': apply Q or Q**C from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DGELQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension (LDV,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQT in the first K rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DGELQT, stored as a MB-by-M matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**C C, C Q**C or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array. The dimension of +*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE CGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. + COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'C' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0) THEN + INFO = -5 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL CLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL CLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL CLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL CLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of CGEMLQT +* + END diff --git a/lapack-netlib/SRC/cgemqr.f b/lapack-netlib/SRC/cgemqr.f new file mode 100644 index 0000000000..a43d7be5b9 --- /dev/null +++ b/lapack-netlib/SRC/cgemqr.f @@ -0,0 +1,285 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMQR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (CGEQR) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,K) +*> Part of the data structure to represent Q as returned by CGEQR. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by CGEQR. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> CLATSQR or CGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, CGEQR will use either +*> CLATSQR (if the matrix is tall-and-skinny) or CGEQRT to compute +*> the QR factorization. +*> This version of CGEMQR will use either CLAMTSQR or CGEMQRT to +*> multiply matrix Q by another matrix. +*> Further Details in CLAMTSQR or CGEMQRT. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMQRT, CLAMTSQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * NB + MN = M + ELSE + LW = MB * NB + MN = N + END IF +* + IF( ( MB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, MB - K ).EQ.0 ) THEN + NBLCKS = ( MN - K ) / ( MB - K ) + ELSE + NBLCKS = ( MN - K ) / ( MB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, MN ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( MB.LE.K ) .OR. ( MB.GE.MAX( M, N, K ) ) ) THEN + CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, INFO ) + ELSE + CALL CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of CGEMQR +* + END diff --git a/lapack-netlib/SRC/cgemqrt.f b/lapack-netlib/SRC/cgemqrt.f index ae6f8c7a6a..4926fb7f65 100644 --- a/lapack-netlib/SRC/cgemqrt.f +++ b/lapack-netlib/SRC/cgemqrt.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, +* SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDC, M, N, NB, LDT @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -46,7 +46,7 @@ *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> -*> generated using the compact WY representation as returned by CGEQRT. +*> generated using the compact WY representation as returned by CGEQRT. *> *> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. *> \endverbatim @@ -155,23 +155,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== - SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, + SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -207,7 +207,7 @@ SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF( LEFT ) THEN LDWORK = MAX( 1, N ) Q = M @@ -248,17 +248,17 @@ SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL CLARFB( 'L', 'C', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL CLARFB( 'L', 'C', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL CLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL CLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * @@ -266,9 +266,9 @@ SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL CLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL CLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * @@ -276,9 +276,9 @@ SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL CLARFB( 'R', 'C', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL CLARFB( 'R', 'C', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * diff --git a/lapack-netlib/SRC/cgeql2.f b/lapack-netlib/SRC/cgeql2.f index b3cd801958..b9521ba4ad 100644 --- a/lapack-netlib/SRC/cgeql2.f +++ b/lapack-netlib/SRC/cgeql2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgeqlf.f b/lapack-netlib/SRC/cgeqlf.f index 2e3d30977d..fdd03f9e10 100644 --- a/lapack-netlib/SRC/cgeqlf.f +++ b/lapack-netlib/SRC/cgeqlf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQLF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQLF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgeqp3.f b/lapack-netlib/SRC/cgeqp3.f index 826a44ad99..e3d109de92 100644 --- a/lapack-netlib/SRC/cgeqp3.f +++ b/lapack-netlib/SRC/cgeqp3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -29,7 +29,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -159,10 +159,10 @@ SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgeqr.f b/lapack-netlib/SRC/cgeqr.f new file mode 100644 index 0000000000..a00ef45c0d --- /dev/null +++ b/lapack-netlib/SRC/cgeqr.f @@ -0,0 +1,307 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CGEQR computes a QR factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R +*> (R is upper triangular if M >= N); +*> the elements below the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any QR factorization algorithm they wish. The triangular +*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> CLATSQR or CGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, CGEQR will use either +*> CLATSQR (if the matrix is tall-and-skinny) or CGEQRT to compute +*> the QR factorization. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLATSQR, CGEQRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'CGEQR ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'CGEQR ', ' ', M, N, 2, -1 ) + ELSE + MB = M + NB = 1 + END IF + IF( MB.GT.M .OR. MB.LE.N ) MB = M + IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1 + MINTSZ = N + 5 + IF( MB.GT.N .AND. M.GT.N ) THEN + IF( MOD( M - N, MB - N ).EQ.0 ) THEN + NBLCKS = ( M - N ) / ( MB - N ) + ELSE + NBLCKS = ( M - N ) / ( MB - N ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N ) + $ .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + NB = 1 + MB = M + END IF + IF( LWORK.LT.NB*N ) THEN + LMINWS = .TRUE. + NB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = NB*N*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, NB*N ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN + CALL CGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO ) + ELSE + CALL CLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, NB*N ) +* + RETURN +* +* End of CGEQR +* + END diff --git a/lapack-netlib/SRC/cgeqr2.f b/lapack-netlib/SRC/cgeqr2.f index 67bf2ccf79..1b2030b478 100644 --- a/lapack-netlib/SRC/cgeqr2.f +++ b/lapack-netlib/SRC/cgeqr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgeqr2p.f b/lapack-netlib/SRC/cgeqr2p.f index b5b7b1c3c2..3c64255d9b 100644 --- a/lapack-netlib/SRC/cgeqr2p.f +++ b/lapack-netlib/SRC/cgeqr2p.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQR2P + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -124,10 +124,10 @@ * ===================================================================== SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgeqrf.f b/lapack-netlib/SRC/cgeqrf.f index be1bb402a8..8333847077 100644 --- a/lapack-netlib/SRC/cgeqrf.f +++ b/lapack-netlib/SRC/cgeqrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgeqrfp.f b/lapack-netlib/SRC/cgeqrfp.f index 1fa8a6afd1..a56508b4ef 100644 --- a/lapack-netlib/SRC/cgeqrfp.f +++ b/lapack-netlib/SRC/cgeqrfp.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQRFP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQRFP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -139,10 +139,10 @@ * ===================================================================== SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgeqrt.f b/lapack-netlib/SRC/cgeqrt.f index a849168202..2b8bb6986a 100644 --- a/lapack-netlib/SRC/cgeqrt.f +++ b/lapack-netlib/SRC/cgeqrt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> CGEQRT computes a blocked QR factorization of a complex M-by-N matrix A -*> using the compact WY representation of Q. +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -81,7 +81,7 @@ *> as a sequence of upper triangular blocks. See below *> for further details. *> \endverbatim -*> +*> *> \param[in] LDT *> \verbatim *> LDT is INTEGER @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -130,9 +130,9 @@ *> in the matrix A. The 1's along the diagonal of V are not stored in A. *> *> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = (T1 T2 ... TB). @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -194,7 +194,7 @@ SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * DO I = 1, K, NB IB = MIN( K-I+1, NB ) -* +* * Compute the QR factorization of the current block A(I:M,I:I+IB-1) * IF( USE_RECURSIVE_QR ) THEN @@ -207,12 +207,12 @@ SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * Update by applying H**H to A(I:M,I+IB:N) from the left * CALL CLARFB( 'L', 'C', 'F', 'C', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I, I ), LDA, T( 1, I ), LDT, $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN -* +* * End of CGEQRT * END diff --git a/lapack-netlib/SRC/cgeqrt2.f b/lapack-netlib/SRC/cgeqrt2.f index df5f51a71c..9ee3e4f793 100644 --- a/lapack-netlib/SRC/cgeqrt2.f +++ b/lapack-netlib/SRC/cgeqrt2.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CGEQRT2 computes a QR factorization of a complex M-by-N matrix A, -*> using the compact WY representation of Q. +*> CGEQRT2 computes a QR factorization of a complex M-by-N matrix A, +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N @@ -170,7 +170,7 @@ SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) CALL XERBLA( 'CGEQRT2', -INFO ) RETURN END IF -* +* K = MIN( M, N ) * DO I = 1, K @@ -188,13 +188,13 @@ SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * W(1:N-I) := A(I:M,I+1:N)**H * A(I:M,I) [W = T(:,N)] * - CALL CGEMV( 'C',M-I+1, N-I, ONE, A( I, I+1 ), LDA, + CALL CGEMV( 'C',M-I+1, N-I, ONE, A( I, I+1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) * * A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)**H * ALPHA = -CONJG(T( I, 1 )) - CALL CGERC( M-I+1, N-I, ALPHA, A( I, I ), 1, + CALL CGERC( M-I+1, N-I, ALPHA, A( I, I ), 1, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF @@ -207,7 +207,7 @@ SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) * T(1:I-1,I) := alpha * A(I:M,1:I-1)**H * A(I:M,I) * ALPHA = -T( I, 1 ) - CALL CGEMV( 'C', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, + CALL CGEMV( 'C', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * @@ -220,7 +220,7 @@ SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO - + * * End of CGEQRT2 * diff --git a/lapack-netlib/SRC/cgeqrt3.f b/lapack-netlib/SRC/cgeqrt3.f index a5b55c1d32..e3cfeeaca0 100644 --- a/lapack-netlib/SRC/cgeqrt3.f +++ b/lapack-netlib/SRC/cgeqrt3.f @@ -1,42 +1,42 @@ -*> \brief \b CGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. +*> \brief CGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGEQRT3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CGEQRT3 recursively computes a QR factorization of a complex M-by-N matrix A, -*> using the compact WY representation of Q. +*> CGEQRT3 recursively computes a QR factorization of a complex M-by-N matrix A, +*> using the compact WY representation of Q. *> -*> Based on the algorithm of Elmroth and Gustavson, +*> Based on the algorithm of Elmroth and Gustavson, *> IBM J. Res. Develop. Vol 44 No. 4 July 2000. *> \endverbatim * @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexGEcomputational * @@ -132,10 +132,10 @@ * ===================================================================== RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT @@ -177,8 +177,8 @@ RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute Householder transform when N=1 * - CALL CLARFG( M, A, A( MIN( 2, M ), 1 ), 1, T ) -* + CALL CLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) +* ELSE * * Otherwise, split A into blocks... @@ -199,7 +199,7 @@ RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) T( I, J+N1 ) = A( I, J+N1 ) END DO END DO - CALL CTRMM( 'L', 'L', 'C', 'U', N1, N2, ONE, + CALL CTRMM( 'L', 'L', 'C', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * CALL CGEMM( 'C', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, @@ -208,7 +208,7 @@ RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL CTRMM( 'L', 'U', 'C', 'N', N1, N2, ONE, & T, LDT, T( 1, J1 ), LDT ) * - CALL CGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, + CALL CGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL CTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, @@ -222,7 +222,7 @@ RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2**H * - CALL CGEQRT3( M-N1, N2, A( J1, J1 ), LDA, + CALL CGEQRT3( M-N1, N2, A( J1, J1 ), LDA, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1**H Y2 T2 @@ -236,13 +236,13 @@ RECURSIVE SUBROUTINE CGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL CTRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) * - CALL CGEMM( 'C', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, + CALL CGEMM( 'C', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) * - CALL CTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, + CALL CTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, & T( 1, J1 ), LDT ) * - CALL CTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, + CALL CTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] diff --git a/lapack-netlib/SRC/cgerfs.f b/lapack-netlib/SRC/cgerfs.f index 5ee085108f..6178321daa 100644 --- a/lapack-netlib/SRC/cgerfs.f +++ b/lapack-netlib/SRC/cgerfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,12 +173,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -186,10 +186,10 @@ SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgerfsx.f b/lapack-netlib/SRC/cgerfsx.f index 698cb229cf..7b72f9c9a2 100644 --- a/lapack-netlib/SRC/cgerfsx.f +++ b/lapack-netlib/SRC/cgerfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,7 +143,7 @@ *> R is REAL array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. +*> is not accessed. *> If R is accessed, each element of R should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -158,7 +158,7 @@ *> C is REAL array, dimension (N) *> The column scale factors for A. If EQUED = 'C' or 'B', A is *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C -*> is not accessed. +*> is not accessed. *> If C is accessed, each element of C should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -399,12 +399,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -414,10 +414,10 @@ SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, EQUED @@ -475,11 +475,10 @@ SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL SLAMCH, CLANGE, CLA_GERCOND_X, CLA_GERCOND_C REAL SLAMCH, CLANGE, CLA_GERCOND_X, CLA_GERCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/cgerq2.f b/lapack-netlib/SRC/cgerq2.f index 9ec0888afc..b0844ea7b2 100644 --- a/lapack-netlib/SRC/cgerq2.f +++ b/lapack-netlib/SRC/cgerq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGERQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgerqf.f b/lapack-netlib/SRC/cgerqf.f index 375a1a994b..4ae26e817c 100644 --- a/lapack-netlib/SRC/cgerqf.f +++ b/lapack-netlib/SRC/cgerqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGERQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGERQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cgesc2.f b/lapack-netlib/SRC/cgesc2.f index 129105202d..c0b91107e4 100644 --- a/lapack-netlib/SRC/cgesc2.f +++ b/lapack-netlib/SRC/cgesc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, N * REAL SCALE @@ -28,7 +28,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX A( LDA, * ), RHS( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEauxiliary * @@ -115,10 +115,10 @@ * ===================================================================== SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, N diff --git a/lapack-netlib/SRC/cgesdd.f b/lapack-netlib/SRC/cgesdd.f index 7f16b63b66..07341593f6 100644 --- a/lapack-netlib/SRC/cgesdd.f +++ b/lapack-netlib/SRC/cgesdd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESDD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESDD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,8 +135,8 @@ *> \param[in] LDU *> \verbatim *> LDU is INTEGER -*> The leading dimension of the array U. LDU >= 1; if -*> JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. +*> The leading dimension of the array U. LDU >= 1; +*> if JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. *> \endverbatim *> *> \param[out] VT @@ -152,8 +152,8 @@ *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; +*> The leading dimension of the array VT. LDVT >= 1; +*> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; *> if JOBZ = 'S', LDVT >= min(M,N). *> \endverbatim *> @@ -167,24 +167,28 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. -*> if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N). -*> if JOBZ = 'O', -*> LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). -*> if JOBZ = 'S' or 'A', -*> LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). -*> For good performance, LWORK should generally be larger. -*> *> If LWORK = -1, a workspace query is assumed. The optimal *> size for the WORK array is calculated and stored in WORK(1), *> and no other work except argument checking is performed. +*> +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LWORK >= 2*mn + mx. +*> If JOBZ = 'O', LWORK >= 2*mn*mn + 2*mn + mx. +*> If JOBZ = 'S', LWORK >= mn*mn + 3*mn. +*> If JOBZ = 'A', LWORK >= mn*mn + 2*mn + mx. +*> These are not tight minimums in all cases; see comments inside code. +*> For good performance, LWORK should generally be larger; +*> a query is recommended. *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is REAL array, dimension (MAX(1,LRWORK)) -*> If JOBZ = 'N', LRWORK >= 7*min(M,N). -*> Otherwise, -*> LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1) +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn); +*> else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn; +*> else LRWORK >= max( 5*mn*mn + 5*mn, +*> 2*mx*mn + 2*mn*mn + mn ). *> \endverbatim *> *> \param[out] IWORK @@ -203,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexGEsing * @@ -221,11 +225,12 @@ * ===================================================================== SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ @@ -241,8 +246,6 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ===================================================================== * * .. Parameters .. - INTEGER LQUERV - PARAMETER ( LQUERV = -1 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) @@ -250,16 +253,27 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS INTEGER BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT, $ ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, $ MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL - REAL ANRM, BIGNUM, EPS, SMLNUM + INTEGER LWORK_CGEBRD_MN, LWORK_CGEBRD_MM, + $ LWORK_CGEBRD_NN, LWORK_CGELQF_MN, + $ LWORK_CGEQRF_MN, + $ LWORK_CUNGBR_P_MN, LWORK_CUNGBR_P_NN, + $ LWORK_CUNGBR_Q_MN, LWORK_CUNGBR_Q_MM, + $ LWORK_CUNGLQ_MN, LWORK_CUNGLQ_NN, + $ LWORK_CUNGQR_MM, LWORK_CUNGQR_MN, + $ LWORK_CUNMBR_PRC_MM, LWORK_CUNMBR_QLN_MM, + $ LWORK_CUNMBR_PRC_MN, LWORK_CUNMBR_QLN_MN, + $ LWORK_CUNMBR_PRC_NN, LWORK_CUNMBR_QLN_NN + REAL ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) REAL DUM( 1 ) + COMPLEX CDUM( 1 ) * .. * .. External Subroutines .. EXTERNAL CGEBRD, CGELQF, CGEMM, CGEQRF, CLACP2, CLACPY, @@ -268,9 +282,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - REAL CLANGE, SLAMCH - EXTERNAL CLANGE, SLAMCH, ILAENV, LSAME + REAL SLAMCH, CLANGE + EXTERNAL LSAME, SLAMCH, CLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -279,15 +292,16 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Test the input arguments * - INFO = 0 - MINMN = MIN( M, N ) - MNTHR1 = INT( MINMN*17.0 / 9.0 ) - MNTHR2 = INT( MINMN*5.0 / 3.0 ) - WNTQA = LSAME( JOBZ, 'A' ) - WNTQS = LSAME( JOBZ, 'S' ) + INFO = 0 + MINMN = MIN( M, N ) + MNTHR1 = INT( MINMN*17.0E0 / 9.0E0 ) + MNTHR2 = INT( MINMN*5.0E0 / 3.0E0 ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS - WNTQO = LSAME( JOBZ, 'O' ) - WNTQN = LSAME( JOBZ, 'N' ) + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) MINWRK = 1 MAXWRK = 1 * @@ -309,244 +323,296 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, END IF * * Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, +* Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace allocated at that point in the code, * as well as the preferred amount for good performance. * CWorkspace refers to complex workspace, and RWorkspace to * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN - IF( M.GE.N ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC -* for computing singular values and singular vectors; BDSPAN -* for computing singular values only. -* BDSPAC = 5*N*N + 7*N -* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) +* The real work space needed for bidiagonal SVD (sbdsdc) is +* BDSPAC = 3*N*N + 4*N for singular values and vectors; +* BDSPAC = 4*N for singular values only; +* not including e, RU, and RVT matrices. +* +* Compute space preferred for each routine + CALL CGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGEBRD_MN = INT( CDUM(1) ) +* + CALL CGEBRD( N, N, CDUM(1), N, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGEBRD_NN = INT( CDUM(1) ) +* + CALL CGEQRF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGEQRF_MN = INT( CDUM(1) ) +* + CALL CUNGBR( 'P', N, N, N, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_P_NN = INT( CDUM(1) ) +* + CALL CUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_Q_MM = INT( CDUM(1) ) +* + CALL CUNGBR( 'Q', M, N, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_Q_MN = INT( CDUM(1) ) +* + CALL CUNGQR( M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGQR_MM = INT( CDUM(1) ) +* + CALL CUNGQR( M, N, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGQR_MN = INT( CDUM(1) ) +* + CALL CUNMBR( 'P', 'R', 'C', N, N, N, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_CUNMBR_PRC_NN = INT( CDUM(1) ) +* + CALL CUNMBR( 'Q', 'L', 'N', M, M, N, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_CUNMBR_QLN_MM = INT( CDUM(1) ) +* + CALL CUNMBR( 'Q', 'L', 'N', M, N, N, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_CUNMBR_QLN_MN = INT( CDUM(1) ) +* + CALL CUNMBR( 'Q', 'L', 'N', N, N, N, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_CUNMBR_QLN_NN = INT( CDUM(1) ) * IF( M.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * - MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*N+2*N* - $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) + MAXWRK = N + LWORK_CGEQRF_MN + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CGEBRD_NN ) MINWRK = 3*N ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') -* - WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 2 (M >> N, JOBZ='O') +* + WRKBL = N + LWORK_CGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_CUNGQR_MN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_PRC_NN ) MAXWRK = M*N + N*N + WRKBL MINWRK = 2*N*N + 3*N ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') -* - WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 3 (M >> N, JOBZ='S') +* + WRKBL = N + LWORK_CGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_CUNGQR_MN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_PRC_NN ) MAXWRK = N*N + WRKBL MINWRK = N*N + 3*N ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') -* - WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'CUNGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 4 (M >> N, JOBZ='A') +* + WRKBL = N + LWORK_CGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_CUNGQR_MM ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_CUNMBR_PRC_NN ) MAXWRK = N*N + WRKBL - MINWRK = N*N + 2*N + M + MINWRK = N*N + MAX( 3*N, N + M ) END IF ELSE IF( M.GE.MNTHR2 ) THEN * -* Path 5 (M much larger than N, but not as much as MNTHR1) +* Path 5 (M >> N, but not as much as MNTHR1) * - MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*N + LWORK_CGEBRD_MN MINWRK = 2*N + M IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'Q', M, N, N, -1 ) ) +* Path 5o (M >> N, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_Q_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + N*N ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'Q', M, N, N, -1 ) ) +* Path 5s (M >> N, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_Q_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+M* - $ ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5a (M >> N, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNGBR_Q_MM ) END IF ELSE * -* Path 6 (M at least N, but not much larger) +* Path 6 (M >= N, but not much larger) * - MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*N + LWORK_CGEBRD_MN MINWRK = 2*N + M IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, N, N, -1 ) ) +* Path 6o (M >= N, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_PRC_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_QLN_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + N*N ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, N, N, -1 ) ) +* Path 6s (M >= N, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_QLN_MN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_PRC_NN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'CUNGBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+M* - $ ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6a (M >= N, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_CUNMBR_PRC_NN ) END IF END IF - ELSE + ELSE IF( MINMN.GT.0 ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC -* for computing singular values and singular vectors; BDSPAN -* for computing singular values only. -* BDSPAC = 5*M*M + 7*M -* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) +* The real work space needed for bidiagonal SVD (sbdsdc) is +* BDSPAC = 3*M*M + 4*M for singular values and vectors; +* BDSPAC = 4*M for singular values only; +* not including e, RU, and RVT matrices. +* +* Compute space preferred for each routine + CALL CGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGEBRD_MN = INT( CDUM(1) ) +* + CALL CGEBRD( M, M, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGEBRD_MM = INT( CDUM(1) ) +* + CALL CGELQF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR ) + LWORK_CGELQF_MN = INT( CDUM(1) ) +* + CALL CUNGBR( 'P', M, N, M, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_P_MN = INT( CDUM(1) ) +* + CALL CUNGBR( 'P', N, N, M, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_P_NN = INT( CDUM(1) ) +* + CALL CUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGBR_Q_MM = INT( CDUM(1) ) +* + CALL CUNGLQ( M, N, M, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGLQ_MN = INT( CDUM(1) ) +* + CALL CUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_CUNGLQ_NN = INT( CDUM(1) ) +* + CALL CUNMBR( 'P', 'R', 'C', M, M, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_CUNMBR_PRC_MM = INT( CDUM(1) ) +* + CALL CUNMBR( 'P', 'R', 'C', M, N, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_CUNMBR_PRC_MN = INT( CDUM(1) ) +* + CALL CUNMBR( 'P', 'R', 'C', N, N, M, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_CUNMBR_PRC_NN = INT( CDUM(1) ) +* + CALL CUNMBR( 'Q', 'L', 'N', M, M, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_CUNMBR_QLN_MM = INT( CDUM(1) ) * IF( N.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * - MAXWRK = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*M+2*M* - $ ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = M + LWORK_CGELQF_MN + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CGEBRD_MM ) MINWRK = 3*M ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') -* - WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 2t (N >> M, JOBZ='O') +* + WRKBL = M + LWORK_CGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_CUNGLQ_MN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_PRC_MM ) MAXWRK = M*N + M*M + WRKBL MINWRK = 2*M*M + 3*M ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* - WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 3t (N >> M, JOBZ='S') +* + WRKBL = M + LWORK_CGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_CUNGLQ_MN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_PRC_MM ) MAXWRK = M*M + WRKBL MINWRK = M*M + 3*M ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') -* - WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'CUNGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 4t (N >> M, JOBZ='A') +* + WRKBL = M + LWORK_CGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_CUNGLQ_NN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_CUNMBR_PRC_MM ) MAXWRK = M*M + WRKBL - MINWRK = M*M + 2*M + N + MINWRK = M*M + MAX( 3*M, M + N ) END IF ELSE IF( N.GE.MNTHR2 ) THEN * -* Path 5t (N much larger than M, but not as much as MNTHR1) +* Path 5t (N >> M, but not as much as MNTHR1) * - MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*M + LWORK_CGEBRD_MN MINWRK = 2*M + N IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5to (N >> M, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_P_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + M*M ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5ts (N >> M, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_P_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*M+N* - $ ILAENV( 1, 'CUNGBR', 'P', N, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5ta (N >> M, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNGBR_P_NN ) END IF ELSE * -* Path 6t (N greater than M, but not much larger) +* Path 6t (N > M, but not much larger) * - MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*M + LWORK_CGEBRD_MN MINWRK = 2*M + N IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'PRC', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNMBR', 'QLN', M, M, N, -1 ) ) +* Path 6to (N > M, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_PRC_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + M*M ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'PRC', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6ts (N > M, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_PRC_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*M+N* - $ ILAENV( 1, 'CUNGBR', 'PRC', N, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6ta (N > M, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_CUNMBR_PRC_NN ) END IF END IF END IF @@ -554,18 +620,20 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, END IF IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK - IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) - $ INFO = -13 + IF( LWORK.LT.MINWRK .AND. .NOT. LQUERY ) THEN + INFO = -12 + END IF END IF -* -* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGESDD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF - IF( LWORK.EQ.LQUERV ) - $ RETURN +* +* Quick return if possible +* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF @@ -598,15 +666,16 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: need 0) +* CWorkspace: need N [tau] + N [work] +* CWorkspace: prefer N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -621,8 +690,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -630,15 +700,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NRWORK = IE + N * * Perform bidiagonal SVD, compute singular values only -* (CWorkspace: 0) -* (RWorkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') +* Path 2 (M >> N, JOBZ='O') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * @@ -648,20 +718,21 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * LDWRKU = N IR = IU + LDWRKU*N - IF( LWORK.GE.M*N+N*N+3*N ) THEN + IF( LWORK .GE. M*N + N*N + 3*N ) THEN * * WORK(IR) is M by N * LDWRKR = M ELSE - LDWRKR = ( LWORK-N*N-3*N ) / N + LDWRKR = ( LWORK - N*N - 3*N ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -673,8 +744,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ LDWRKR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -684,8 +756,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -694,8 +767,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of R in WORK(IRU) and computing right singular vectors * of R in WORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = IE + N IRVT = IRU + N*N @@ -706,8 +779,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by the left singular vectors of R -* (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ), $ LDWRKU ) @@ -717,8 +791,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by the right singular vectors of R -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR, @@ -727,8 +802,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in WORK(IR) and copying to A -* (CWorkspace: need 2*N*N, prefer N*N+M*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] +* CWorkspace: prefer N*N [U] + M*N [R] +* RWorkspace: need 0 * DO 10 I = 1, M, LDWRKR CHUNK = MIN( M-I+1, LDWRKR ) @@ -741,7 +817,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') +* Path 3 (M >> N, JOBZ='S') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -754,8 +830,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -767,8 +844,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ LDWRKR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -778,8 +856,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -788,8 +867,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = IE + N IRVT = IRU + N*N @@ -800,8 +879,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, @@ -810,8 +890,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR, @@ -820,8 +901,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U -* (CWorkspace: need N*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] +* RWorkspace: need 0 * CALL CLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) CALL CGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ), @@ -829,7 +910,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') +* Path 4 (M >> N, JOBZ='A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -842,16 +923,18 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) CALL CLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (CWorkspace: need N+M, prefer N+M*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N [tau] + M [work] +* CWorkspace: prefer N*N [U] + N [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -866,8 +949,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -879,8 +963,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -888,8 +972,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by left singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ), $ LDWRKU ) @@ -899,8 +984,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of R -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -909,8 +995,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A -* (CWorkspace: need N*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] +* RWorkspace: need 0 * CALL CGEMM( 'N', 'N', M, N, N, CONE, U, LDU, WORK( IU ), $ LDWRKU, CZERO, A, LDA ) @@ -925,7 +1011,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * MNTHR2 <= M < MNTHR1 * -* Path 5 (M much larger than N, but not as much as MNTHR1) +* Path 5 (M >> N, but not as much as MNTHR1) * Reduce to bidiagonal form without QR decomposition, use * CUNGBR and matrix multiplication to compute singular vectors * @@ -936,19 +1022,21 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5n (M >> N, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK @@ -956,22 +1044,25 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, IRVT = IRU + N*N NRWORK = IRVT + N*N * +* Path 5o (M >> N, JOBZ='O') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * * WORK( IU ) is M by N * @@ -980,15 +1071,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * WORK(IU) is LDWRKU by N * - LDWRKU = ( LWORK-3*N ) / N + LDWRKU = ( LWORK - 3*N ) / N END IF NWORK = IU + LDWRKU*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -996,8 +1087,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in WORK(IU), copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, $ WORK( IU ), LDWRKU, RWORK( NRWORK ) ) @@ -1005,8 +1096,10 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need N*N, prefer M*N) -* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] +* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork] +* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT DO 20 I = 1, M, LDWRKU @@ -1019,17 +1112,20 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQS ) THEN * +* Path 5s (M >> N, JOBZ='S') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to U, generate Q -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'L', M, N, A, LDA, U, LDU ) CALL CUNGBR( 'Q', M, N, N, U, LDU, WORK( ITAUQ ), @@ -1038,8 +1134,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1050,8 +1146,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) @@ -1059,8 +1155,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need N*N+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT CALL CLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA, @@ -1068,17 +1164,20 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, CALL CLACPY( 'F', M, N, A, LDA, U, LDU ) ELSE * +* Path 5a (M >> N, JOBZ='A') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to U, generate Q -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'L', M, N, A, LDA, U, LDU ) CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), @@ -1087,8 +1186,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1099,8 +1198,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) @@ -1108,8 +1207,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT CALL CLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA, @@ -1121,7 +1220,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * M .LT. MNTHR2 * -* Path 6 (M at least N, but not much larger) +* Path 6 (M >= N, but not much larger) * Reduce to bidiagonal form without QR decomposition * Use CUNMBR to compute singular vectors * @@ -1132,26 +1231,28 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + N * * Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need N [e] * CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 6n (M >= N, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK IRU = NRWORK IRVT = IRU + N*N NRWORK = IRVT + N*N - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * * WORK( IU ) is M by N * @@ -1160,15 +1261,16 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * WORK( IU ) is LDWRKU by N * - LDWRKU = ( LWORK-3*N ) / N + LDWRKU = ( LWORK - 3*N ) / N END IF NWORK = IU + LDWRKU*N * +* Path 6o (M >= N, JOBZ='O') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -1176,21 +1278,24 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * -* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) -* Overwrite WORK(IU) by left singular vectors of A, copying -* to A -* (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB) -* (Rworkspace: need 0) +* Path 6o-fast +* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) +* Overwrite WORK(IU) by left singular vectors of A, copying +* to A +* CWorkspace: need 2*N [tauq, taup] + M*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] * CALL CLASET( 'F', M, N, CZERO, CZERO, WORK( IU ), $ LDWRKU ) @@ -1202,17 +1307,21 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, CALL CLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) ELSE * +* Path 6o-slow * Generate Q in A -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work] +* RWorkspace: need 0 * CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need N*N, prefer M*N) -* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] +* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork] +* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT DO 30 I = 1, M, LDWRKU @@ -1227,11 +1336,12 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQS ) THEN * +* Path 6s (M >= N, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1242,8 +1352,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL CLASET( 'F', M, N, CZERO, CZERO, U, LDU ) CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) @@ -1253,8 +1364,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -1262,11 +1374,12 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ LWORK-NWORK+1, IERR ) ELSE * +* Path 6a (M >= N, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1285,8 +1398,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -1295,8 +1409,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -1316,15 +1431,16 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M [tau] + M [work] +* CWorkspace: prefer M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1339,8 +1455,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1348,15 +1465,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NRWORK = IE + M * * Perform bidiagonal SVD, compute singular values only -* (CWorkspace: 0) -* (RWorkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL SBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') +* Path 2t (N >> M, JOBZ='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * @@ -1366,7 +1483,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK(IVT) is M by M * IL = IVT + LDWKVT*M - IF( LWORK.GE.M*N+M*M+3*M ) THEN + IF( LWORK .GE. M*N + M*M + 3*M ) THEN * * WORK(IL) M by N * @@ -1377,14 +1494,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK(IL) is M by CHUNK * LDWRKL = M - CHUNK = ( LWORK-M*M-3*M ) / M + CHUNK = ( LWORK - M*M - 3*M ) / M END IF ITAU = IL + LDWRKL*CHUNK NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1396,8 +1514,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK( IL+LDWRKL ), LDWRKL ) * * Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1407,8 +1526,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -1417,8 +1537,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1429,8 +1549,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by the left singular vectors of L -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, @@ -1439,8 +1560,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) * Overwrite WORK(IVT) by the right singular vectors of L -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1450,8 +1572,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply right singular vectors of L in WORK(IL) by Q * in A, storing result in WORK(IL) and copying to A -* (CWorkspace: need 2*M*M, prefer M*M+M*N)) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] +* CWorkspace: prefer M*M [VT] + M*N [L] +* RWorkspace: need 0 * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -1464,9 +1587,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U +* Path 3t (N >> M, JOBZ='S') +* M right singular vectors to be computed in VT and +* M left singular vectors to be computed in U * IL = 1 * @@ -1477,8 +1600,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1490,8 +1614,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK( IL+LDWRKL ), LDWRKL ) * * Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1501,8 +1626,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -1511,8 +1637,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1523,8 +1649,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, @@ -1533,8 +1660,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by left singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL, @@ -1543,8 +1671,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy VT to WORK(IL), multiply right singular vectors of L * in WORK(IL) by Q in A, storing result in VT -* (CWorkspace: need M*M) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] +* RWorkspace: need 0 * CALL CLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL, @@ -1552,7 +1680,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * ELSE IF( WNTQA ) THEN * -* Path 9t (N much larger than M, JOBZ='A') +* Path 4t (N >> M, JOBZ='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1565,16 +1693,18 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (CWorkspace: need M+N, prefer M+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M [tau] + N [work] +* CWorkspace: prefer M*M [VT] + M [tau] + N*NB [work] +* RWorkspace: need 0 * CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1589,8 +1719,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize L in A -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1599,8 +1730,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1611,8 +1742,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of L -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, M, A, LDA, @@ -1621,8 +1753,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) * Overwrite WORK(IVT) by right singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1632,11 +1765,11 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply right singular vectors of L in WORK(IVT) by * Q in VT, storing result in A -* (CWorkspace: need M*M) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] +* RWorkspace: need 0 * - CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), - $ LDWKVT, VT, LDVT, CZERO, A, LDA ) + CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), LDWKVT, + $ VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * @@ -1648,10 +1781,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * MNTHR2 <= N < MNTHR1 * -* Path 5t (N much larger than M, but not as much as MNTHR1) +* Path 5t (N >> M, but not as much as MNTHR1) * Reduce to bidiagonal form without QR decomposition, use * CUNGBR and matrix multiplication to compute singular vectors -* * IE = 1 NRWORK = IE + M @@ -1660,8 +1792,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1669,11 +1802,12 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * IF( WNTQN ) THEN * +* Path 5tn (N >> M, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IRVT = NRWORK @@ -1681,23 +1815,26 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NRWORK = IRU + M*M IVT = NWORK * +* Path 5to (N >> M, JOBZ='O') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'L', M, M, A, LDA, U, LDU ) CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Generate P**H in A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * LDWKVT = M - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * * WORK( IVT ) is M by N * @@ -1707,15 +1844,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * WORK( IVT ) is M by CHUNK * - CHUNK = ( LWORK-3*M ) / M + CHUNK = ( LWORK - 3*M ) / M NWORK = IVT + LDWKVT*CHUNK END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ), $ M, RWORK( IRVT ), M, DUM, IDUM, @@ -1723,8 +1860,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by real matrix RWORK(IRVT) * storing the result in WORK(IVT), copying to U -* (Cworkspace: need 0) -* (Rworkspace: need 2*M*M) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ), $ LDWKVT, RWORK( NRWORK ) ) @@ -1732,8 +1869,10 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply RWORK(IRVT) by P**H in A, storing the * result in WORK(IVT), copying to A -* (CWorkspace: need M*M, prefer M*N) -* (Rworkspace: need 2*M*M, prefer 2*M*N) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] +* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork] +* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU DO 50 I = 1, N, CHUNK @@ -1745,17 +1884,20 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, 50 CONTINUE ELSE IF( WNTQS ) THEN * +* Path 5ts (N >> M, JOBZ='S') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'L', M, M, A, LDA, U, LDU ) CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to VT, generate P**H -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT ) CALL CUNGBR( 'P', M, N, M, VT, LDVT, WORK( ITAUP ), @@ -1764,8 +1906,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1776,8 +1918,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need 3*M*M) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA, $ RWORK( NRWORK ) ) @@ -1785,8 +1927,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need M*M+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU CALL CLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA, @@ -1794,17 +1936,20 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT ) ELSE * +* Path 5ta (N >> M, JOBZ='A') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'L', M, M, A, LDA, U, LDU ) CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to VT, generate P**H -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT ) CALL CUNGBR( 'P', N, N, M, VT, LDVT, WORK( ITAUP ), @@ -1813,8 +1958,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1825,8 +1970,8 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need 3*M*M) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA, $ RWORK( NRWORK ) ) @@ -1834,9 +1979,10 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need M*M+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * + NRWORK = IRU CALL CLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT ) @@ -1846,7 +1992,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * N .LT. MNTHR2 * -* Path 6t (N greater than M, but not much larger) +* Path 6t (N > M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * Use CUNMBR to compute singular vectors * @@ -1857,24 +2003,27 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, NWORK = ITAUP + M * * Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need M [e] * CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 6tn (N > M, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 6to (N > M, JOBZ='O') LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * * WORK( IVT ) is M by N * @@ -1885,15 +2034,15 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * WORK( IVT ) is M by CHUNK * - CHUNK = ( LWORK-3*M ) / M + CHUNK = ( LWORK - 3*M ) / M NWORK = IVT + LDWKVT*CHUNK END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1904,21 +2053,24 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * -* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) -* Overwrite WORK(IVT) by right singular vectors of A, -* copying to A -* (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB) -* (Rworkspace: need 0) +* Path 6to-fast +* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) +* Overwrite WORK(IVT) by right singular vectors of A, +* copying to A +* CWorkspace: need 2*M [tauq, taup] + M*N [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1928,17 +2080,21 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, CALL CLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) ELSE * +* Path 6to-slow * Generate P**H in A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work] +* RWorkspace: need 0 * CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need M*M, prefer M*N) -* (Rworkspace: need 3*M*M, prefer M*M+2*M*N) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] +* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork] +* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU DO 60 I = 1, N, CHUNK @@ -1952,11 +2108,12 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, END IF ELSE IF( WNTQS ) THEN * +* Path 6ts (N > M, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1967,8 +2124,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -1977,8 +2135,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL CLASET( 'F', M, N, CZERO, CZERO, VT, LDVT ) CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) @@ -1987,11 +2146,12 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ LWORK-NWORK+1, IERR ) ELSE * +* Path 6ta (N > M, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -2003,8 +2163,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -2017,8 +2178,9 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) CALL CUNMBR( 'P', 'R', 'C', N, N, M, A, LDA, diff --git a/lapack-netlib/SRC/cgesv.f b/lapack-netlib/SRC/cgesv.f index bc3118bf73..7837e0fa4e 100644 --- a/lapack-netlib/SRC/cgesv.f +++ b/lapack-netlib/SRC/cgesv.f @@ -1,25 +1,25 @@ -*> \brief CGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) +*> \brief CGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEsolve * * ===================================================================== SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff --git a/lapack-netlib/SRC/cgesvd.f b/lapack-netlib/SRC/cgesvd.f index 3c1f825db8..cdcf9db3cd 100644 --- a/lapack-netlib/SRC/cgesvd.f +++ b/lapack-netlib/SRC/cgesvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -201,10 +201,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -214,7 +214,7 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * April 2012 @@ -322,23 +322,23 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) * Compute space needed for CGEQRF CALL CGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGEQRF=CDUM(1) + LWORK_CGEQRF = INT( CDUM(1) ) * Compute space needed for CUNGQR CALL CUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_CUNGQR_N=CDUM(1) + LWORK_CUNGQR_N = INT( CDUM(1) ) CALL CUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_CUNGQR_M=CDUM(1) + LWORK_CUNGQR_M = INT( CDUM(1) ) * Compute space needed for CGEBRD CALL CGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGEBRD=CDUM(1) + LWORK_CGEBRD = INT( CDUM(1) ) * Compute space needed for CUNGBR CALL CUNGBR( 'P', N, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_P=CDUM(1) + LWORK_CUNGBR_P = INT( CDUM(1) ) CALL CUNGBR( 'Q', N, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_Q=CDUM(1) + LWORK_CUNGBR_Q = INT( CDUM(1) ) * MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( M.GE.MNTHR ) THEN @@ -446,24 +446,24 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * CALL CGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGEBRD=CDUM(1) + LWORK_CGEBRD = INT( CDUM(1) ) MAXWRK = 2*N + LWORK_CGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL CUNGBR( 'Q', M, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_Q=CDUM(1) + LWORK_CUNGBR_Q = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_Q ) END IF IF( WNTUA ) THEN CALL CUNGBR( 'Q', M, M, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_Q=CDUM(1) + LWORK_CUNGBR_Q = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_Q ) END IF IF( .NOT.WNTVN ) THEN MAXWRK = MAX( MAXWRK, 2*N+LWORK_CUNGBR_P ) - MINWRK = 2*N + M END IF + MINWRK = 2*N + M END IF ELSE IF( MINMN.GT.0 ) THEN * @@ -472,25 +472,25 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) * Compute space needed for CGELQF CALL CGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGELQF=CDUM(1) + LWORK_CGELQF = INT( CDUM(1) ) * Compute space needed for CUNGLQ CALL CUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1, $ IERR ) - LWORK_CUNGLQ_N=CDUM(1) + LWORK_CUNGLQ_N = INT( CDUM(1) ) CALL CUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_CUNGLQ_M=CDUM(1) + LWORK_CUNGLQ_M = INT( CDUM(1) ) * Compute space needed for CGEBRD CALL CGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGEBRD=CDUM(1) + LWORK_CGEBRD = INT( CDUM(1) ) * Compute space needed for CUNGBR P CALL CUNGBR( 'P', M, M, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_P=CDUM(1) + LWORK_CUNGBR_P = INT( CDUM(1) ) * Compute space needed for CUNGBR Q CALL CUNGBR( 'Q', M, M, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_Q=CDUM(1) + LWORK_CUNGBR_Q = INT( CDUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * @@ -596,25 +596,25 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * CALL CGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_CGEBRD=CDUM(1) + LWORK_CGEBRD = INT( CDUM(1) ) MAXWRK = 2*M + LWORK_CGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for CUNGBR P CALL CUNGBR( 'P', M, N, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_P=CDUM(1) + LWORK_CUNGBR_P = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_P ) END IF IF( WNTVA ) THEN CALL CUNGBR( 'P', N, N, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_CUNGBR_P=CDUM(1) + LWORK_CUNGBR_P = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_P ) END IF IF( .NOT.WNTUN ) THEN MAXWRK = MAX( MAXWRK, 2*M+LWORK_CUNGBR_Q ) - MINWRK = 2*M + N END IF + MINWRK = 2*M + N END IF END IF MAXWRK = MAX( MINWRK, MAXWRK ) @@ -681,8 +681,10 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R * - CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), + $ LDA ) + END IF IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N @@ -1145,8 +1147,10 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1322,8 +1326,10 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1650,8 +1656,10 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1831,8 +1839,10 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) diff --git a/lapack-netlib/SRC/cgesvdx.f b/lapack-netlib/SRC/cgesvdx.f index 235426ad48..fdfb9734ff 100644 --- a/lapack-netlib/SRC/cgesvdx.f +++ b/lapack-netlib/SRC/cgesvdx.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, -* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, +* SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, +* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, * $ LWORK, RWORK, IWORK, INFO ) -* +* * * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT, RANGE @@ -31,10 +31,10 @@ * .. Array Arguments .. * INTEGER IWORK( * ) * REAL S( * ), RWORK( * ) -* COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), +* COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -44,23 +44,23 @@ *> CGESVDX computes the singular value decomposition (SVD) of a complex *> M-by-N matrix A, optionally computing the left and/or right singular *> vectors. The SVD is written -*> +*> *> A = U * SIGMA * transpose(V) -*> +*> *> where SIGMA is an M-by-N matrix which is zero except for its *> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and *> V is an N-by-N unitary matrix. The diagonal elements of SIGMA *> are the singular values of A; they are real and non-negative, and *> are returned in descending order. The first min(m,n) columns of *> U and V are the left and right singular vectors of A. -*> -*> CGESVDX uses an eigenvalue problem for obtaining the SVD, which -*> allows for the computation of a subset of singular values and +*> +*> CGESVDX uses an eigenvalue problem for obtaining the SVD, which +*> allows for the computation of a subset of singular values and *> vectors. See SBDSVDX for details. -*> +*> *> Note that the routine returns V**T, not V. *> \endverbatim -* +* * Arguments: * ========== * @@ -69,7 +69,7 @@ *> JOBU is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'V': the first min(m,n) columns of U (the left singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array U; *> = 'N': no columns of U (no left singular vectors) are *> computed. @@ -81,7 +81,7 @@ *> Specifies options for computing all or part of the matrix *> V**T: *> = 'V': the first min(m,n) rows of V**T (the right singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array VT; *> = 'N': no rows of V**T (no right singular vectors) are *> computed. @@ -93,7 +93,7 @@ *> = 'A': all singular values will be found. *> = 'V': all singular values in the half-open interval (VL,VU] *> will be found. -*> = 'I': the IL-th through IU-th singular values will be found. +*> = 'I': the IL-th through IU-th singular values will be found. *> \endverbatim *> *> \param[in] M @@ -124,13 +124,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL -*> VL >=0. +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -138,13 +140,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -152,7 +158,7 @@ *> \param[out] NS *> \verbatim *> NS is INTEGER -*> The total number of singular values found, +*> The total number of singular values found, *> 0 <= NS <= min(M,N). *> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1. *> \endverbatim @@ -166,11 +172,11 @@ *> \param[out] U *> \verbatim *> U is COMPLEX array, dimension (LDU,UCOL) -*> If JOBU = 'V', U contains columns of U (the left singular -*> vectors, stored columnwise) as specified by RANGE; if +*> If JOBU = 'V', U contains columns of U (the left singular +*> vectors, stored columnwise) as specified by RANGE; if *> JOBU = 'N', U is not referenced. -*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', -*> the exact value of NS is not known ILQFin advance and an upper +*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -184,11 +190,11 @@ *> \param[out] VT *> \verbatim *> VT is COMPLEX array, dimension (LDVT,N) -*> If JOBVT = 'V', VT contains the rows of V**T (the right singular -*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', +*> If JOBVT = 'V', VT contains the rows of V**T (the right singular +*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', *> VT is not referenced. -*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', -*> the exact value of NS is not known in advance and an upper +*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -209,9 +215,9 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see +*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see *> comments inside the code): -*> - PATH 1 (M much larger than N) +*> - PATH 1 (M much larger than N) *> - PATH 1t (N much larger than M) *> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths. *> For good performance, LWORK should generally be larger. @@ -231,8 +237,8 @@ *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (12*MIN(M,N)) -*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, -*> then IWORK contains the indices of the eigenvectors that failed +*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, +*> then IWORK contains the indices of the eigenvectors that failed *> to converge in SBDSVDX/SSTEVX. *> \endverbatim *> @@ -250,24 +256,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexGEsing * * ===================================================================== - SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, - $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, + SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, + $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT, RANGE @@ -277,7 +283,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * .. Array Arguments .. INTEGER IWORK( * ) REAL S( * ), RWORK( * ) - COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), + COMPLEX A( LDA, * ), U( LDU, * ), VT( LDVT, * ), $ WORK( * ) * .. * @@ -294,8 +300,8 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CHARACTER JOBZ, RNGTGK LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL, - $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, - $ J, K, MAXWRK, MINMN, MINWRK, MNTHR + $ ITAU, ITAUP, ITAUQ, ITEMP, ITEMPR, ITGKZ, + $ IUTGK, J, K, MAXWRK, MINMN, MINWRK, MNTHR REAL ABSTOL, ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. @@ -367,8 +373,14 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( INFO.EQ.0 ) THEN IF( WANTU .AND. LDU.LT.M ) THEN INFO = -15 - ELSE IF( WANTVT .AND. LDVT.LT.MINMN ) THEN - INFO = -16 + ELSE IF( WANTVT ) THEN + IF( INDS ) THEN + IF( LDVT.LT.IU-IL+1 ) THEN + INFO = -17 + END IF + ELSE IF( LDVT.LT.MINMN ) THEN + INFO = -17 + END IF END IF END IF END IF @@ -390,18 +402,24 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1 (M much larger than N) * - MAXWRK = N + N* - $ ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, N*N + N + 2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - MINWRK = N*(N+4) + MINWRK = N*(N+5) + MAXWRK = N + N*ILAENV(1,'CGEQRF',' ',M,N,-1,-1) + MAXWRK = MAX(MAXWRK, + $ N*N+2*N+2*N*ILAENV(1,'CGEBRD',' ',N,N,-1,-1)) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ N*N+2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1)) + END IF ELSE * * Path 2 (M at least N, but not much larger) * - MAXWRK = 2*N + ( M+N )* - $ ILAENV( 1, 'CGEBRD', ' ', M, N, -1, -1 ) - MINWRK = 2*N + M + MINWRK = 3*N + M + MAXWRK = 2*N + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ 2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1)) + END IF END IF ELSE MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 ) @@ -409,18 +427,25 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1t (N much larger than M) * - MAXWRK = M + M* - $ ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M + M + 2*M* - $ ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) ) - MINWRK = M*(M+4) + MINWRK = M*(M+5) + MAXWRK = M + M*ILAENV(1,'CGELQF',' ',M,N,-1,-1) + MAXWRK = MAX(MAXWRK, + $ M*M+2*M+2*M*ILAENV(1,'CGEBRD',' ',M,M,-1,-1)) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ M*M+2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1)) + END IF ELSE * * Path 2t (N greater than M, but not much larger) * - MAXWRK = M*(M*2+19) + ( M+N )* - $ ILAENV( 1, 'CGEBRD', ' ', M, N, -1, -1 ) - MINWRK = 2*M + N +* + MINWRK = 3*M + N + MAXWRK = 2*M + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ 2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1)) + END IF END IF END IF END IF @@ -447,8 +472,6 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Set singular values indices accord to RANGE='A'. * - ALLS = LSAME( RANGE, 'A' ) - INDS = LSAME( RANGE, 'I' ) IF( ALLS ) THEN RNGTGK = 'I' ILTGK = 1 @@ -457,7 +480,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, RNGTGK = 'I' ILTGK = IL IUTGK = IU - ELSE + ELSE RNGTGK = 'V' ILTGK = 0 IUTGK = 0 @@ -501,31 +524,31 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAU + N CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) -* +* * Copy R into WORK and bidiagonalize it: * (Workspace: need N*N+3*N, prefer N*N+N+2*N*NB) -* +* IQRF = ITEMP ITAUQ = ITEMP + N*N ITAUP = ITAUQ + N ITEMP = ITAUP + N - ID = 1 + ID = 1 IE = ID + N ITGKZ = IE + N CALL CLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IQRF+1 ), N ) - CALL CGEBRD( N, N, WORK( IQRF ), N, RWORK( ID ), + CALL CGEBRD( N, N, WORK( IQRF ), N, RWORK( ID ), $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), $ WORK( ITEMP ), LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + N*(N*2+1) + ITEMPR = ITGKZ + N*(N*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*N*N+14*N) -* +* (Workspace: need 2*N*N+14*N) +* CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ), $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), N*2, RWORK( ITEMP ), + $ RWORK( ITGKZ ), N*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -539,23 +562,23 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL CLASET( 'A', M-N, N, CZERO, CZERO, U( N+1,1 ), LDU ) + CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) * * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL CUNMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL CUNMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call CUNMQR to compute Q*(QB*UB). * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL CUNMQR( 'L', 'N', M, NS, N, A, LDA, + CALL CUNMQR( 'L', 'N', M, NS, N, A, LDA, $ WORK( ITAU ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -571,7 +594,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call CUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL CUNMBR( 'P', 'R', 'C', NS, N, N, WORK( IQRF ), N, + CALL CUNMBR( 'P', 'R', 'C', NS, N, N, WORK( IQRF ), N, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) END IF @@ -587,21 +610,21 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITAUQ = 1 ITAUP = ITAUQ + N - ITEMP = ITAUP + N + ITEMP = ITAUP + N ID = 1 IE = ID + N ITGKZ = IE + N - CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), + CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + N*(N*2+1) + ITEMPR = ITGKZ + N*(N*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*N*N+14*N) -* +* (Workspace: need 2*N*N+14*N) +* CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), N*2, RWORK( ITEMP ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), N*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -609,22 +632,22 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( WANTU ) THEN K = ITGKZ DO I = 1, NS - DO J = 1, N + DO J = 1, N U( J, I ) = CMPLX( RWORK( K ), ZERO ) K = K + 1 END DO K = K + N END DO - CALL CLASET( 'A', M-N, N, CZERO, CZERO, U( N+1,1 ), LDU ) + CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) * * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) -* - CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), +* + CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -640,11 +663,11 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call CUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL CUNMBR( 'P', 'R', 'C', NS, N, N, A, LDA, + CALL CUNMBR( 'P', 'R', 'C', NS, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) END IF - END IF + END IF ELSE * * A has more columns than rows. If A has sufficiently more @@ -653,7 +676,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M): -* A = L * Q = ( QB * B * PB**T ) * Q +* A = L * Q = ( QB * B * PB**T ) * Q * = ( QB * ( UB * S * VB**T ) * PB**T ) * Q * U = QB * UB ; V**T = VB**T * PB**T * Q * @@ -668,7 +691,7 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Copy L into WORK and bidiagonalize it: * (Workspace in WORK( ITEMP ): need M*M+3*M, prefer M*M+M+2*M*NB) * - ILQF = ITEMP + ILQF = ITEMP ITAUQ = ILQF + M*M ITAUP = ITAUQ + M ITEMP = ITAUP + M @@ -676,19 +699,19 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + M ITGKZ = IE + M CALL CLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) - CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, + CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( ILQF+M ), M ) CALL CGEBRD( M, M, WORK( ILQF ), M, RWORK( ID ), - $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), + $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), $ WORK( ITEMP ), LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + M*(M*2+1) + ITEMPR = ITGKZ + M*(M*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), M*2, RWORK( ITEMP ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), M*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -706,11 +729,11 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL CUNMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL CUNMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -722,52 +745,52 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + M END DO - CALL CLASET( 'A', M, N-M, CZERO, CZERO, + CALL CLASET( 'A', NS, N-M, CZERO, CZERO, $ VT( 1,M+1 ), LDVT ) * * Call CUNMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL CUNMBR( 'P', 'R', 'C', NS, M, M, WORK( ILQF ), M, + CALL CUNMBR( 'P', 'R', 'C', NS, M, M, WORK( ILQF ), M, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call CUNMLQ to compute ((VB**T)*(PB**T))*Q. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL CUNMLQ( 'R', 'N', NS, N, M, A, LDA, + CALL CUNMLQ( 'R', 'N', NS, N, M, A, LDA, $ WORK( ITAU ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF ELSE * * Path 2t (N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T -* U = QB * UB; V**T = VB**T * PB**T +* U = QB * UB; V**T = VB**T * PB**T * * Bidiagonalize A * (Workspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* +* ITAUQ = 1 ITAUP = ITAUQ + M ITEMP = ITAUP + M ID = 1 IE = ID + M ITGKZ = IE + M - CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), + CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + M*(M*2+1) + ITEMPR = ITGKZ + M*(M*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) -* - CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), M*2, RWORK( ITEMP ), +* (Workspace: need 2*M*M+14*M) +* + CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, RWORK( ID ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), M*2, RWORK( ITEMPR ), $ IWORK, INFO) -* +* * If needed, compute left singular vectors. * IF( WANTU ) THEN @@ -783,11 +806,11 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call CUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -799,16 +822,16 @@ SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + M END DO - CALL CLASET( 'A', M, N-M, CZERO, CZERO, + CALL CLASET( 'A', NS, N-M, CZERO, CZERO, $ VT( 1,M+1 ), LDVT ) * * Call CUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL CUNMBR( 'P', 'R', 'C', NS, N, M, A, LDA, + CALL CUNMBR( 'P', 'R', 'C', NS, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF END IF END IF * diff --git a/lapack-netlib/SRC/cgesvj.f b/lapack-netlib/SRC/cgesvj.f index 69d77048b4..8dc6280fab 100644 --- a/lapack-netlib/SRC/cgesvj.f +++ b/lapack-netlib/SRC/cgesvj.f @@ -1,26 +1,26 @@ -*> \brief \b CGESVJ +*> \brief CGESVJ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESVJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESVJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, LRWORK, M, MV, N * CHARACTER*1 JOBA, JOBU, JOBV @@ -29,22 +29,22 @@ * COMPLEX A( LDA, * ), V( LDV, * ), CWORK( LWORK ) * REAL RWORK( LRWORK ), SVA( N ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -* CGESVJ computes the singular value decomposition (SVD) of a complex -* M-by-N matrix A, where M >= N. The SVD of A is written as -* [++] [xx] [x0] [xx] -* A = U * SIGMA * V^*, [++] = [xx] * [ox] * [xx] -* [++] [xx] -* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal -* matrix, and V is an N-by-N unitary matrix. The diagonal elements -* of SIGMA are the singular values of A. The columns of U and V are the -* left and the right singular vectors of A, respectively. +*> CGESVJ computes the singular value decomposition (SVD) of a complex +*> M-by-N matrix A, where M >= N. The SVD of A is written as +*> [++] [xx] [x0] [xx] +*> A = U * SIGMA * V^*, [++] = [xx] * [ox] * [xx] +*> [++] [xx] +*> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal +*> matrix, and V is an N-by-N unitary matrix. The diagonal elements +*> of SIGMA are the singular values of A. The columns of U and V are the +*> left and the right singular vectors of A, respectively. *> \endverbatim * * Arguments: @@ -64,7 +64,7 @@ *> JOBU is CHARACTER*1 *> Specifies whether to compute the left singular vectors *> (columns of U): -*> = 'U': The left singular vectors corresponding to the nonzero +*> = 'U' or 'F': The left singular vectors corresponding to the nonzero *> singular values are computed and returned in the leading *> columns of A. See more details in the description of A. *> The default numerical orthogonality threshold is set to @@ -88,7 +88,7 @@ *> JOBV is CHARACTER*1 *> Specifies whether to compute the right singular vectors, that *> is, the matrix V: -*> = 'V' : the matrix V is computed and returned in the array V +*> = 'V' or 'J': the matrix V is computed and returned in the array V *> = 'A' : the Jacobi rotations are applied to the MV-by-N *> array V. In other words, the right singular vector *> matrix V is not computed explicitly; instead it is @@ -205,17 +205,23 @@ *> \endverbatim *> *> \param[in,out] CWORK -*> CWORK is COMPLEX array, dimension M+N. -*> Used as work space. +*> \verbatim +*> CWORK is COMPLEX array, dimension max(1,LWORK). +*> Used as workspace. +*> If on entry LWORK .EQ. -1, then a workspace query is assumed and +*> no computation is done; CWORK(1) is set to the minial (and optimal) +*> length of CWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim -*> LWORK is INTEGER +*> LWORK is INTEGER. *> Length of CWORK, LWORK >= M+N. +*> \endverbatim *> *> \param[in,out] RWORK -*> RWORK is REAL array, dimension max(6,M+N). +*> \verbatim +*> RWORK is REAL array, dimension max(6,LRWORK). *> On entry, *> If JOBU .EQ. 'C' : *> RWORK(1) = CTOL, where CTOL defines the threshold for convergence. @@ -241,10 +247,14 @@ *> RWORK(6) = the largest absolute value over all sines of the *> Jacobi rotation angles in the last sweep. It can be *> useful for a post festum analysis. +*> If on entry LRWORK .EQ. -1, then a workspace query is assumed and +*> no computation is done; RWORK(1) is set to the minial (and optimal) +*> length of RWORK. *> \endverbatim *> *> \param[in] LRWORK -*> LRWORK is INTEGER +*> \verbatim +*> LRWORK is INTEGER *> Length of RWORK, LRWORK >= MAX(6,N). *> \endverbatim *> @@ -253,26 +263,28 @@ *> INFO is INTEGER *> = 0 : successful exit. *> < 0 : if INFO = -i, then the i-th argument had an illegal value -*> > 0 : CGESVJ did not converge in the maximal allowed number -*> (NSWEEP=30) of sweeps. The output may still be useful. +*> > 0 : CGESVJ did not converge in the maximal allowed number +*> (NSWEEP=30) of sweeps. The output may still be useful. *> See the description of RWORK. *> \endverbatim -* +*> * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexGEcomputational * *> \par Further Details: * ===================== *> +*> \verbatim +*> *> The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane *> rotations. In the case of underflow of the tangent of the Jacobi angle, a *> modified Jacobi transformation of Drmac [3] is used. Pivot strategy uses @@ -285,23 +297,30 @@ *> procedure is achieved if used in an accelerated version of Drmac and *> Veselic [4,5], and it is the kernel routine in the SIGMA library [6]. *> Some tunning parameters (marked with [TP]) are available for the -*> implementer. +*> implementer. *> The computational range for the nonzero singular values is the machine *> number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even *> denormalized singular values can be computed with the corresponding *> gradual loss of accurate digits. -*> -*> \par Contributors: +*> \endverbatim +* +*> \par Contributor: * ================== *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> \verbatim +*> +*> ============ *> +*> Zlatko Drmac (Zagreb, Croatia) +*> +*> \endverbatim +* *> \par References: * ================ *> *> [1] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the -*> singular value decomposition on a vector computer. -*> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. +*> singular value decomposition on a vector computer. +*> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. *> [2] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. *> [3] Z. Drmac: Implementation of Jacobi rotations for accurate singular *> value computation in floating point arithmetic. @@ -315,23 +334,27 @@ *> [6] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, *> QSVD, (H,K)-SVD computations. *> Department of Mathematics, University of Zagreb, 2008, 2015. -*> -*> \par Bugs, Examples and Comments: +*> \endverbatim +* +*> \par Bugs, examples and comments: * ================================= *> -*> Please report all bugs and send interesting test examples and comments to -*> drmac@math.hr. Thank you. -* +*> \verbatim +*> =========================== +*> Please report all bugs and send interesting test examples and comments to +*> drmac@math.hr. Thank you. +*> \endverbatim +*> * ===================================================================== - SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, + SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * - IMPLICIT NONE + IMPLICIT NONE * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, LRWORK, M, MV, N CHARACTER*1 JOBA, JOBU, JOBV @@ -353,25 +376,24 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. * .. Local Scalars .. COMPLEX AAPQ, OMPQ - REAL AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, - $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, - $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, + REAL AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, + $ BIGTHETA, CS, CTOL, EPSLN, MXAAPQ, + $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, THSIGN, TOL INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, - $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, + $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND - LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, + LOGICAL APPLV, GOSCALE, LOWER, LQUERY, LSVEC, NOSCALE, ROTOK, $ RSVEC, UCTOL, UPPER * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, AMAX1, AMIN1, CONJG, FLOAT, MIN0, MAX0, - $ SIGN, SQRT + INTRINSIC ABS, MAX, MIN, CONJG, REAL, SIGN, SQRT * .. * .. External Functions .. * .. * from BLAS - REAL SCNRM2 + REAL SCNRM2 COMPLEX CDOTC EXTERNAL CDOTC, SCNRM2 INTEGER ISAMAX @@ -387,20 +409,21 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * from BLAS EXTERNAL CCOPY, CROT, CSSCAL, CSWAP * from LAPACK - EXTERNAL CLASCL, CLASET, CLASSQ, XERBLA + EXTERNAL CLASCL, CLASET, CLASSQ, SLASCL, XERBLA EXTERNAL CGSVJ0, CGSVJ1 * .. * .. Executable Statements .. * * Test the input arguments * - LSVEC = LSAME( JOBU, 'U' ) + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) UCTOL = LSAME( JOBU, 'C' ) - RSVEC = LSAME( JOBV, 'V' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'J' ) APPLV = LSAME( JOBV, 'A' ) UPPER = LSAME( JOBA, 'U' ) LOWER = LSAME( JOBA, 'L' ) * + LQUERY = ( LWORK .EQ. -1 ) .OR. ( LRWORK .EQ. -1 ) IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN @@ -420,10 +443,10 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, INFO = -11 ELSE IF( UCTOL .AND. ( RWORK( 1 ).LE.ONE ) ) THEN INFO = -12 - ELSE IF( LWORK.LT.( M+N ) ) THEN + ELSE IF( LWORK.LT.( M+N ) .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 - ELSE IF( LRWORK.LT.MAX0( N, 6 ) ) THEN - INFO = -15 + ELSE IF( LRWORK.LT.MAX( N, 6 ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -15 ELSE INFO = 0 END IF @@ -432,6 +455,10 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGESVJ', -INFO ) RETURN + ELSE IF ( LQUERY ) THEN + CWORK(1) = M + N + RWORK(1) = MAX( N, 6 ) + RETURN END IF * * #:) Quick return for void matrix @@ -451,9 +478,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN - CTOL = SQRT( FLOAT( M ) ) + CTOL = SQRT( REAL( M ) ) ELSE - CTOL = FLOAT( M ) + CTOL = REAL( M ) END IF END IF * ... and the machine dependent parameters are @@ -464,16 +491,16 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, SFMIN = SLAMCH( 'SafeMinimum' ) ROOTSFMIN = SQRT( SFMIN ) SMALL = SFMIN / EPSLN - BIG = SLAMCH( 'Overflow' ) -* BIG = ONE / SFMIN +* BIG = SLAMCH( 'Overflow' ) + BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN - LARGE = BIG / SQRT( FLOAT( M*N ) ) +* LARGE = BIG / SQRT( REAL( M*N ) ) BIGTHETA = ONE / ROOTEPS * TOL = CTOL*EPSLN ROOTTOL = SQRT( TOL ) * - IF( FLOAT( M )*EPSLN.GE.ONE ) THEN + IF( REAL( M )*EPSLN.GE.ONE ) THEN INFO = -4 CALL XERBLA( 'CGESVJ', -INFO ) RETURN @@ -498,7 +525,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries * in A are detected, the procedure returns with INFO=-6. * - SKL = ONE / SQRT( FLOAT( M )*FLOAT( N ) ) + SKL = ONE / SQRT( REAL( M )*REAL( N ) ) NOSCALE = .TRUE. GOSCALE = .TRUE. * @@ -588,8 +615,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = ZERO AAQQ = BIG DO 4781 p = 1, N - IF( SVA( p ).NE.ZERO )AAQQ = AMIN1( AAQQ, SVA( p ) ) - AAPP = AMAX1( AAPP, SVA( p ) ) + IF( SVA( p ).NE.ZERO )AAQQ = MIN( AAQQ, SVA( p ) ) + AAPP = MAX( AAPP, SVA( p ) ) 4781 CONTINUE * * #:) Quick return for zero matrix @@ -627,22 +654,22 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * avoid underflows/overflows in computing Jacobi rotations. * SN = SQRT( SFMIN / EPSLN ) - TEMP1 = SQRT( BIG / FLOAT( N ) ) - IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. + TEMP1 = SQRT( BIG / REAL( N ) ) + IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. $ ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN - TEMP1 = AMIN1( BIG, TEMP1 / AAPP ) + TEMP1 = MIN( BIG, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN - TEMP1 = AMIN1( SN / AAQQ, BIG / ( AAPP*SQRT( FLOAT( N ) ) ) ) + TEMP1 = MIN( SN / AAQQ, BIG / ( AAPP*SQRT( REAL( N ) ) ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN - TEMP1 = AMAX1( SN / AAQQ, TEMP1 / AAPP ) + TEMP1 = MAX( SN / AAQQ, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN - TEMP1 = AMIN1( SN / AAQQ, BIG / ( SQRT( FLOAT( N ) )*AAPP ) ) + TEMP1 = MIN( SN / AAQQ, BIG / ( SQRT( REAL( N ) )*AAPP ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE @@ -664,10 +691,10 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * EMPTSW = ( N*( N-1 ) ) / 2 NOTROT = 0 - + DO 1868 q = 1, N CWORK( q ) = CONE - 1868 CONTINUE + 1868 CONTINUE * * * @@ -679,7 +706,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * The boundaries are determined dynamically, based on the number of * pivots above a threshold. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the @@ -691,7 +718,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, BLSKIP = KBL**2 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. * - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. * LKAHEAD = 1 @@ -702,7 +729,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * invokes cubic convergence. Big part of this cycle is done inside * canonical subspaces of dimensions less than M. * - IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX0( 64, 4*KBL ) ) ) THEN + IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX( 64, 4*KBL ) ) ) THEN *[TP] The number of partition levels and the actual partition are * tuning parameters. N4 = N / 4 @@ -800,18 +827,18 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * igl = ( ibr-1 )*KBL + 1 * - DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr ) + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * - DO 2001 p = igl, MIN0( igl+KBL-1, N-1 ) + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * * .. de Rijk's pivoting * q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL CSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) - IF( RSVEC )CALL CSWAP( MVL, V( 1, p ), 1, + IF( RSVEC )CALL CSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) @@ -835,7 +862,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * If properly implemented SCNRM2 is available, the IF-THEN-ELSE-END IF * below should be replaced with "AAPP = SCNRM2( M, A(1,p), 1 )". * - IF( ( SVA( p ).LT.ROOTBIG ) .AND. + IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = SCNRM2( M, A( 1, p ), 1 ) ELSE @@ -853,7 +880,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * PSKIPPED = 0 * - DO 2002 q = p + 1, MIN0( igl+KBL-1, N ) + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) * @@ -863,12 +890,12 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, + AAPQ = ( CDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE - CALL CCOPY( M, A( 1, p ), 1, + CALL CCOPY( M, A( 1, p ), 1, $ CWORK(N+1), 1 ) - CALL CLASCL( 'G', 0, 0, AAPP, ONE, + CALL CLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, CWORK(N+1), LDA, IERR ) AAPQ = CDOTC( M, CWORK(N+1), 1, $ A( 1, q ), 1 ) / AAQQ @@ -876,10 +903,10 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( CDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / AAPP ) / AAQQ ELSE - CALL CCOPY( M, A( 1, q ), 1, + CALL CCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) CALL CLASCL( 'G', 0, 0, AAQQ, $ ONE, M, 1, @@ -889,14 +916,14 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) - AAPQ1 = -ABS(AAPQ) - MXAAPQ = AMAX1( MXAAPQ, -AAPQ1 ) +* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) + AAPQ1 = -ABS(AAPQ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) * * .. rotate *[RTD] ROTATED = ROTATED + ONE @@ -914,47 +941,47 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, THETA = -HALF*ABS( AQOAP-APOAQ )/AAPQ1 * IF( ABS( THETA ).GT.BIGTHETA ) THEN -* +* T = HALF / THETA CS = ONE CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*T ) IF ( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -SIGN( ONE, AAPQ1 ) - T = ONE / ( THETA+THSIGN* + T = ONE / ( THETA+THSIGN* $ SQRT( ONE+THETA*THETA ) ) CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS * - MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*SN ) IF ( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) - END IF - END IF - CWORK(p) = -CWORK(q) * OMPQ + END IF + END IF + CWORK(p) = -CWORK(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -969,9 +996,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ A( 1, q ), 1 ) CALL CLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * @@ -1035,7 +1062,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) - $ NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE @@ -1055,14 +1082,14 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N ) + DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -1079,7 +1106,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, + AAPQ = ( CDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL CCOPY( M, A( 1, p ), 1, @@ -1097,8 +1124,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( CDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL CCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) @@ -1110,14 +1138,14 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = AMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -1132,18 +1160,18 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate @@ -1154,20 +1182,20 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ SQRT( ONE+THETA*THETA ) ) CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL CROT( M, A(1,p), 1, A(1,q), 1, - $ CS, CONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF - CWORK(p) = -CWORK(q) * OMPQ + CWORK(p) = -CWORK(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -1185,9 +1213,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL CLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL CCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) @@ -1197,14 +1225,14 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL CLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL CAXPY( M, -CONJG(AAPQ), + CALL CAXPY( M, -CONJG(AAPQ), $ CWORK(N+1), 1, A( 1, p ), 1 ) CALL CLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*SQRT( AMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -1272,7 +1300,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -1283,7 +1311,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -1306,8 +1334,8 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( FLOAT( N ) )* - $ TOL ) .AND. ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( REAL( N ) )* + $ TOL ) .AND. ( REAL( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * @@ -1355,8 +1383,9 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * Normalize the left singular vectors. * IF( LSVEC .OR. UCTOL ) THEN - DO 1998 p = 1, N2 - CALL CSSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) + DO 1998 p = 1, N4 +* CALL CSSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) + CALL CLASCL( 'G',0,0, SVA(p), ONE, M, 1, A(1,p), M, IERR ) 1998 CONTINUE END IF * @@ -1370,7 +1399,7 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) + IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. $ ( SFMIN / SKL ) ) ) ) THEN DO 2400 p = 1, N @@ -1384,15 +1413,15 @@ SUBROUTINE CGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * then some of the singular values may overflow or underflow and * the spectrum is given in this factored representation. * - RWORK( 2 ) = FLOAT( N4 ) + RWORK( 2 ) = REAL( N4 ) * N4 is the number of computed nonzero singular values of A. * - RWORK( 3 ) = FLOAT( N2 ) + RWORK( 3 ) = REAL( N2 ) * N2 is the number of singular values of A greater than SFMIN. * If N2 \htmlonly -*> Download CGESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, * EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -336,10 +336,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -350,7 +350,7 @@ SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cgesvxx.f b/lapack-netlib/SRC/cgesvxx.f index 58b36e81bb..30d1beb338 100644 --- a/lapack-netlib/SRC/cgesvxx.f +++ b/lapack-netlib/SRC/cgesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -527,10 +527,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -543,7 +543,7 @@ SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cgetc2.f b/lapack-netlib/SRC/cgetc2.f index 99eb69d92a..e4a414fc27 100644 --- a/lapack-netlib/SRC/cgetc2.f +++ b/lapack-netlib/SRC/cgetc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGETC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGETC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complexGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/cgetf2.f b/lapack-netlib/SRC/cgetf2.f index 0070f157fe..083e6cce1e 100644 --- a/lapack-netlib/SRC/cgetf2.f +++ b/lapack-netlib/SRC/cgetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -167,7 +167,7 @@ SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO ) * * Compute machine safe minimum * - SFMIN = SLAMCH('S') + SFMIN = SLAMCH('S') * DO 10 J = 1, MIN( M, N ) * diff --git a/lapack-netlib/SRC/cgetrf.f b/lapack-netlib/SRC/cgetrf.f index dba75bc23a..4e72995f53 100644 --- a/lapack-netlib/SRC/cgetrf.f +++ b/lapack-netlib/SRC/cgetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/cgetrf2.f b/lapack-netlib/SRC/cgetrf2.f index 9e985d0e23..eda77e2270 100644 --- a/lapack-netlib/SRC/cgetrf2.f +++ b/lapack-netlib/SRC/cgetrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE CGETRF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -35,11 +35,11 @@ *> *> This is the recursive version of the algorithm. It divides *> the matrix into four submatrices: -*> +*> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = min(m,n) +*> A = [ -----|----- ] with n1 = min(m,n)/2 *> [ A21 | A22 ] n2 = n-n1 -*> +*> *> [ A11 ] *> The subroutine calls itself to factor [ --- ], *> [ A12 ] @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexGEcomputational * * ===================================================================== RECURSIVE SUBROUTINE CGETRF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -130,7 +130,7 @@ RECURSIVE SUBROUTINE CGETRF2( M, N, A, LDA, IPIV, INFO ) * * .. Parameters .. COMPLEX ONE, ZERO - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. @@ -241,12 +241,12 @@ RECURSIVE SUBROUTINE CGETRF2( M, N, A, LDA, IPIV, INFO ) * * Solve A12 * - CALL CTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + CALL CTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, $ A( 1, N1+1 ), LDA ) * * Update A22 * - CALL CGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + CALL CGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) * * Factor A22 diff --git a/lapack-netlib/SRC/cgetri.f b/lapack-netlib/SRC/cgetri.f index 97bf362582..bc83f74c66 100644 --- a/lapack-netlib/SRC/cgetri.f +++ b/lapack-netlib/SRC/cgetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/cgetrs.f b/lapack-netlib/SRC/cgetrs.f index cdeec9eadd..6dc63e70df 100644 --- a/lapack-netlib/SRC/cgetrs.f +++ b/lapack-netlib/SRC/cgetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgetsls.f b/lapack-netlib/SRC/cgetsls.f new file mode 100644 index 0000000000..56fb8063f9 --- /dev/null +++ b/lapack-netlib/SRC/cgetsls.f @@ -0,0 +1,497 @@ +* Definition: +* =========== +* +* SUBROUTINE CGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGETSLS solves overdetermined or underdetermined complex linear systems +*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ +*> factorization of A. It is assumed that A has full rank. +*> +*> +*> +*> The following options are provided: +*> +*> 1. If TRANS = 'N' and m >= n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A*X ||. +*> +*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of +*> an underdetermined system A * X = B. +*> +*> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of +*> an undetermined system A**T * X = B. +*> +*> 4. If TRANS = 'C' and m < n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A**T * X ||. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'C': the linear system involves A**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> A is overwritten by details of its QR or LQ +*> factorization as returned by CGEQR or CGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the matrix B of right hand side vectors, stored +*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS +*> if TRANS = 'C'. +*> On exit, if INFO = 0, B is overwritten by the solution +*> vectors, stored columnwise: +*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least +*> squares solution vectors. +*> if TRANS = 'N' and m < n, rows 1 to N of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'C' and m >= n, rows 1 to M of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'C' and m < n, rows 1 to M of B contain the +*> least squares solution vectors. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of A is zero, so that A does not have +*> full rank; the least squares solution could not be +*> computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexGEsolve +* +* ===================================================================== + SUBROUTINE CGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TRAN + INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, + $ SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2, + $ WSIZEO, WSIZEM, INFO2 + REAL ANRM, BIGNUM, BNRM, SMLNUM + COMPLEX TQ( 5 ), WORKQ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANGE + EXTERNAL LSAME, ILAENV, SLABAD, SLAMCH, CLANGE +* .. +* .. External Subroutines .. + EXTERNAL CGEQR, CGEMQR, CLASCL, CLASET, + $ CTRTRS, XERBLA, CGELQ, CGEMLQ +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN, INT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNK = MAX( MINMN, NRHS ) + TRAN = LSAME( TRANS, 'C' ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) + IF( .NOT.( LSAME( TRANS, 'N' ) .OR. + $ LSAME( TRANS, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size and minimum LWORK +* + IF( M.GE.N ) THEN + CALL CGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL CGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL CGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL CGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZM, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + ELSE + CALL CGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL CGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL CGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL CGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + END IF +* + IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN + INFO = -10 + END IF +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGETSLS', -INFO ) + WORK( 1 ) = REAL( WSIZEO ) + RETURN + END IF + IF( LQUERY ) THEN + IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO ) + IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM ) + RETURN + END IF + IF( LWORK.LT.WSIZEO ) THEN + LW1 = TSZM + LW2 = LWM + ELSE + LW1 = TSZO + LW2 = LWO + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + CALL CLASET( 'FULL', MAX( M, N ), NRHS, CZERO, CZERO, + $ B, LDB ) + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL SLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max element outside range [SMLNUM,BIGNUM] +* + ANRM = CLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL CLASET( 'F', MAXMN, NRHS, CZERO, CZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF ( TRAN ) THEN + BROW = N + END IF + BNRM = CLANGE( 'M', BROW, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL CLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL CLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +* + IF ( M.GE.N ) THEN +* +* compute QR factorization of A +* + CALL CGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) + IF ( .NOT.TRAN ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) +* + CALL CGEMQR( 'L' , 'C', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL CTRTRS( 'U', 'N', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) + IF( INFO.GT.0 ) THEN + RETURN + END IF + SCLLEN = N + ELSE +* +* Overdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) +* + CALL CTRTRS( 'U', 'C', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(N+1:M,1:NRHS) = CZERO +* + DO 20 J = 1, NRHS + DO 10 I = N + 1, M + B( I, J ) = CZERO + 10 CONTINUE + 20 CONTINUE +* +* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) +* + CALL CGEMQR( 'L', 'N', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL CGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TRAN ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL CTRTRS( 'L', 'N', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(M+1:N,1:NRHS) = 0 +* + DO 40 J = 1, NRHS + DO 30 I = M + 1, N + B( I, J ) = CZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS) +* + CALL CGEMLQ( 'L', 'C', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = N +* + ELSE +* +* overdetermined system min || A**T * X - B || +* +* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) +* + CALL CGEMLQ( 'L', 'N', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS) +* + CALL CTRTRS( 'L', 'C', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = M +* + END IF +* + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF +* + 50 CONTINUE + WORK( 1 ) = REAL( TSZO + LWO ) + RETURN +* +* End of ZGETSLS +* + END diff --git a/lapack-netlib/SRC/cggbak.f b/lapack-netlib/SRC/cggbak.f index 2992e132f1..3626ecbeb8 100644 --- a/lapack-netlib/SRC/cggbak.f +++ b/lapack-netlib/SRC/cggbak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, * LDV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -29,7 +29,7 @@ * REAL LSCALE( * ), RSCALE( * ) * COMPLEX V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -148,10 +148,10 @@ SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/cggbal.f b/lapack-netlib/SRC/cggbal.f index 7fe1956799..8c7324c70c 100644 --- a/lapack-netlib/SRC/cggbal.f +++ b/lapack-netlib/SRC/cggbal.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, * RSCALE, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, LDB, N @@ -29,7 +29,7 @@ * REAL LSCALE( * ), RSCALE( * ), WORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -177,10 +177,10 @@ SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/cgges.f b/lapack-netlib/SRC/cgges.f index 655e2b063f..988b8a8539 100644 --- a/lapack-netlib/SRC/cgges.f +++ b/lapack-netlib/SRC/cgges.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, * SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM @@ -37,7 +37,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -256,12 +256,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexGEeigen * @@ -270,10 +270,10 @@ SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT diff --git a/lapack-netlib/SRC/cgges3.f b/lapack-netlib/SRC/cgges3.f index 9103ccf1c6..876a26df96 100644 --- a/lapack-netlib/SRC/cgges3.f +++ b/lapack-netlib/SRC/cgges3.f @@ -269,7 +269,7 @@ SUBROUTINE CGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -394,7 +394,7 @@ SUBROUTINE CGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, -1, - $ WORK, IERR ) + $ RWORK, IERR ) LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) IF( WANTST ) THEN CALL CTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, diff --git a/lapack-netlib/SRC/cggesx.f b/lapack-netlib/SRC/cggesx.f index 0238a7237d..4d49647414 100644 --- a/lapack-netlib/SRC/cggesx.f +++ b/lapack-netlib/SRC/cggesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, * LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, * IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SENSE, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, @@ -40,7 +40,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -315,12 +315,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEeigen * @@ -330,10 +330,10 @@ SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, $ LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT diff --git a/lapack-netlib/SRC/cggev.f b/lapack-netlib/SRC/cggev.f index 18b4f47eac..678a0e51dd 100644 --- a/lapack-netlib/SRC/cggev.f +++ b/lapack-netlib/SRC/cggev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, * VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -31,7 +31,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -204,10 +204,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -217,7 +217,7 @@ SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -334,7 +334,7 @@ SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, LWKMIN = MAX( 1, 2*N ) LWKOPT = MAX( 1, N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) ) LWKOPT = MAX( LWKOPT, N + - $ N*ILAENV( 1, 'CUNMQR', ' ', N, 1, N, 0 ) ) + $ N*ILAENV( 1, 'CUNMQR', ' ', N, 1, N, 0 ) ) IF( ILVL ) THEN LWKOPT = MAX( LWKOPT, N + $ N*ILAENV( 1, 'CUNGQR', ' ', N, 1, N, -1 ) ) diff --git a/lapack-netlib/SRC/cggev3.f b/lapack-netlib/SRC/cggev3.f index decdae509f..f34b8f2c41 100644 --- a/lapack-netlib/SRC/cggev3.f +++ b/lapack-netlib/SRC/cggev3.f @@ -216,7 +216,7 @@ SUBROUTINE CGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 diff --git a/lapack-netlib/SRC/cggevx.f b/lapack-netlib/SRC/cggevx.f index d01cf918e8..c5fb37e888 100644 --- a/lapack-netlib/SRC/cggevx.f +++ b/lapack-netlib/SRC/cggevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, * LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, * WORK, LWORK, RWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -37,7 +37,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,7 +271,7 @@ *> numbers of the eigenvectors, stored in consecutive elements *> of the array. If the eigenvalues cannot be reordered to *> compute RCONDV(j), RCONDV(j) is set to 0; this can only occur -*> when the true value would be very small anyway. +*> when the true value would be very small anyway. *> If SENSE = 'N' or 'E', RCONDV is not referenced. *> \endverbatim *> @@ -330,10 +330,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -374,7 +374,7 @@ SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, $ WORK, LWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cggglm.f b/lapack-netlib/SRC/cggglm.f index 2f20100e6b..336f419091 100644 --- a/lapack-netlib/SRC/cggglm.f +++ b/lapack-netlib/SRC/cggglm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGGLM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGGLM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), * $ X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -185,10 +185,10 @@ SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -216,7 +216,7 @@ SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/cgghd3.f b/lapack-netlib/SRC/cgghd3.f index 112b41a179..a9468a24b3 100644 --- a/lapack-netlib/SRC/cgghd3.f +++ b/lapack-netlib/SRC/cgghd3.f @@ -231,7 +231,7 @@ SUBROUTINE CGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -282,7 +282,7 @@ SUBROUTINE CGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * INFO = 0 NB = ILAENV( 1, 'CGGHD3', ' ', N, ILO, IHI, -1 ) - LWKOPT = 6*N*NB + LWKOPT = MAX( 6*N*NB, 1 ) WORK( 1 ) = CMPLX( LWKOPT ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) diff --git a/lapack-netlib/SRC/cgghrd.f b/lapack-netlib/SRC/cgghrd.f index eda9e43d45..e615e3feee 100644 --- a/lapack-netlib/SRC/cgghrd.f +++ b/lapack-netlib/SRC/cgghrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ * INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -181,12 +181,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -204,10 +204,10 @@ SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ diff --git a/lapack-netlib/SRC/cgglse.f b/lapack-netlib/SRC/cgglse.f index 222650a375..b84dbeca8e 100644 --- a/lapack-netlib/SRC/cgglse.f +++ b/lapack-netlib/SRC/cgglse.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGLSE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGLSE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), C( * ), D( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsolve * @@ -180,10 +180,10 @@ SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -210,7 +210,7 @@ SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/cggqrf.f b/lapack-netlib/SRC/cggqrf.f index 24f95a2763..6d3496bef3 100644 --- a/lapack-netlib/SRC/cggqrf.f +++ b/lapack-netlib/SRC/cggqrf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -215,10 +215,10 @@ SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -238,7 +238,7 @@ SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, EXTERNAL CGEQRF, CGERQF, CUNMQR, XERBLA * .. * .. External Functions .. - INTEGER ILAENV + INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/cggrqf.f b/lapack-netlib/SRC/cggrqf.f index 3cba411e53..cad1cc0a7b 100644 --- a/lapack-netlib/SRC/cggrqf.f +++ b/lapack-netlib/SRC/cggrqf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -214,10 +214,10 @@ SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -237,7 +237,7 @@ SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, EXTERNAL CGEQRF, CGERQF, CUNMRQ, XERBLA * .. * .. External Functions .. - INTEGER ILAENV + INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/cggsvd3.f b/lapack-netlib/SRC/cggsvd3.f index 5cef7d478e..c9b4262f65 100644 --- a/lapack-netlib/SRC/cggsvd3.f +++ b/lapack-netlib/SRC/cggsvd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGSVD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGSVD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * LWORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -328,14 +328,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * -*> \ingroup complexOTHERsing +*> \ingroup complexGEsing * *> \par Contributors: * ================== @@ -354,7 +354,7 @@ SUBROUTINE CGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * August 2015 diff --git a/lapack-netlib/SRC/cggsvp3.f b/lapack-netlib/SRC/cggsvp3.f index 36fe9913be..8ea60367a5 100644 --- a/lapack-netlib/SRC/cggsvp3.f +++ b/lapack-netlib/SRC/cggsvp3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGGSVP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGGSVP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, RWORK, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. +*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -251,10 +251,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -278,7 +278,7 @@ SUBROUTINE CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * August 2015 @@ -308,7 +308,6 @@ SUBROUTINE CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * .. Local Scalars .. LOGICAL FORWRD, WANTQ, WANTU, WANTV, LQUERY INTEGER I, J, LWKOPT - COMPLEX T * .. * .. External Functions .. LOGICAL LSAME diff --git a/lapack-netlib/SRC/cgsvj0.f b/lapack-netlib/SRC/cgsvj0.f index 79ffde6233..ca817159c1 100644 --- a/lapack-netlib/SRC/cgsvj0.f +++ b/lapack-netlib/SRC/cgsvj0.f @@ -1,26 +1,26 @@ -*> \brief \b CGSVJ0 pre-processor for the routine sgesvj. +*> \brief \b CGSVJ0 pre-processor for the routine cgesvj. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGSVJ0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP * REAL EPS, SFMIN, TOL @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) * REAL SVA( N ) * .. -* +* * *> \par Purpose: * ============= @@ -188,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -203,10 +203,10 @@ *> CGSVJ0 is used just to enable CGESVJ to call a simplified version of *> itself to work on a submatrix of the original matrix. *> -*> \par Contributors: +*> \par Contributor: * ================== *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> Zlatko Drmac (Zagreb, Croatia) *> *> \par Bugs, Examples and Comments: * ================================= @@ -218,10 +218,10 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * IMPLICIT NONE * .. Scalar Arguments .. @@ -231,7 +231,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * .. * .. Array Arguments .. COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) - REAL SVA( N ) + REAL SVA( N ) * .. * * ===================================================================== @@ -255,7 +255,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, AMAX1, CONJG, FLOAT, MIN0, SIGN, SQRT + INTRINSIC ABS, MAX, CONJG, REAL, MIN, SIGN, SQRT * .. * .. External Functions .. REAL SCNRM2 @@ -268,7 +268,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * .. External Subroutines .. * .. * from BLAS - EXTERNAL CCOPY, CROT, CSSCAL, CSWAP + EXTERNAL CCOPY, CROT, CSWAP * from LAPACK EXTERNAL CLASCL, CLASSQ, XERBLA * .. @@ -288,7 +288,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, INFO = -5 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN @@ -338,7 +338,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * The boundaries are determined dynamically, based on the number of * pivots above a threshold. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the @@ -350,7 +350,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, BLSKIP = KBL**2 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. * - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. * LKAHEAD = 1 @@ -384,18 +384,18 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * igl = ( ibr-1 )*KBL + 1 * - DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr ) + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * - DO 2001 p = igl, MIN0( igl+KBL-1, N-1 ) + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * * .. de Rijk's pivoting * q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL CSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) - IF( RSVEC )CALL CSWAP( MVL, V( 1, p ), 1, + IF( RSVEC )CALL CSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) @@ -419,7 +419,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * If properly implemented SCNRM2 is available, the IF-THEN-ELSE-END IF * below should be replaced with "AAPP = SCNRM2( M, A(1,p), 1 )". * - IF( ( SVA( p ).LT.ROOTBIG ) .AND. + IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = SCNRM2( M, A( 1, p ), 1 ) ELSE @@ -437,7 +437,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * PSKIPPED = 0 * - DO 2002 q = p + 1, MIN0( igl+KBL-1, N ) + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) * @@ -447,12 +447,12 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, + AAPQ = ( CDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE - CALL CCOPY( M, A( 1, p ), 1, + CALL CCOPY( M, A( 1, p ), 1, $ WORK, 1 ) - CALL CLASCL( 'G', 0, 0, AAPP, ONE, + CALL CLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, WORK, LDA, IERR ) AAPQ = CDOTC( M, WORK, 1, $ A( 1, q ), 1 ) / AAQQ @@ -460,27 +460,27 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( CDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / AAPP ) / AAQQ ELSE - CALL CCOPY( M, A( 1, q ), 1, + CALL CCOPY( M, A( 1, q ), 1, $ WORK, 1 ) CALL CLASCL( 'G', 0, 0, AAQQ, $ ONE, M, 1, $ WORK, LDA, IERR ) - AAPQ = CDOTC( M, A( 1, p ), 1, + AAPQ = CDOTC( M, A( 1, p ), 1, $ WORK, 1 ) / AAPP END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) - AAPQ1 = -ABS(AAPQ) - MXAAPQ = AMAX1( MXAAPQ, -AAPQ1 ) +* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) + AAPQ1 = -ABS(AAPQ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) * * .. rotate *[RTD] ROTATED = ROTATED + ONE @@ -498,47 +498,47 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, THETA = -HALF*ABS( AQOAP-APOAQ )/AAPQ1 * IF( ABS( THETA ).GT.BIGTHETA ) THEN -* +* T = HALF / THETA CS = ONE CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*T ) IF ( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -SIGN( ONE, AAPQ1 ) - T = ONE / ( THETA+THSIGN* + T = ONE / ( THETA+THSIGN* $ SQRT( ONE+THETA*THETA ) ) CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS * - MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*SN ) IF ( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) - END IF - END IF - D(p) = -D(q) * OMPQ + END IF + END IF + D(p) = -D(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -553,9 +553,9 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ A( 1, q ), 1 ) CALL CLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * @@ -619,7 +619,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) - $ NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE @@ -639,14 +639,14 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N ) + DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -663,7 +663,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, + AAPQ = ( CDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL CCOPY( M, A( 1, p ), 1, @@ -681,8 +681,9 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( CDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL CCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -694,14 +695,14 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = AMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -716,18 +717,18 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate @@ -738,16 +739,16 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SQRT( ONE+THETA*THETA ) ) CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL CROT( M, A(1,p), 1, A(1,q), 1, - $ CS, CONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF @@ -769,9 +770,9 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, CALL CLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL CCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -781,14 +782,14 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, CALL CLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL CAXPY( M, -CONJG(AAPQ), + CALL CAXPY( M, -CONJG(AAPQ), $ WORK, 1, A( 1, p ), 1 ) CALL CLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*SQRT( AMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -856,7 +857,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -867,7 +868,7 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -890,8 +891,8 @@ SUBROUTINE CGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( FLOAT( N ) )* - $ TOL ) .AND. ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( REAL( N ) )* + $ TOL ) .AND. ( REAL( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * diff --git a/lapack-netlib/SRC/cgsvj1.f b/lapack-netlib/SRC/cgsvj1.f index f4b1fc156e..1689caaa21 100644 --- a/lapack-netlib/SRC/cgsvj1.f +++ b/lapack-netlib/SRC/cgsvj1.f @@ -1,36 +1,36 @@ -*> \brief \b CGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivots. +*> \brief \b CGSVJ1 pre-processor for the routine cgesvj, applies Jacobi rotations targeting only particular pivots. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGSVJ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGSVJ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * REAL EPS, SFMIN, TOL * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP * CHARACTER*1 JOBV * .. * .. Array Arguments .. -* COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) -* REAL SVA( N ) +* COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) +* REAL SVA( N ) * .. -* +* * *> \par Purpose: * ============= @@ -105,7 +105,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is REAL array, dimension (LDA,N) +*> A is COMPLEX array, dimension (LDA,N) *> On entry, M-by-N matrix A, such that A*diag(D) represents *> the input matrix. *> On exit, @@ -124,7 +124,7 @@ *> *> \param[in,out] D *> \verbatim -*> D is REAL array, dimension (N) +*> D is COMPLEX array, dimension (N) *> The array D accumulates the scaling factors from the fast scaled *> Jacobi rotations. *> On entry, A*diag(D) represents the input matrix. @@ -154,7 +154,7 @@ *> *> \param[in,out] V *> \verbatim -*> V is REAL array, dimension (LDV,N) +*> V is COMPLEX array, dimension (LDV,N) *> If JOBV .EQ. 'V' then N rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a @@ -218,28 +218,28 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * -*> \par Contributors: +*> \par Contributor: * ================== *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> Zlatko Drmac (Zagreb, Croatia) * * ===================================================================== SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. REAL EPS, SFMIN, TOL @@ -248,7 +248,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. * .. Array Arguments .. COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) - REAL SVA( N ) + REAL SVA( N ) * .. * * ===================================================================== @@ -260,7 +260,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. Local Scalars .. COMPLEX AAPQ, OMPQ REAL AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, - $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, + $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T, $ TEMP1, THETA, THSIGN INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, @@ -270,7 +270,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, AMAX1, CONJG, FLOAT, MIN0, SIGN, SQRT + INTRINSIC ABS, MAX, CONJG, REAL, MIN, SIGN, SQRT * .. * .. External Functions .. REAL SCNRM2 @@ -280,8 +280,8 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EXTERNAL ISAMAX, LSAME, CDOTC, SCNRM2 * .. * .. External Subroutines .. -* .. from BLAS - EXTERNAL CCOPY, CROT, CSSCAL, CSWAP +* .. from BLAS + EXTERNAL CCOPY, CROT, CSWAP * .. from LAPACK EXTERNAL CLASCL, CLASSQ, XERBLA * .. @@ -303,7 +303,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, INFO = -6 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -9 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( TOL.LE.EPS ) THEN @@ -334,7 +334,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, SMALL = SFMIN / EPS BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN - LARGE = BIG / SQRT( FLOAT( M*N ) ) +* LARGE = BIG / SQRT( REAL( M*N ) ) BIGTHETA = ONE / ROOTEPS ROOTTOL = SQRT( TOL ) * @@ -347,7 +347,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * * .. Row-cyclic pivot strategy with de Rijk's pivoting .. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) NBLR = N1 / KBL IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1 @@ -358,7 +358,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, BLSKIP = ( KBL**2 ) + 1 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. SWBAND = 0 *[TP] SWBAND is a tuning parameter. It is meaningful and effective @@ -401,21 +401,21 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, igl = ( ibr-1 )*KBL + 1 * * DO 2010 jbc = ibr + 1, NBL - DO 2010 jbc = 1, NBLC + DO 2010 jbc = 1, NBLC * jgl = ( jbc-1 )*KBL + N1 + 1 * * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N1 ) + DO 2100 p = igl, MIN( igl+KBL-1, N1 ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -432,7 +432,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, + AAPQ = ( CDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL CCOPY( M, A( 1, p ), 1, @@ -450,8 +450,9 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( CDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( CDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL CCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -463,14 +464,14 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = AMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -485,18 +486,18 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL CROT( M, A(1,p), 1, A(1,q), 1, $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate @@ -507,16 +508,16 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ SQRT( ONE+THETA*THETA ) ) CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*SQRT( AMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL CROT( M, A(1,p), 1, A(1,q), 1, - $ CS, CONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL CROT( MVL, V(1,p), 1, + CALL CROT( MVL, V(1,p), 1, $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF @@ -538,9 +539,9 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, CALL CLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL CCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -550,14 +551,14 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, CALL CLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL CAXPY( M, -CONJG(AAPQ), + CALL CAXPY( M, -CONJG(AAPQ), $ WORK, 1, A( 1, p ), 1 ) CALL CLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*SQRT( AMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = AMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -625,7 +626,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -636,7 +637,7 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -659,8 +660,8 @@ SUBROUTINE CGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( FLOAT( N ) )* - $ TOL ) .AND. ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( REAL( N ) )* + $ TOL ) .AND. ( REAL( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * diff --git a/lapack-netlib/SRC/cgtcon.f b/lapack-netlib/SRC/cgtcon.f index 775277a4e8..ed3260532b 100644 --- a/lapack-netlib/SRC/cgtcon.f +++ b/lapack-netlib/SRC/cgtcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTcomputational * @@ -141,10 +141,10 @@ SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/cgtrfs.f b/lapack-netlib/SRC/cgtrfs.f index dd95d4060e..22979a721f 100644 --- a/lapack-netlib/SRC/cgtrfs.f +++ b/lapack-netlib/SRC/cgtrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTcomputational * @@ -210,10 +210,10 @@ SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgtsv.f b/lapack-netlib/SRC/cgtsv.f index 2f23fd7ee0..6063db0cd3 100644 --- a/lapack-netlib/SRC/cgtsv.f +++ b/lapack-netlib/SRC/cgtsv.f @@ -1,32 +1,32 @@ -*> \brief CGTSV computes the solution to system of linear equations A * X = B for GT matrices +*> \brief CGTSV computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTsolve * * ===================================================================== SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/cgtsvx.f b/lapack-netlib/SRC/cgtsvx.f index 9211e39f8f..5ebb25dad7 100644 --- a/lapack-netlib/SRC/cgtsvx.f +++ b/lapack-netlib/SRC/cgtsvx.f @@ -1,19 +1,19 @@ -*> \brief CGTSVX computes the solution to system of linear equations A * X = B for GT matrices +*> \brief CGTSVX computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, * DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * $ DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -280,12 +280,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTsolve * @@ -294,10 +294,10 @@ SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT, TRANS diff --git a/lapack-netlib/SRC/cgttrf.f b/lapack-netlib/SRC/cgttrf.f index acec054cdc..04a7a3f861 100644 --- a/lapack-netlib/SRC/cgttrf.f +++ b/lapack-netlib/SRC/cgttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTcomputational * * ===================================================================== SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/cgttrs.f b/lapack-netlib/SRC/cgttrs.f index 0ca3d81ad0..64d675c266 100644 --- a/lapack-netlib/SRC/cgttrs.f +++ b/lapack-netlib/SRC/cgttrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTcomputational * @@ -138,10 +138,10 @@ SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cgtts2.f b/lapack-netlib/SRC/cgtts2.f index 5c29afbdd7..68d81cae87 100644 --- a/lapack-netlib/SRC/cgtts2.f +++ b/lapack-netlib/SRC/cgtts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CGTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER ITRANS, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGTcomputational * * ===================================================================== SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ITRANS, LDB, N, NRHS diff --git a/lapack-netlib/SRC/chb2st_kernels.f b/lapack-netlib/SRC/chb2st_kernels.f new file mode 100644 index 0000000000..77ddaed5d4 --- /dev/null +++ b/lapack-netlib/SRC/chb2st_kernels.f @@ -0,0 +1,335 @@ +*> \brief \b CHB2ST_KERNELS +* +* @generated from zhb2st_kernels.f, fortran z -> c, Wed Dec 7 08:22:40 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHB2ST_KERNELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHB2ST_KERNELS( UPLO, WANTZ, TTYPE, +* ST, ED, SWEEP, N, NB, IB, +* A, LDA, V, TAU, LDVT, WORK) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* LOGICAL WANTZ +* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), V( * ), +* TAU( * ), WORK( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHB2ST_KERNELS is an internal routine used by the CHETRD_HB2ST +*> subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> @param[in] n +*> The order of the matrix A. +*> +*> @param[in] nb +*> The size of the band. +*> +*> @param[in, out] A +*> A pointer to the matrix A. +*> +*> @param[in] lda +*> The leading dimension of the matrix A. +*> +*> @param[out] V +*> COMPLEX array, dimension 2*n if eigenvalues only are +*> requested or to be queried for vectors. +*> +*> @param[out] TAU +*> COMPLEX array, dimension (2*n). +*> The scalar factors of the Householder reflectors are stored +*> in this array. +*> +*> @param[in] st +*> internal parameter for indices. +*> +*> @param[in] ed +*> internal parameter for indices. +*> +*> @param[in] sweep +*> internal parameter for indices. +*> +*> @param[in] Vblksiz +*> internal parameter for indices. +*> +*> @param[in] wantz +*> logical which indicate if Eigenvalue are requested or both +*> Eigenvalue/Eigenvectors. +*> +*> @param[in] work +*> Workspace of size nb. +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHB2ST_KERNELS( UPLO, WANTZ, TTYPE, + $ ST, ED, SWEEP, N, NB, IB, + $ A, LDA, V, TAU, LDVT, WORK) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + LOGICAL WANTZ + INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), V( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), + $ ONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, + $ DPOS, OFDPOS, AJETER + COMPLEX CTMP +* .. +* .. External Subroutines .. + EXTERNAL CLARFG, CLARFX, CLARFY +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MOD +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. +* .. Executable Statements .. +* + AJETER = IB + LDVT + UPPER = LSAME( UPLO, 'U' ) + + IF( UPPER ) THEN + DPOS = 2 * NB + 1 + OFDPOS = 2 * NB + ELSE + DPOS = 1 + OFDPOS = 2 + ENDIF + +* +* Upper case +* + IF( UPPER ) THEN +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 10 I = 1, LM-1 + V( VPOS+I ) = CONJG( A( OFDPOS-I, ST+I ) ) + A( OFDPOS-I, ST+I ) = ZERO + 10 CONTINUE + CTMP = CONJG( A( OFDPOS, ST ) ) + CALL CLARFG( LM, CTMP, V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) + A( OFDPOS, ST ) = CTMP +* + LM = ED - ST + 1 + CALL CLARFY( UPLO, LM, V( VPOS ), 1, + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.3 ) THEN +* + LM = ED - ST + 1 + CALL CLARFY( UPLO, LM, V( VPOS ), 1, + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 + IF( LM.GT.0) THEN + CALL CLARFX( 'Left', LN, LM, V( VPOS ), + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS-NB, J1 ), LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 30 I = 1, LM-1 + V( VPOS+I ) = + $ CONJG( A( DPOS-NB-I, J1+I ) ) + A( DPOS-NB-I, J1+I ) = ZERO + 30 CONTINUE + CTMP = CONJG( A( DPOS-NB, J1 ) ) + CALL CLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) + A( DPOS-NB, J1 ) = CTMP +* + CALL CLARFX( 'Right', LN-1, LM, V( VPOS ), + $ TAU( TAUPOS ), + $ A( DPOS-NB+1, J1 ), LDA-1, WORK) + ENDIF + ENDIF +* +* Lower case +* + ELSE +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 20 I = 1, LM-1 + V( VPOS+I ) = A( OFDPOS+I, ST-1 ) + A( OFDPOS+I, ST-1 ) = ZERO + 20 CONTINUE + CALL CLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + LM = ED - ST + 1 +* + CALL CLARFY( UPLO, LM, V( VPOS ), 1, + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.3 ) THEN + LM = ED - ST + 1 +* + CALL CLARFY( UPLO, LM, V( VPOS ), 1, + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 +* + IF( LM.GT.0) THEN + CALL CLARFX( 'Right', LM, LN, V( VPOS ), + $ TAU( TAUPOS ), A( DPOS+NB, ST ), + $ LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 40 I = 1, LM-1 + V( VPOS+I ) = A( DPOS+NB+I, ST ) + A( DPOS+NB+I, ST ) = ZERO + 40 CONTINUE + CALL CLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + CALL CLARFX( 'Left', LM, LN-1, V( VPOS ), + $ CONJG( TAU( TAUPOS ) ), + $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) + + ENDIF + ENDIF + ENDIF +* + RETURN +* +* END OF CHB2ST_KERNELS +* + END diff --git a/lapack-netlib/SRC/chbev.f b/lapack-netlib/SRC/chbev.f index f87a320a43..2e7022f1d5 100644 --- a/lapack-netlib/SRC/chbev.f +++ b/lapack-netlib/SRC/chbev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, N @@ -29,7 +29,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -152,10 +152,10 @@ SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chbev_2stage.f b/lapack-netlib/SRC/chbev_2stage.f new file mode 100644 index 0000000000..5ced8c9777 --- /dev/null +++ b/lapack-netlib/SRC/chbev_2stage.f @@ -0,0 +1,386 @@ +*> \brief CHBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from zhbev_2stage.f, fortran z -> c, Sat Nov 5 23:18:20 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHBEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* REAL RWORK( * ), W( * ) +* COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(1,3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. + REAL RWORK( * ), W( * ) + COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ, LQUERY + INTEGER IINFO, IMAX, INDE, INDWRK, INDRWK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHB + EXTERNAL LSAME, SLAMCH, CLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSTERF, XERBLA, CLASCL, CSTEQR, + $ CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'CHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -11 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHBEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = REAL( AB( 1, 1 ) ) + ELSE + W( 1 ) = REAL( AB( KD+1, 1 ) ) + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call CHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = 1 + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL CHETRD_HB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ RWORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + INDRWK = INDE + N + CALL CSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of CHBEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/chbevd.f b/lapack-netlib/SRC/chbevd.f index fa8f0c8e78..a54da4386b 100644 --- a/lapack-netlib/SRC/chbevd.f +++ b/lapack-netlib/SRC/chbevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -202,12 +202,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -215,10 +215,10 @@ SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -320,13 +320,13 @@ SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * Quick return if possible * IF( N.EQ.0 ) - $ RETURN + $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AB( 1, 1 ) IF( WANTZ ) $ Z( 1, 1 ) = CONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/chbevd_2stage.f b/lapack-netlib/SRC/chbevd_2stage.f new file mode 100644 index 0000000000..f8296a443c --- /dev/null +++ b/lapack-netlib/SRC/chbevd_2stage.f @@ -0,0 +1,458 @@ +*> \brief CHBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from zhbevd_2stage.f, fortran z -> c, Sat Nov 5 23:18:17 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHBEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, RWORK, LRWORK, IWORK, +* LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* REAL RWORK( * ), W( * ) +* COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it +*> uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, +*> dimension (LRWORK) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of array RWORK. +*> If N <= 1, LRWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. +*> If JOBZ = 'V' and N > 1, LRWORK must be at least +*> 1 + 5*N + 2*N**2. +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, RWORK, LRWORK, IWORK, + $ LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL RWORK( * ), W( * ) + COMPLEX AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), + $ CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDWK2, INDRWK, ISCALE, + $ LLWORK, INDWK, LHTRD, LWTRD, IB, INDHOUS, + $ LIWMIN, LLRWK, LLWK2, LRWMIN, LWMIN + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHB + EXTERNAL LSAME, SLAMCH, CLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSTERF, XERBLA, CGEMM, CLACPY, + $ CLASCL, CSTEDC, CHETRD_HB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LWMIN = 1 + LRWMIN = 1 + LIWMIN = 1 + ELSE + IB = ILAENV( 18, 'CHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LWMIN = 2*N**2 + LRWMIN = 1 + 5*N + 2*N**2 + LIWMIN = 3 + 5*N + ELSE + LWMIN = MAX( N, LHTRD + LWTRD ) + LRWMIN = N + LIWMIN = 1 + END IF + END IF + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHBEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = REAL( AB( 1, 1 ) ) + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call CHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDE = 1 + INDRWK = INDE + N + LLRWK = LRWORK - INDRWK + 1 + INDHOUS = 1 + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + INDWK2 = INDWK + N*N + LLWK2 = LWORK - INDWK2 + 1 +* + CALL CHETRD_HB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ RWORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ), + $ LLWK2, RWORK( INDRWK ), LLRWK, IWORK, LIWORK, + $ INFO ) + CALL CGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO, + $ WORK( INDWK2 ), N ) + CALL CLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of CHBEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/chbevx.f b/lapack-netlib/SRC/chbevx.f index d9a22e3504..c7060bbd70 100644 --- a/lapack-netlib/SRC/chbevx.f +++ b/lapack-netlib/SRC/chbevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N @@ -33,7 +33,7 @@ * COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -136,13 +139,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -246,12 +253,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexOTHEReigen * @@ -260,10 +267,10 @@ SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/chbevx_2stage.f b/lapack-netlib/SRC/chbevx_2stage.f new file mode 100644 index 0000000000..e2cb8ca5e3 --- /dev/null +++ b/lapack-netlib/SRC/chbevx_2stage.f @@ -0,0 +1,646 @@ +*> \brief CHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from zhbevx_2stage.f, fortran z -> c, Sat Nov 5 23:18:22 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHBEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, +* Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, +* Z, LDZ, WORK, LWORK, RWORK, IWORK, +* IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* REAL RWORK( * ), W( * ) +* COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors +*> can be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N unitary matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*SLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*SLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complexOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, + $ Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, + $ Z, LDZ, WORK, LWORK, RWORK, IWORK, + $ IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + REAL RWORK( * ), W( * ) + COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), + $ CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, + $ LQUERY + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ J, JJ, NSPLIT + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU + COMPLEX CTMP1 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHB + EXTERNAL LSAME, SLAMCH, CLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CCOPY, + $ CGEMV, CLACPY, CLASCL, CSTEIN, CSTEQR, + $ CSWAP, CHETRD_HB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'CHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -20 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHBEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + CTMP1 = AB( 1, 1 ) + ELSE + CTMP1 = AB( KD+1, 1 ) + END IF + TMP1 = REAL( CTMP1 ) + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = REAL( CTMP1 ) + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call CHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDRWK = INDE + N +* + INDHOUS = 1 + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL CHETRD_HB2ST( 'N', JOBZ, UPLO, N, KD, AB, LDAB, + $ RWORK( INDD ), RWORK( INDE ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call SSTERF or CSTEQR. If this fails for some +* eigenvalue, then try SSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL SCOPY( N, RWORK( INDD ), 1, W, 1 ) + INDEE = INDRWK + 2*N + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL SSTERF( N, W, RWORK( INDEE ), INFO ) + ELSE + CALL CLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWK = INDISP + N + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWK ), INFO ) +* + IF( WANTZ ) THEN + CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by CSTEIN. +* + DO 20 J = 1, M + CALL CCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL CGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of CHBEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/chbgst.f b/lapack-netlib/SRC/chbgst.f index b6a5de9da0..c84999834f 100644 --- a/lapack-netlib/SRC/chbgst.f +++ b/lapack-netlib/SRC/chbgst.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, * LDX, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N @@ -30,7 +30,7 @@ * COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -165,10 +165,10 @@ SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/chbgv.f b/lapack-netlib/SRC/chbgv.f index b4e3a87d5c..d20372e971 100644 --- a/lapack-netlib/SRC/chbgv.f +++ b/lapack-netlib/SRC/chbgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, * LDZ, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N @@ -30,7 +30,7 @@ * COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -183,10 +183,10 @@ SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chbgvd.f b/lapack-netlib/SRC/chbgvd.f index e57bd93752..a6d38f0c06 100644 --- a/lapack-netlib/SRC/chbgvd.f +++ b/lapack-netlib/SRC/chbgvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, * Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LRWORK, @@ -33,7 +33,7 @@ * COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -233,12 +233,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHEReigen * @@ -252,10 +252,10 @@ SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -372,7 +372,7 @@ SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, LLWK2 = LWORK - INDWK2 + 2 LLRWK = LRWORK - INDWRK + 2 CALL CHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, - $ WORK, RWORK( INDWRK ), IINFO ) + $ WORK, RWORK, IINFO ) * * Reduce Hermitian band matrix to tridiagonal form. * diff --git a/lapack-netlib/SRC/chbgvx.f b/lapack-netlib/SRC/chbgvx.f index 5e28cc88fd..db4632eb8f 100644 --- a/lapack-netlib/SRC/chbgvx.f +++ b/lapack-netlib/SRC/chbgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, * LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, * LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, @@ -34,7 +34,7 @@ * COMPLEX AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,13 +153,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -167,14 +171,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -272,12 +281,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHEReigen * @@ -291,10 +300,10 @@ SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/chbtrd.f b/lapack-netlib/SRC/chbtrd.f index a88d4d1a0f..126cc123ba 100644 --- a/lapack-netlib/SRC/chbtrd.f +++ b/lapack-netlib/SRC/chbtrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHBTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHBTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KD, LDAB, LDQ, N @@ -29,7 +29,7 @@ * REAL D( * ), E( * ) * COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/checon.f b/lapack-netlib/SRC/checon.f index 499c6740df..d305232723 100644 --- a/lapack-netlib/SRC/checon.f +++ b/lapack-netlib/SRC/checon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -125,10 +125,10 @@ SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/checon_3.f b/lapack-netlib/SRC/checon_3.f new file mode 100644 index 0000000000..8b18dacdb4 --- /dev/null +++ b/lapack-netlib/SRC/checon_3.f @@ -0,0 +1,285 @@ +*> \brief \b CHECON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHECON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* COMPLEX A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHECON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex Hermitian matrix A using the factorization +*> computed by CHETRF_RK or CHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver CHETRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_RK or CHETRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CHETRS_3, CLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHECON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**H) or inv(U*D*U**H). +* + CALL CHETRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of CHECON_3 +* + END diff --git a/lapack-netlib/SRC/checon_rook.f b/lapack-netlib/SRC/checon_rook.f index b986387b64..0fe4ffebab 100644 --- a/lapack-netlib/SRC/checon_rook.f +++ b/lapack-netlib/SRC/checon_rook.f @@ -1,4 +1,4 @@ -*> \brief \b CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +*> \brief CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) * * =========== DOCUMENTATION =========== * @@ -117,7 +117,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -125,7 +125,7 @@ * ================== *> \verbatim *> -*> November 2013, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -139,10 +139,10 @@ SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cheequb.f b/lapack-netlib/SRC/cheequb.f index b526ad2252..f324a08c4c 100644 --- a/lapack-netlib/SRC/cheequb.f +++ b/lapack-netlib/SRC/cheequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), WORK( * ) * REAL S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -37,12 +37,11 @@ *> \verbatim *> *> CHEEQUB computes row and column scalings intended to equilibrate a -*> Hermitian matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> Hermitian matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -52,28 +51,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) -*> The N-by-N Hermitian matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N Hermitian matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -86,21 +84,21 @@ *> \verbatim *> SCOND is REAL *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is REAL -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension (3*N) +*> WORK is COMPLEX array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -114,19 +112,27 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * *> \ingroup complexHEcomputational * +*> \par References: +* ================ +*> +*> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n +*> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n +*> DOI 10.1023/B:NUMA.0000016606.32820.69 \n +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 +*> * ===================================================================== SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -145,14 +151,14 @@ SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * .. Parameters .. REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) INTEGER MAX_ITER PARAMETER ( MAX_ITER = 100 ) * .. * .. Local Scalars .. INTEGER I, J, ITER - REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, - $ BASE, SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ LOGICAL UP COMPLEX ZDUM * .. @@ -172,20 +178,22 @@ SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. * .. Statement Function Definitions .. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. * -* Test input parameters. +* Test the input parameters. * INFO = 0 - IF (.NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'CHEEQUB', -INFO ) - RETURN + CALL XERBLA( 'CHEEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -194,12 +202,12 @@ SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -220,102 +228,100 @@ SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) DO I = J+1, N S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) - AMAX = MAX( AMAX, CABS1( A(I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO END DO END IF DO J = 1, N - S( J ) = 1.0 / S( J ) + S( J ) = 1.0E0 / S( J ) END DO TOL = ONE / SQRT( 2.0E0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0 - SUMSQ = 0.0 -* beta = |A|s - DO I = 1, N - WORK( I ) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - DO I = J+1, N - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - END DO - END IF + SCALE = 0.0E0 + SUMSQ = 0.0E0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF -* avg = s^T beta / n - AVG = 0.0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N +* avg = s^T beta / n + AVG = 0.0E0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - STD = 0.0 - DO I = 2*N+1, 3*N - WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG - END DO - CALL CLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + STD = 0.0E0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL CLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( STD .LT. TOL * AVG ) GOTO 999 + IF ( STD .LT. TOL * AVG ) GOTO 999 - DO I = 1, N - T = CABS1( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - D = C1*C1 - 4*C0*C2 - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - D = SI - S(I) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -328,10 +334,10 @@ SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BASE = SLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) - +* END diff --git a/lapack-netlib/SRC/cheev.f b/lapack-netlib/SRC/cheev.f index 6e62bbfe92..913c032b7f 100644 --- a/lapack-netlib/SRC/cheev.f +++ b/lapack-netlib/SRC/cheev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -29,7 +29,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEeigen * @@ -140,10 +140,10 @@ SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/cheev_2stage.f b/lapack-netlib/SRC/cheev_2stage.f new file mode 100644 index 0000000000..55a0ed60a5 --- /dev/null +++ b/lapack-netlib/SRC/cheev_2stage.f @@ -0,0 +1,355 @@ +*> \brief CHEEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @generated from zheev_2stage.f, fortran z -> c, Sat Nov 5 23:18:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHEEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* REAL RWORK( * ), W( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(1, 3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + REAL RWORK( * ), W( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHE + EXTERNAL LSAME, ILAENV, SLAMCH, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSTERF, XERBLA, CLASCL, CSTEQR, + $ CUNGTR, CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'CHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'CHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHEEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = REAL( A( 1, 1 ) ) + WORK( 1 ) = 1 + IF( WANTZ ) + $ A( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = CLANHE( 'M', UPLO, N, A, LDA, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL CLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call CHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDE = 1 + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL CHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, first call +* CUNGTR to generate the unitary matrix, then call CSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL CUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + INDWRK = INDE + N + CALL CSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, + $ RWORK( INDWRK ), INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal complex workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of CHEEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/cheevd.f b/lapack-netlib/SRC/cheevd.f index b3f166062d..ff89c2961c 100644 --- a/lapack-netlib/SRC/cheevd.f +++ b/lapack-netlib/SRC/cheevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -181,12 +181,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEeigen * @@ -205,10 +205,10 @@ SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -306,7 +306,7 @@ SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CHEEVD', -INFO ) - RETURN + RETURN ELSE IF( LQUERY ) THEN RETURN END IF diff --git a/lapack-netlib/SRC/cheevd_2stage.f b/lapack-netlib/SRC/cheevd_2stage.f new file mode 100644 index 0000000000..56e2bac5cf --- /dev/null +++ b/lapack-netlib/SRC/cheevd_2stage.f @@ -0,0 +1,451 @@ +*> \brief CHEEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @generated from zheevd_2stage.f, fortran z -> c, Sat Nov 5 23:18:14 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHEEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHEEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* RWORK, LRWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* REAL RWORK( * ), W( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N+1 +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N+1 +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, +*> dimension (LRWORK) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> If N <= 1, LRWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. +*> If JOBZ = 'V' and N > 1, LRWORK must be at least +*> 1 + 5*N + 2*N**2. +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEeigen +* +*> \par Further Details: +* ===================== +*> +*> Modified description of INFO. Sven, 16 Feb 05. +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHEEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ RWORK, LRWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL RWORK( * ), W( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, + $ INDWRK, ISCALE, LIWMIN, LLRWK, LLWORK, + $ LLWRK2, LRWMIN, LWMIN, + $ LHTRD, LWTRD, KD, IB, INDHOUS + + + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHE + EXTERNAL LSAME, ILAENV, SLAMCH, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSTERF, XERBLA, CLACPY, CLASCL, + $ CSTEDC, CUNMTR, CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + LRWMIN = 1 + LIWMIN = 1 + ELSE + KD = ILAENV( 17, 'CHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'CHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LWMIN = 2*N + N*N + LRWMIN = 1 + 5*N + 2*N**2 + LIWMIN = 3 + 5*N + ELSE + LWMIN = N + 1 + LHTRD + LWTRD + LRWMIN = N + LIWMIN = 1 + END IF + END IF + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHEEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = REAL( A( 1, 1 ) ) + IF( WANTZ ) + $ A( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = CLANHE( 'M', UPLO, N, A, LDA, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL CLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call CHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDE = 1 + INDRWK = INDE + N + LLRWK = LRWORK - INDRWK + 1 + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL CHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, first call +* CSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call CUNMTR to multiply it to the +* Householder transformations represented as Householder vectors in +* A. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, + $ IWORK, LIWORK, INFO ) + CALL CUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL CLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of CHEEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/cheevr.f b/lapack-netlib/SRC/cheevr.f index 18dfe4313a..0b055baf66 100644 --- a/lapack-netlib/SRC/cheevr.f +++ b/lapack-netlib/SRC/cheevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, * RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, @@ -33,7 +33,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -168,13 +171,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -250,7 +257,9 @@ *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through -*> ISUPPZ( 2*i ). +*> ISUPPZ( 2*i ). This is an output of CSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the unitary transformations applied by CUNMTR. *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> @@ -324,12 +333,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexHEeigen * @@ -348,10 +357,10 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -617,7 +626,7 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ IWORK, LIWORK, INFO ) * * Apply unitary matrix used in reduction to tridiagonal -* form to eigenvectors returned by CSTEIN. +* form to eigenvectors returned by CSTEMR. * IF( WANTZ .AND. INFO.EQ.0 ) THEN INDWKN = INDWK diff --git a/lapack-netlib/SRC/cheevr_2stage.f b/lapack-netlib/SRC/cheevr_2stage.f new file mode 100644 index 0000000000..361addd1e4 --- /dev/null +++ b/lapack-netlib/SRC/cheevr_2stage.f @@ -0,0 +1,779 @@ +*> \brief CHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @generated from zheevr_2stage.f, fortran z -> c, Sat Nov 5 23:18:11 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHEEVR_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, +* WORK, LWORK, RWORK, LRWORK, IWORK, +* LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, +* $ M, N +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* REAL RWORK( * ), W( * ) +* COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> CHEEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call +*> to CHETRD. Then, whenever possible, CHEEVR_2STAGE calls CSTEMR to compute +*> eigenspectrum using Relatively Robust Representations. CSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see DSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : CHEEVR_2STAGE calls CSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> CHEEVR_2STAGE calls SSTEBZ and CSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of CSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and +*> CSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> SLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> furutre releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of CSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the unitary transformations applied by CUNMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 26*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal +*> (and minimal) LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The length of the array RWORK. LRWORK >= max(1,24*N). +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal +*> (and minimal) LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complexHEeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, + $ WORK, LWORK, RWORK, LRWORK, IWORK, + $ LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, + $ M, N + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + REAL RWORK( * ), W( * ) + COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ, TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, + $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, + $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, + $ LWMIN, NSPLIT, LHTRD, LWTRD, KD, IB, INDHOUS + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANSY + EXTERNAL LSAME, ILAENV, SLAMCH, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CSSCAL, + $ CHETRD_2STAGE, CSTEMR, CSTEIN, CSWAP, CUNMTR +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'CHEEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR. + $ ( LIWORK.EQ.-1 ) ) +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + LRWMIN = MAX( 1, 24*N ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -22 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHEEVR_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 2 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = REAL( A( 1, 1 ) ) + ELSE + IF( VL.LT.REAL( A( 1, 1 ) ) .AND. VU.GE.REAL( A( 1, 1 ) ) ) + $ THEN + M = 1 + W( 1 ) = REAL( A( 1, 1 ) ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = CLANSY( 'M', UPLO, N, A, LDA, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL CSSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL CSSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if SSTERF or CSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the +* elementary reflectors used in CHETRD. + INDTAU = 1 +* INDWK is the starting offset of the remaining complex workspace, +* and LLWORK is the remaining complex workspace size. + INDHOUS = INDTAU + N + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + +* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal +* entries. + INDRD = 1 +* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from CHETRD. + INDRE = INDRD + N +* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over +* -written by CSTEMR (the SSTERF path copies the diagonal to W). + INDRDD = INDRE + N +* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in SSTERF and CSTEMR. + INDREE = INDRDD + N +* INDRWK is the starting offset of the left-over real workspace, and +* LLRWORK is the remaining workspace size. + INDRWK = INDREE + N + LLRWORK = LRWORK - INDRWK + 1 + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* CSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call CHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + CALL CHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDRD ), + $ RWORK( INDRE ), WORK( INDTAU ), + $ WORK( INDHOUS ), LHTRD, + $ WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call SSTERF or CSTEMR and CUNMTR. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) + CALL SSTERF( N, W, RWORK( INDREE ), INFO ) + ELSE + CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) + CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL CSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + $ RWORK( INDREE ), VL, VU, IL, IU, M, W, + $ Z, LDZ, N, ISUPPZ, TRYRAC, + $ RWORK( INDRWK ), LLRWORK, + $ IWORK, LIWORK, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by CSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDWK + LLWRKN = LWORK - INDWKN + 1 + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. +* Also call SSTEBZ and CSTEIN if CSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL CSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by CSTEIN. +* + INDWKN = INDWK + LLWRKN = LWORK - INDWKN + 1 + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of CHEEVR_2STAGE +* + END diff --git a/lapack-netlib/SRC/cheevx.f b/lapack-netlib/SRC/cheevx.f index 12f69ccc92..e2a2c3d765 100644 --- a/lapack-netlib/SRC/cheevx.f +++ b/lapack-netlib/SRC/cheevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N @@ -32,7 +32,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,12 +99,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -112,13 +115,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -238,12 +245,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexHEeigen * @@ -252,10 +259,10 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/cheevx_2stage.f b/lapack-netlib/SRC/cheevx_2stage.f new file mode 100644 index 0000000000..002dddb457 --- /dev/null +++ b/lapack-netlib/SRC/cheevx_2stage.f @@ -0,0 +1,618 @@ +*> \brief CHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @generated from zheevx_2stage.f, fortran z -> c, Sat Nov 5 23:18:09 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHEEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, RWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* REAL RWORK( * ), W( * ) +* COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*SLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*SLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 8*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complexHEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, RWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + REAL RWORK( * ), W( * ) + COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, + $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, CLANHE + EXTERNAL LSAME, ILAENV, SLAMCH, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CSSCAL, + $ CLACPY, CSTEIN, CSTEQR, CSWAP, CUNGTR, CUNMTR, + $ CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + KD = ILAENV( 17, 'CHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'CHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHEEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = REAL( A( 1, 1 ) ) + ELSE IF( VALEIG ) THEN + IF( VL.LT.REAL( A( 1, 1 ) ) .AND. VU.GE.REAL( A( 1, 1 ) ) ) + $ THEN + M = 1 + W( 1 ) = REAL( A( 1, 1 ) ) + END IF + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = CLANHE( 'M', UPLO, N, A, LDA, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL CSSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL CSSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call CHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDRWK = INDE + N + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL CHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDD ), + $ RWORK( INDE ), WORK( INDTAU ), + $ WORK( INDHOUS ), LHTRD, WORK( INDWRK ), + $ LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call SSTERF or CUNGTR and CSTEQR. If this fails for +* some eigenvalue, then try SSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL SCOPY( N, RWORK( INDD ), 1, W, 1 ) + INDEE = INDRWK + 2*N + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL SSTERF( N, W, RWORK( INDEE ), INFO ) + ELSE + CALL CLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL CUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWK = INDISP + N + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWK ), INFO ) +* + IF( WANTZ ) THEN + CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by CSTEIN. +* + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal complex workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of CHEEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/chegs2.f b/lapack-netlib/SRC/chegs2.f index 7462a4ad3a..68d2f66257 100644 --- a/lapack-netlib/SRC/chegs2.f +++ b/lapack-netlib/SRC/chegs2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chegst.f b/lapack-netlib/SRC/chegst.f index e4791b5595..2f933729c3 100644 --- a/lapack-netlib/SRC/chegst.f +++ b/lapack-netlib/SRC/chegst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chegv.f b/lapack-netlib/SRC/chegv.f index d7dde7639b..16b3a434e1 100644 --- a/lapack-netlib/SRC/chegv.f +++ b/lapack-netlib/SRC/chegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N @@ -29,7 +29,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexHEeigen * @@ -181,10 +181,10 @@ SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chegv_2stage.f b/lapack-netlib/SRC/chegv_2stage.f new file mode 100644 index 0000000000..11956def5f --- /dev/null +++ b/lapack-netlib/SRC/chegv_2stage.f @@ -0,0 +1,379 @@ +*> \brief \b CHEGV_2STAGE +* +* @generated from zhegv_2stage.f, fortran z -> c, Sun Nov 6 13:09:52 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHEGV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHEGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, +* WORK, LWORK, RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* REAL RWORK( * ), W( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors +*> of a complex generalized Hermitian-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be Hermitian and B is also +*> positive definite. +*> This routine use the 2stage technique for the reduction to tridiagonal +*> which showed higher performance on recent architecture and for large +* sizes N>2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**H*B*Z = I; +*> if ITYPE = 3, Z**H*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB, N) +*> On entry, the Hermitian positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**H*U or B = L*L**H. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(1, 3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: CPOTRF or CHEEV returned an error code: +*> <= N: if INFO = i, CHEEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHEGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, + $ WORK, LWORK, RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + REAL RWORK( * ), W( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER NEIG, LWMIN, LHTRD, LWTRD, KD, IB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHEGST, CPOTRF, CTRMM, CTRSM, + $ CHEEV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'CHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'CHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHEGV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL CPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL CHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, + $ WORK, LWORK, RWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'C' + END IF +* + CALL CTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**H *y +* + IF( UPPER ) THEN + TRANS = 'C' + ELSE + TRANS = 'N' + END IF +* + CALL CTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of CHEGV_2STAGE +* + END diff --git a/lapack-netlib/SRC/chegvd.f b/lapack-netlib/SRC/chegvd.f index 9114ebdd47..38b234174e 100644 --- a/lapack-netlib/SRC/chegvd.f +++ b/lapack-netlib/SRC/chegvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -220,12 +220,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexHEeigen * @@ -249,10 +249,10 @@ SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chegvx.f b/lapack-netlib/SRC/chegvx.f index 33a4e5f4a8..bf153f50a4 100644 --- a/lapack-netlib/SRC/chegvx.f +++ b/lapack-netlib/SRC/chegvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHEGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHEGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, * VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, * LWORK, RWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,13 +132,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -146,14 +150,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -279,12 +288,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexHEeigen * @@ -298,10 +307,10 @@ SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/cherfs.f b/lapack-netlib/SRC/cherfs.f index e1d15c08a1..14844825e4 100644 --- a/lapack-netlib/SRC/cherfs.f +++ b/lapack-netlib/SRC/cherfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -179,12 +179,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -192,10 +192,10 @@ SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cherfsx.f b/lapack-netlib/SRC/cherfsx.f index e596b9c347..4ed2c99f70 100644 --- a/lapack-netlib/SRC/cherfsx.f +++ b/lapack-netlib/SRC/cherfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) -* +* * *> \par Purpose: * ============= @@ -386,10 +386,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -401,7 +401,7 @@ SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -461,12 +461,11 @@ SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL SLAMCH, CLANHE, CLA_HERCOND_X, CLA_HERCOND_C REAL SLAMCH, CLANHE, CLA_HERCOND_X, CLA_HERCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/chesv.f b/lapack-netlib/SRC/chesv.f index 9d3a4066ed..261cbbe9ea 100644 --- a/lapack-netlib/SRC/chesv.f +++ b/lapack-netlib/SRC/chesv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEsolve * @@ -171,10 +171,10 @@ SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chesv_aa.f b/lapack-netlib/SRC/chesv_aa.f new file mode 100644 index 0000000000..d08740559a --- /dev/null +++ b/lapack-netlib/SRC/chesv_aa.f @@ -0,0 +1,254 @@ +*> \brief CHESV_AA computes the solution to system of linear equations A * X = B for HE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHESV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHESV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHESV_AA computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**H, if UPLO = 'U', or +*> A = L * T * L**H, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is Hermitian and tridiagonal. The factored form +*> of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**H or A = L*T*L**H as computed by +*> CHETRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for best +*> performance LWORK >= MAX(1,N*NB), where NB is the optimal +*> blocksize for CHETRF. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEsolve +* +* ===================================================================== + SUBROUTINE CHESV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_HETRF, LWKOPT_HETRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHETRF, CHETRS, CHETRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL CHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_HETRF = INT( WORK(1) ) + CALL CHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_HETRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_HETRF, LWKOPT_HETRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHESV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**H or A = L*T*L**H. +* + CALL CHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL CHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CHESV_AA +* + END diff --git a/lapack-netlib/SRC/chesv_rk.f b/lapack-netlib/SRC/chesv_rk.f new file mode 100644 index 0000000000..f1ff523616 --- /dev/null +++ b/lapack-netlib/SRC/chesv_rk.f @@ -0,0 +1,316 @@ +*> \brief CHESV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHESV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHESV_RK computes the solution to a complex system of linear +*> equations A * X = B, where A is an N-by-N Hermitian matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**H)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CHETRF_RK is called to compute the factorization of a complex +*> Hermitian matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine CHETRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by CHETRF_RK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of CHETRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine CHETRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of CHETRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CHETRF_RK. +*> +*> For more info see the description of CHETRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for CHETRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHETRF_RK, CHETRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHESV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CHESV_RK +* + END diff --git a/lapack-netlib/SRC/chesvx.f b/lapack-netlib/SRC/chesvx.f index fd2703962f..b3b1e9ca5a 100644 --- a/lapack-netlib/SRC/chesvx.f +++ b/lapack-netlib/SRC/chesvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,10 +271,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -285,7 +285,7 @@ SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/chesvxx.f b/lapack-netlib/SRC/chesvxx.f index 5b5df0f131..3f4466d416 100644 --- a/lapack-netlib/SRC/chesvxx.f +++ b/lapack-netlib/SRC/chesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -494,10 +494,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -509,7 +509,7 @@ SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -554,7 +554,7 @@ SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, REAL SLAMCH, CLA_HERPVGRW * .. * .. External Subroutines .. - EXTERNAL CHECON, CHEEQUB, CHETRF, CHETRS, CLACPY, + EXTERNAL CHEEQUB, CHETRF, CHETRS, CLACPY, $ CLAQHE, XERBLA, CLASCL2, CHERFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/cheswapr.f b/lapack-netlib/SRC/cheswapr.f index 03bf14b8c4..f251b9205f 100644 --- a/lapack-netlib/SRC/cheswapr.f +++ b/lapack-netlib/SRC/cheswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHESWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHESWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHESWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * COMPLEX A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEauxiliary * * ===================================================================== SUBROUTINE CHESWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,14 +136,14 @@ SUBROUTINE CHESWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL CSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) * - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 * - swap A(I2,I1) and A(I1,I2) - + TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -169,12 +169,12 @@ SUBROUTINE CHESWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from 1 to I1-1 +* - swap row I1 and I2 from 1 to I1-1 CALL CSWAP ( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 * - swap A(I2,I1) and A(I1,I2) TMP=A(I1,I1) @@ -198,6 +198,6 @@ SUBROUTINE CHESWAPR( UPLO, N, A, LDA, I1, I2) END DO * ENDIF - + END SUBROUTINE CHESWAPR diff --git a/lapack-netlib/SRC/chetd2.f b/lapack-netlib/SRC/chetd2.f index bf562e0dda..b80bfec5c3 100644 --- a/lapack-netlib/SRC/chetd2.f +++ b/lapack-netlib/SRC/chetd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -175,10 +175,10 @@ * ===================================================================== SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetf2.f b/lapack-netlib/SRC/chetf2.f index 6f7fa32146..15585bd2f8 100644 --- a/lapack-netlib/SRC/chetf2.f +++ b/lapack-netlib/SRC/chetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetf2_rk.f b/lapack-netlib/SRC/chetf2_rk.f new file mode 100644 index 0000000000..38a0ce3734 --- /dev/null +++ b/lapack-netlib/SRC/chetf2_rk.f @@ -0,0 +1,1039 @@ +*> \brief \b CHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHETF2_RK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ) +* .. +* +* ====================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE, UPPER + INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP, + $ P + REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, STEMP, + $ ROWMAX, TT, SFMIN + COMPLEX D12, D21, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. +* + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH, SLAPY2 + EXTERNAL LSAME, ICAMAX, SLAMCH, SLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSSCAL, CHER, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**H using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( A( K, K ) ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the leading submatrix A(1:k,1:k) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.GT.1 ) + $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 14 J = P + 1, K - 1 + T = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( P, J ) ) + A( P, J ) = T + 14 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = CONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( K, K ) ) + A( K, K ) = REAL( A( P, P ) ) + A( P, P ) = R1 +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the leading submatrix A(1:k,1:k) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 15 J = KP + 1, KK - 1 + T = CONJG( A( J, KK ) ) + A( J, KK ) = CONJG( A( KP, J ) ) + A( KP, J ) = T + 15 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = CONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( KK, KK ) ) + A( KK, KK ) = REAL( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) +* (5) Swap row elements + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K-1, K-1 ) = REAL( A( K-1, K-1 ) ) + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / REAL( A( K, K ) ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL CSSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = REAL( A( K, K ) ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* D = |A12| + D = SLAPY2( REAL( A( K-1, K ) ), + $ AIMAG( A( K-1, K ) ) ) + D11 = A( K, K ) / D + D22 = A( K-1, K-1 ) / D + D12 = A( K-1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) + WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) +* +* Perform a rank-2 update of A(1:k-2,1:k-2) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*CONJG( WK ) - + $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D + A( J, K-1 ) = WKM1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = CZERO + A( K-1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**H using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( A( K, K ) ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 42 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the trailing submatrix A(k:n,k:n) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.LT.N ) + $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 44 J = K + 1, P - 1 + T = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( P, J ) ) + A( P, J ) = T + 44 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = CONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( K, K ) ) + A( K, K ) = REAL( A( P, P ) ) + A( P, P ) = R1 +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the trailing submatrix A(k:n,k:n) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 45 J = KK + 1, KP - 1 + T = CONJG( A( J, KK ) ) + A( J, KK ) = CONJG( A( KP, J ) ) + A( KP, J ) = T + 45 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = CONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( KK, KK ) ) + A( KK, KK ) = REAL( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) +* (5) Swap row elements + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K+1, K+1 ) = REAL( A( K+1, K+1 ) ) + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of A now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* +* Handle division by a small number +* + IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / REAL( A( K, K ) ) + CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL CSSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = REAL( A( K, K ) ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* D = |A21| + D = SLAPY2( REAL( A( K+1, K ) ), + $ AIMAG( A( K+1, K ) ) ) + D11 = REAL( A( K+1, K+1 ) ) / D + D22 = REAL( A( K, K ) ) / D + D21 = A( K+1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) + WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*CONJG( WK ) - + $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D + A( J, K+1 ) = WKP1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = CZERO + A( K+1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of CHETF2_RK +* + END diff --git a/lapack-netlib/SRC/chetrd.f b/lapack-netlib/SRC/chetrd.f index d95fb4905c..22ea3516e5 100644 --- a/lapack-netlib/SRC/chetrd.f +++ b/lapack-netlib/SRC/chetrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * REAL D( * ), E( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetrd_2stage.f b/lapack-netlib/SRC/chetrd_2stage.f new file mode 100644 index 0000000000..56d55f6e95 --- /dev/null +++ b/lapack-netlib/SRC/chetrd_2stage.f @@ -0,0 +1,337 @@ +*> \brief \b CHETRD_2STAGE +* +* @generated from zhetrd_2stage.f, fortran z -> c, Sun Nov 6 19:34:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, +* HOUS2, LHOUS2, WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER VECT, UPLO +* INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. +* REAL D( * ), E( * ) +* COMPLEX A( LDA, * ), TAU( * ), +* HOUS2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRD_2STAGE reduces a complex Hermitian matrix A to real symmetric +*> tridiagonal form T by a unitary similarity transformation: +*> Q1**H Q2**H* A * Q2 * Q1 = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> in particular for the second stage (Band to +*> tridiagonal) and thus LHOUS2 is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate Q1 Q2 or to apply Q1 Q2, +*> then LHOUS2 is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the band superdiagonal +*> of A are overwritten by the corresponding elements of the +*> internal band-diagonal matrix AB, and the elements above +*> the KD superdiagonal, with the array TAU, represent the unitary +*> matrix Q1 as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and band subdiagonal of A are over- +*> written by the corresponding elements of the internal band-diagonal +*> matrix AB, and the elements below the KD subdiagonal, with +*> the array TAU, represent the unitary matrix Q1 as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (N-KD) +*> The scalar factors of the elementary reflectors of +*> the first stage (see Further Details). +*> \endverbatim +*> +*> \param[out] HOUS2 +*> \verbatim +*> HOUS2 is COMPLEX array, dimension LHOUS2, that +*> store the Householder representation of the stage2 +*> band to tridiagonal. +*> \endverbatim +*> +*> \param[in] LHOUS2 +*> \verbatim +*> LHOUS2 is INTEGER +*> The dimension of the array HOUS2. LHOUS2 = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS2 array, returns +*> this value as the first entry of the HOUS2 array, and no error +*> message related to LHOUS2 is issued by XERBLA. +*> LHOUS2 = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, + $ HOUS2, LHOUS2, WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER VECT, UPLO + INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. + REAL D( * ), E( * ) + COMPLEX A( LDA, * ), TAU( * ), + $ HOUS2( * ), WORK( * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTQ + INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHETRD_HE2HB, CHETRD_HB2ST +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + KD = ILAENV( 17, 'CHETRD_2STAGE', VECT, N, -1, -1, -1 ) + IB = ILAENV( 18, 'CHETRD_2STAGE', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'CHETRD_2STAGE', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'CHETRD_2STAGE', VECT, N, KD, IB, -1 ) +* WRITE(*,*),'CHETRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, +* $ LHMIN, LWMIN +* + IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDAB = KD+1 + LWRK = LWORK-LDAB*N + ABPOS = 1 + WPOS = ABPOS + LDAB*N + CALL CHETRD_HE2HB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, + $ TAU, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRD_HE2HB', -INFO ) + RETURN + END IF + CALL CHETRD_HB2ST( 'Y', VECT, UPLO, N, KD, + $ WORK( ABPOS ), LDAB, D, E, + $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRD_HB2ST', -INFO ) + RETURN + END IF +* +* + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of CHETRD_2STAGE +* + END diff --git a/lapack-netlib/SRC/chetrd_hb2st.F b/lapack-netlib/SRC/chetrd_hb2st.F new file mode 100644 index 0000000000..83c5c262a9 --- /dev/null +++ b/lapack-netlib/SRC/chetrd_hb2st.F @@ -0,0 +1,587 @@ +*> \brief \b CHBTRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHBTRD_HB2ST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRD_HB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, +* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* #if defined(_OPENMP) +* use omp_lib +* #endif +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER STAGE1, UPLO, VECT +* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. +* REAL D( * ), E( * ) +* COMPLEX AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric +*> tridiagonal form T by a unitary similarity transformation: +*> Q**H * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] STAGE +*> \verbatim +*> STAGE is CHARACTER*1 +*> = 'N': "No": to mention that the stage 1 of the reduction +*> from dense to band using the chetrd_he2hb routine +*> was not called before this routine to reproduce AB. +*> In other term this routine is called as standalone. +*> = 'Y': "Yes": to mention that the stage 1 of the +*> reduction from dense to band using the chetrd_he2hb +*> routine has been called to produce AB (e.g., AB is +*> the output of chetrd_he2hb. +*> \endverbatim +*> +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> and thus LHOUS is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate or to apply Q later on, +*> then LHOUS is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] HOUS +*> \verbatim +*> HOUS is COMPLEX array, dimension LHOUS, that +*> store the Householder representation. +*> \endverbatim +*> +*> \param[in] LHOUS +*> \verbatim +*> LHOUS is INTEGER +*> The dimension of the array HOUS. LHOUS = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS array, returns +*> this value as the first entry of the HOUS array, and no error +*> message related to LHOUS is issued by XERBLA. +*> LHOUS = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHETRD_HB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, + $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* +#if defined(_OPENMP) + use omp_lib +#endif +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER STAGE1, UPLO, VECT + INTEGER N, KD, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. + REAL D( * ), E( * ) + COMPLEX AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL RZERO + COMPLEX ZERO, ONE + PARAMETER ( RZERO = 0.0E+0, + $ ZERO = ( 0.0E+0, 0.0E+0 ), + $ ONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 + INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, + $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, + $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, + $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, + $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, + $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, + $ SICEV, SIZETAU, LDV, LHMIN, LWMIN + REAL ABSTMP + COMPLEX TMP +* .. +* .. External Subroutines .. + EXTERNAL CHB2ST_KERNELS, CLACPY, CLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX, CEILING, REAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required. +* Test the input parameters +* + DEBUG = 0 + INFO = 0 + AFTERS1 = LSAME( STAGE1, 'Y' ) + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + IB = ILAENV( 18, 'CHETRD_HB2ST', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'CHETRD_HB2ST', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'CHETRD_HB2ST', VECT, N, KD, IB, -1 ) +* + IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.(KD+1) ) THEN + INFO = -7 + ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRD_HB2ST', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDV = KD + IB + SIZETAU = 2 * N + SICEV = 2 * N + INDTAU = 1 + INDV = INDTAU + SIZETAU + LDA = 2 * KD + 1 + SIZEA = LDA * N + INDA = 1 + INDW = INDA + SIZEA + NTHREADS = 1 + TID = 0 +* + IF( UPPER ) THEN + APOS = INDA + KD + AWPOS = INDA + DPOS = APOS + KD + OFDPOS = DPOS - 1 + ABDPOS = KD + 1 + ABOFDPOS = KD + ELSE + APOS = INDA + AWPOS = INDA + KD + 1 + DPOS = APOS + OFDPOS = DPOS + 1 + ABDPOS = 1 + ABOFDPOS = 2 + + ENDIF +* +* Case KD=0: +* The matrix is diagonal. We just copy it (convert to "real" for +* complex because D is double and the imaginary part should be 0) +* and store it in D. A sequential code here is better or +* in a parallel environment it might need two cores for D and E +* + IF( KD.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = REAL( AB( ABDPOS, I ) ) + 30 CONTINUE + DO 40 I = 1, N-1 + E( I ) = RZERO + 40 CONTINUE +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Case KD=1: +* The matrix is already Tridiagonal. We have to make diagonal +* and offdiagonal elements real, and store them in D and E. +* For that, for real precision just copy the diag and offdiag +* to D and E while for the COMPLEX case the bulge chasing is +* performed to convert the hermetian tridiagonal to symmetric +* tridiagonal. A simpler coversion formula might be used, but then +* updating the Q matrix will be required and based if Q is generated +* or not this might complicate the story. +* + IF( KD.EQ.1 ) THEN + DO 50 I = 1, N + D( I ) = REAL( AB( ABDPOS, I ) ) + 50 CONTINUE +* +* make off-diagonal elements real and copy them to E +* + IF( UPPER ) THEN + DO 60 I = 1, N - 1 + TMP = AB( ABOFDPOS, I+1 ) + ABSTMP = ABS( TMP ) + AB( ABOFDPOS, I+1 ) = ABSTMP + E( I ) = ABSTMP + IF( ABSTMP.NE.RZERO ) THEN + TMP = TMP / ABSTMP + ELSE + TMP = ONE + END IF + IF( I.LT.N-1 ) + $ AB( ABOFDPOS, I+2 ) = AB( ABOFDPOS, I+2 )*TMP +C IF( WANTZ ) THEN +C CALL CSCAL( N, CONJG( TMP ), Q( 1, I+1 ), 1 ) +C END IF + 60 CONTINUE + ELSE + DO 70 I = 1, N - 1 + TMP = AB( ABOFDPOS, I ) + ABSTMP = ABS( TMP ) + AB( ABOFDPOS, I ) = ABSTMP + E( I ) = ABSTMP + IF( ABSTMP.NE.RZERO ) THEN + TMP = TMP / ABSTMP + ELSE + TMP = ONE + END IF + IF( I.LT.N-1 ) + $ AB( ABOFDPOS, I+1 ) = AB( ABOFDPOS, I+1 )*TMP +C IF( WANTQ ) THEN +C CALL CSCAL( N, TMP, Q( 1, I+1 ), 1 ) +C END IF + 70 CONTINUE + ENDIF +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Main code start here. +* Reduce the hermitian band of A to a tridiagonal matrix. +* + THGRSIZ = N + GRSIZ = 1 + SHIFT = 3 + NBTILES = CEILING( REAL(N)/REAL(KD) ) + STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) + THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) +* + CALL CLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) + CALL CLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) +* +* +* openMP parallelisation start here +* +#if defined(_OPENMP) +!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) +!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) +!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) +!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) +!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) +!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT ) +!$OMP MASTER +#endif +* +* main bulge chasing loop +* + DO 100 THGRID = 1, THGRNB + STT = (THGRID-1)*THGRSIZ+1 + THED = MIN( (STT + THGRSIZ -1), (N-1)) + DO 110 I = STT, N-1 + ED = MIN( I, THED ) + IF( STT.GT.ED ) EXIT + DO 120 M = 1, STEPERCOL + ST = STT + DO 130 SWEEPID = ST, ED + DO 140 K = 1, GRSIZ + MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) + $ + (M-1)*GRSIZ + K + IF ( MYID.EQ.1 ) THEN + TTYPE = 1 + ELSE + TTYPE = MOD( MYID, 2 ) + 2 + ENDIF + + IF( TTYPE.EQ.2 ) THEN + COLPT = (MYID/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + BLKLASTIND = COLPT + ELSE + COLPT = ((MYID+1)/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + IF( ( STIND.GE.EDIND-1 ).AND. + $ ( EDIND.EQ.N ) ) THEN + BLKLASTIND = N + ELSE + BLKLASTIND = 0 + ENDIF + ENDIF +* +* Call the kernel +* +#if defined(_OPENMP) + IF( TTYPE.NE.1 ) THEN +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(in:WORK(MYID-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL CHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ELSE +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL CHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ENDIF +#else + CALL CHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +#endif + IF ( BLKLASTIND.GE.(N-1) ) THEN + STT = STT + 1 + EXIT + ENDIF + 140 CONTINUE + 130 CONTINUE + 120 CONTINUE + 110 CONTINUE + 100 CONTINUE +* +#if defined(_OPENMP) +!$OMP END MASTER +!$OMP END PARALLEL +#endif +* +* Copy the diagonal from A to D. Note that D is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + DO 150 I = 1, N + D( I ) = REAL( WORK( DPOS+(I-1)*LDA ) ) + 150 CONTINUE +* +* Copy the off diagonal from A to E. Note that E is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + IF( UPPER ) THEN + DO 160 I = 1, N-1 + E( I ) = REAL( WORK( OFDPOS+I*LDA ) ) + 160 CONTINUE + ELSE + DO 170 I = 1, N-1 + E( I ) = REAL( WORK( OFDPOS+(I-1)*LDA ) ) + 170 CONTINUE + ENDIF +* + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of CHETRD_HB2ST +* + END + diff --git a/lapack-netlib/SRC/chetrd_he2hb.f b/lapack-netlib/SRC/chetrd_he2hb.f new file mode 100644 index 0000000000..677f182876 --- /dev/null +++ b/lapack-netlib/SRC/chetrd_he2hb.f @@ -0,0 +1,517 @@ +*> \brief \b CHETRD_HE2HB +* +* @generated from zhetrd_he2hb.f, fortran z -> c, Wed Dec 7 08:22:40 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRD_HE2HB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRD_HE2HB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), AB( LDAB, * ), +* TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian +*> band-diagonal form AB by a unitary similarity transformation: +*> Q**H * A * Q = AB. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the reduced matrix if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> The reduced matrix is stored in the array AB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the unitary +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the unitary matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AB +*> \verbatim +*> AB is COMPLEX array, dimension (LDAB,N) +*> On exit, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (N-KD) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension LWORK. +*> On exit, if INFO = 0, or if LWORK=-1, +*> WORK(1) returns the size of LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK which should be calculated +* by a workspace query. LWORK = MAX(1, LWORK_QUERY) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +*> where FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice otherwise +*> putting LWORK=-1 will provide the size of WORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in +*> A(i,i+kd+1:n), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in +* A(i+kd+2:n,i), and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( ab ab/v1 v1 v1 v1 ) ( ab ) +*> ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) +*> ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) +*> ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) +*> ( ab ) ( v1 v2 v3 ab/v4 ab ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CHETRD_HE2HB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AB( LDAB, * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL RONE + COMPLEX ZERO, ONE, HALF + PARAMETER ( RONE = 1.0E+0, + $ ZERO = ( 0.0E+0, 0.0E+0 ), + $ ONE = ( 1.0E+0, 0.0E+0 ), + $ HALF = ( 0.5E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, J, IINFO, LWMIN, PN, PK, LK, + $ LDT, LDW, LDS2, LDS1, + $ LS2, LS1, LW, LT, + $ TPOS, WPOS, S2POS, S1POS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHER2K, CHEMM, CGEMM, + $ CLARFT, CGELQF, CGEQRF, CLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required +* and test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + LWMIN = ILAENV( 20, 'CHETRD_HE2HB', '', N, KD, -1, -1 ) + + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRD_HE2HB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWMIN + RETURN + END IF +* +* Quick return if possible +* Copy the upper/lower portion of A into AB +* + IF( N.LE.KD+1 ) THEN + IF( UPPER ) THEN + DO 100 I = 1, N + LK = MIN( KD+1, I ) + CALL CCOPY( LK, A( I-LK+1, I ), 1, + $ AB( KD+1-LK+1, I ), 1 ) + 100 CONTINUE + ELSE + DO 110 I = 1, N + LK = MIN( KD+1, N-I+1 ) + CALL CCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) + 110 CONTINUE + ENDIF + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the pointer position for the workspace +* + LDT = KD + LDS1 = KD + LT = LDT*KD + LW = N*KD + LS1 = LDS1*KD + LS2 = LWMIN - LT - LW - LS1 +* LS2 = N*MAX(KD,FACTOPTNB) + TPOS = 1 + WPOS = TPOS + LT + S1POS = WPOS + LW + S2POS = S1POS + LS1 + IF( UPPER ) THEN + LDW = KD + LDS2 = KD + ELSE + LDW = N + LDS2 = N + ENDIF +* +* +* Set the workspace of the triangular matrix T to zero once such a +* way everytime T is generated the upper/lower portion will be always zero +* + CALL CLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) +* + IF( UPPER ) THEN + DO 10 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the LQ factorization of the current block +* + CALL CGELQF( KD, PN, A( I, I+KD ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 20 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL CCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 20 CONTINUE +* + CALL CLASET( 'Lower', PK, PK, ZERO, ONE, + $ A( I, I+KD ), LDA ) +* +* Form the matrix T +* + CALL CLARFT( 'Forward', 'Rowwise', PN, PK, + $ A( I, I+KD ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL CGEMM( 'Conjugate', 'No transpose', PK, PN, PK, + $ ONE, WORK( TPOS ), LDT, + $ A( I, I+KD ), LDA, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL CHEMM( 'Right', UPLO, PK, PN, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL CGEMM( 'No transpose', 'Conjugate', PK, PK, PN, + $ ONE, WORK( WPOS ), LDW, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL CGEMM( 'No transpose', 'No transpose', PK, PN, PK, + $ -HALF, WORK( S1POS ), LDS1, + $ A( I, I+KD ), LDA, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V'*W - W'*V +* + CALL CHER2K( UPLO, 'Conjugate', PN, PK, + $ -ONE, A( I, I+KD ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) + 10 CONTINUE +* +* Copy the upper band to AB which is the band storage matrix +* + DO 30 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL CCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 30 CONTINUE +* + ELSE +* +* Reduce the lower triangle of A to lower band matrix +* + DO 40 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the QR factorization of the current block +* + CALL CGEQRF( PN, KD, A( I+KD, I ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 50 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL CCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 50 CONTINUE +* + CALL CLASET( 'Upper', PK, PK, ZERO, ONE, + $ A( I+KD, I ), LDA ) +* +* Form the matrix T +* + CALL CLARFT( 'Forward', 'Columnwise', PN, PK, + $ A( I+KD, I ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL CGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ ONE, A( I+KD, I ), LDA, + $ WORK( TPOS ), LDT, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL CHEMM( 'Left', UPLO, PN, PK, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL CGEMM( 'Conjugate', 'No transpose', PK, PK, PN, + $ ONE, WORK( S2POS ), LDS2, + $ WORK( WPOS ), LDW, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL CGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ -HALF, A( I+KD, I ), LDA, + $ WORK( S1POS ), LDS1, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL CHER2K( UPLO, 'No transpose', PN, PK, + $ -ONE, A( I+KD, I ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) +* ================================================================== +* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED +* DO 45 J = I, I+PK-1 +* LK = MIN( KD, N-J ) + 1 +* CALL CCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) +* 45 CONTINUE +* ================================================================== + 40 CONTINUE +* +* Copy the lower band to AB which is the band storage matrix +* + DO 60 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL CCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 60 CONTINUE + + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of CHETRD_HE2HB +* + END diff --git a/lapack-netlib/SRC/chetrf.f b/lapack-netlib/SRC/chetrf.f index f92a81e473..aa8f7f23b9 100644 --- a/lapack-netlib/SRC/chetrf.f +++ b/lapack-netlib/SRC/chetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -42,7 +42,7 @@ *> A = U*D*U**H or A = L*D*L**H *> *> where U (or L) is a product of permutation and unit upper (lower) -*> triangular matrices, and D is Hermitian and block diagonal with +*> triangular matrices, and D is Hermitian and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> *> This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetrf_aa.f b/lapack-netlib/SRC/chetrf_aa.f new file mode 100644 index 0000000000..153a089deb --- /dev/null +++ b/lapack-netlib/SRC/chetrf_aa.f @@ -0,0 +1,483 @@ +*> \brief \b CHETRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRF_AA computes the factorization of a complex hermitian matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**H or A = L*T*L**H +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a hermitian tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 2*N. For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +* ===================================================================== + SUBROUTINE CHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = (0.0E+0, 0.0E+0), ONE = (1.0E+0, 0.0E+0) ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CONJG, MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'CHETRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.( 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + A( 1, 1 ) = REAL( A( 1, 1 ) ) + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**H using the upper triangle of A +* ..................................................... +* +* copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLAHEF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = CONJG( A( J, J+1 ) ) + A( J, J+1 ) = ONE + CALL CCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMM( 'Conjugate transpose', 'Transpose', + $ 1, MJ, JB+1, + $ -ONE, A( J1-K2, J3 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with CGEMM +* + CALL CGEMM( 'Conjugate transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = CONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**H using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLAHEF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = CONJG( A( J+1, J ) ) + A( J+1, J ) = ONE + CALL CCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ MJ, 1, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block column with CGEMM +* + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = CONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of CHETRF_AA +* + END diff --git a/lapack-netlib/SRC/chetrf_rk.f b/lapack-netlib/SRC/chetrf_rk.f new file mode 100644 index 0000000000..9e42b57197 --- /dev/null +++ b/lapack-netlib/SRC/chetrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b CHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHETRF_RK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CLAHEF_RK, CHETF2_RK, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'CHETRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'CHETRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by CLAHEF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL CLAHEF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL CHETF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL CSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by CLAHEF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL CLAHEF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL CHETF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL CSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of CHETRF_RK +* + END diff --git a/lapack-netlib/SRC/chetrf_rook.f b/lapack-netlib/SRC/chetrf_rook.f index 98c8dbd267..0217150d18 100644 --- a/lapack-netlib/SRC/chetrf_rook.f +++ b/lapack-netlib/SRC/chetrf_rook.f @@ -150,7 +150,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complexHEcomputational * @@ -199,7 +199,7 @@ *> *> \verbatim *> -*> November 2013, Igor Kozachenko, +*> June 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -212,10 +212,10 @@ * ===================================================================== SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -265,7 +265,7 @@ SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * diff --git a/lapack-netlib/SRC/chetri.f b/lapack-netlib/SRC/chetri.f index 61048b5f89..a5762b20d6 100644 --- a/lapack-netlib/SRC/chetri.f +++ b/lapack-netlib/SRC/chetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetri2.f b/lapack-netlib/SRC/chetri2.f index 86d291edc3..684bacfc3a 100644 --- a/lapack-netlib/SRC/chetri2.f +++ b/lapack-netlib/SRC/chetri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE CHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/chetri2x.f b/lapack-netlib/SRC/chetri2x.f index 68163fc4b6..2ac18b5746 100644 --- a/lapack-netlib/SRC/chetri2x.f +++ b/lapack-netlib/SRC/chetri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -215,7 +215,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -231,7 +231,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -248,7 +248,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D WORK(K+1,INVD) = CONJG (WORK(K,INVD+1) ) K=K+2 END IF @@ -265,7 +265,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -275,7 +275,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -338,7 +338,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**H*invD1*U11->U11 * CALL CTRMM('L','U','C','U',NNB, NNB, @@ -382,7 +382,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -392,9 +392,9 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL CHESWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL CHESWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -408,7 +408,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -425,7 +425,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D WORK(K-1,INVD+1) = CONJG (WORK(K,INVD+1) ) K=K-2 END IF @@ -442,7 +442,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -509,7 +509,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**H*invD1*L11->L11 * CALL CTRMM('L',UPLO,'C','U',NNB, NNB, @@ -527,7 +527,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL CGEMM('C','N',NNB,NNB,N-NNB-CUT,CONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**H*invD1*L11 + U01**H*invD*U01 * @@ -565,7 +565,7 @@ SUBROUTINE CHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/chetri_3.f b/lapack-netlib/SRC/chetri_3.f new file mode 100644 index 0000000000..8f1527dbbf --- /dev/null +++ b/lapack-netlib/SRC/chetri_3.f @@ -0,0 +1,248 @@ +*> \brief \b CHETRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHETRI_3 computes the inverse of a complex Hermitian indefinite +*> matrix A using the factorization computed by CHETRF_RK or CHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CHETRI_3 sets the leading dimension of the workspace before calling +*> CHETRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the Hermitian inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_RK or CHETRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CHETRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'CHETRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CHETRI_3 +* + END diff --git a/lapack-netlib/SRC/chetri_3x.f b/lapack-netlib/SRC/chetri_3x.f new file mode 100644 index 0000000000..c8fc3d9c7f --- /dev/null +++ b/lapack-netlib/SRC/chetri_3x.f @@ -0,0 +1,649 @@ +*> \brief \b CHETRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHETRI_3X computes the inverse of a complex Hermitian indefinite +*> matrix A using the factorization computed by CHETRF_RK or CHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the Hermitian inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_RK or CHETRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + REAL AK, AKP1, T + COMPLEX AKKP1, D, U01_I_J, U01_IP1_J, U11_I_J, + $ U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CHESWAPR, CTRTRI, CTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX, REAL +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**H) * inv(D) * inv(U) * P**T. +* + CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / REAL( A( K, K ) ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = ABS( WORK( K+1, 1 ) ) + AK = REAL( A( K, K ) ) / T + AKP1 = REAL( A( K+1, K+1 ) ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = CONJG( WORK( K, INVD+1 ) ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**H) = (inv(U))**H +* +* inv(U**H) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = CONE + DO J = 1, I-1 + WORK( U11+I, J ) = CZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**H * invD1 * U11 -> U11 +* + CALL CTRMM( 'L', 'U', 'C', 'U', NNB, NNB, + $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**H * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL CGEMM( 'C', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1), + $ N+NB+1 ) + +* +* U11 = U11**H * invD1 * U11 + U01**H * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**H * invD0 * U01 +* + CALL CTRMM( 'L', UPLO, 'C', 'U', CUT, NNB, + $ CONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**H) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL CHESWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL CHESWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**H) * inv(D) * inv(L) * P**T. +* + CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / REAL( A( K, K ) ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = ABS( WORK( K-1, 1 ) ) + AK = REAL( A( K-1, K-1 ) ) / T + AKP1 = REAL( A( K, K ) ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = CONJG( WORK( K, INVD+1 ) ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**H) = (inv(L))**H +* +* inv(L**H) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = CONE + DO J = I+1, NNB + WORK( U11+I, J ) = CZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**H * invD1 * L11 -> L11 +* + CALL CTRMM( 'L', UPLO, 'C', 'U', NNB, NNB, CONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**H * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL CGEMM( 'C', 'N', NNB, NNB, N-NNB-CUT, CONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ CZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**H * invD1 * L11 + U01**H * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**H * invD2 * L21 +* + CALL CTRMM( 'L', UPLO, 'C', 'U', N-NNB-CUT, NNB, CONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**H * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**H) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL CHESWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL CHESWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of CHETRI_3X +* + END diff --git a/lapack-netlib/SRC/chetrs.f b/lapack-netlib/SRC/chetrs.f index 27fe18497d..a7864621a0 100644 --- a/lapack-netlib/SRC/chetrs.f +++ b/lapack-netlib/SRC/chetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chetrs2.f b/lapack-netlib/SRC/chetrs2.f index 7a1cc04ff1..7041568793 100644 --- a/lapack-netlib/SRC/chetrs2.f +++ b/lapack-netlib/SRC/chetrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHETRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHETRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,23 +114,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexHEcomputational * * ===================================================================== - SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -158,7 +158,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CSCAL, CSYCONV, CSWAP, CTRSM, XERBLA + EXTERNAL CSSCAL, CSYCONV, CSWAP, CTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL @@ -196,7 +196,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**H. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -221,7 +221,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL CTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -274,7 +274,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**H. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -299,7 +299,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL CTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -322,7 +322,7 @@ SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] -* +* CALL CTRSM('L','L','C','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**H \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/chetrs_3.f b/lapack-netlib/SRC/chetrs_3.f new file mode 100644 index 0000000000..ade0a156ba --- /dev/null +++ b/lapack-netlib/SRC/chetrs_3.f @@ -0,0 +1,374 @@ +*> \brief \b CHETRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CHETRS_3 solves a system of linear equations A * X = B with a complex +*> Hermitian matrix A using the factorization computed +*> by CHETRF_RK or CHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_RK or CHETRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = ( 1.0E+0,0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + REAL S + COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CSSCAL, CSWAP, CTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX, REAL +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**H. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL CTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + S = REAL( ONE ) / REAL( A( I, I ) ) + CALL CSSCAL( NRHS, S, B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / CONJG( AKM1K ) + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / CONJG( AKM1K ) + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ] +* + CALL CTRSM( 'L', 'U', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**H. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL CTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + S = REAL( ONE ) / REAL( A( I, I ) ) + CALL CSSCAL( NRHS, S, B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / CONJG( AKM1K ) + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / CONJG( AKM1K ) + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] +* + CALL CTRSM('L', 'L', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of CHETRS_3 +* + END diff --git a/lapack-netlib/SRC/chetrs_aa.f b/lapack-netlib/SRC/chetrs_aa.f new file mode 100644 index 0000000000..f6640c5098 --- /dev/null +++ b/lapack-netlib/SRC/chetrs_aa.f @@ -0,0 +1,295 @@ +*> \brief \b CHETRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRS_AA solves a system of linear equations A*X = B with a complex +*> hermitian matrix A using the factorization A = U*T*U**H or +*> A = L*T*L**H computed by CHETRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**H; +*> = 'L': Lower triangular, form is A = L*T*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> Details of factors computed by CHETRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by CHETRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +* ===================================================================== + SUBROUTINE CHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGTSV, CSWAP, CTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL CTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1) + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1) + CALL CLACGV( N-1, WORK( 1 ), 1 ) + END IF + CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL CTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1) + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1) + CALL CLACGV( N-1, WORK( 2*N ), 1 ) + END IF + CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL CTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + END IF +* + RETURN +* +* End of CHETRS_AA +* + END diff --git a/lapack-netlib/SRC/chfrk.f b/lapack-netlib/SRC/chfrk.f index 971e272d19..3378e6fb85 100644 --- a/lapack-netlib/SRC/chfrk.f +++ b/lapack-netlib/SRC/chfrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHFRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHFRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, * C ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER K, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, $ C ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/chgeqz.f b/lapack-netlib/SRC/chgeqz.f index 024354e66b..73d35621c3 100644 --- a/lapack-netlib/SRC/chgeqz.f +++ b/lapack-netlib/SRC/chgeqz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHGEQZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHGEQZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ, JOB * INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N @@ -32,7 +32,7 @@ * $ Q( LDQ, * ), T( LDT, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -44,18 +44,18 @@ *> using the single-shift QZ method. *> Matrix pairs of this type are produced by the reduction to *> generalized upper Hessenberg form of a complex matrix pair (A,B): -*> +*> *> A = Q1*H*Z1**H, B = Q1*T*Z1**H, -*> +*> *> as computed by CGGHRD. -*> +*> *> If JOB='S', then the Hessenberg-triangular pair (H,T) is *> also reduced to generalized Schur form, -*> +*> *> H = Q*S*Z**H, T = Q*P*Z**H, -*> +*> *> where Q and Z are unitary matrices and S and P are upper triangular. -*> +*> *> Optionally, the unitary matrix Q from the generalized Schur *> factorization may be postmultiplied into an input matrix Q1, and the *> unitary matrix Z may be postmultiplied into an input matrix Z1. @@ -63,9 +63,9 @@ *> the matrix pair (A,B) to generalized Hessenberg form, then the output *> matrices Q1*Q and Z1*Z are the unitary factors from the generalized *> Schur factorization of (A,B): -*> +*> *> A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. -*> +*> *> To avoid overflow, eigenvalues of the matrix pair (H,T) *> (equivalently, of (A,B)) are computed as a pair of complex values *> (alpha,beta). If beta is nonzero, lambda = alpha / beta is an @@ -190,12 +190,12 @@ *> \param[in,out] Q *> \verbatim *> Q is COMPLEX array, dimension (LDQ, N) -*> On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +*> On entry, if COMPQ = 'V', the unitary matrix Q1 used in the *> reduction of (A,B) to generalized Hessenberg form. -*> On exit, if COMPZ = 'I', the unitary matrix of left Schur -*> vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +*> On exit, if COMPQ = 'I', the unitary matrix of left Schur +*> vectors of (H,T), and if COMPQ = 'V', the unitary matrix of *> left Schur vectors of (A,B). -*> Not referenced if COMPZ = 'N'. +*> Not referenced if COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ @@ -261,10 +261,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -284,7 +284,7 @@ SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/chla_transtype.f b/lapack-netlib/SRC/chla_transtype.f index 00ba4f5aec..0630a759bc 100644 --- a/lapack-netlib/SRC/chla_transtype.f +++ b/lapack-netlib/SRC/chla_transtype.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHLA_TRANSTYPE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHLA_TRANSTYPE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS ) -* +* * .. Scalar Arguments .. * INTEGER TRANS * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER TRANS diff --git a/lapack-netlib/SRC/chpcon.f b/lapack-netlib/SRC/chpcon.f index 99b457e6ff..d48a8bd51c 100644 --- a/lapack-netlib/SRC/chpcon.f +++ b/lapack-netlib/SRC/chpcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chpev.f b/lapack-netlib/SRC/chpev.f index 742ff98d4c..489709060a 100644 --- a/lapack-netlib/SRC/chpev.f +++ b/lapack-netlib/SRC/chpev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, N @@ -29,7 +29,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -138,10 +138,10 @@ SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chpevd.f b/lapack-netlib/SRC/chpevd.f index 45d6f45675..b9c872034e 100644 --- a/lapack-netlib/SRC/chpevd.f +++ b/lapack-netlib/SRC/chpevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -200,10 +200,10 @@ SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -292,7 +292,7 @@ SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CHPEVD', -INFO ) - RETURN + RETURN ELSE IF( LQUERY ) THEN RETURN END IF @@ -306,7 +306,7 @@ SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = CONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/chpevx.f b/lapack-netlib/SRC/chpevx.f index e7bd2c4f4d..6a111f00f7 100644 --- a/lapack-netlib/SRC/chpevx.f +++ b/lapack-netlib/SRC/chpevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDZ, M, N @@ -32,7 +32,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -110,13 +113,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -219,12 +226,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexOTHEReigen * @@ -233,10 +240,10 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/chpgst.f b/lapack-netlib/SRC/chpgst.f index 59e30d2656..3813914dd8 100644 --- a/lapack-netlib/SRC/chpgst.f +++ b/lapack-netlib/SRC/chpgst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), BP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chpgv.f b/lapack-netlib/SRC/chpgv.f index d5b52254ab..999031d13a 100644 --- a/lapack-netlib/SRC/chpgv.f +++ b/lapack-netlib/SRC/chpgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, N @@ -29,7 +29,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -165,10 +165,10 @@ SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chpgvd.f b/lapack-netlib/SRC/chpgvd.f index 8321cf93e5..6c1ef3227c 100644 --- a/lapack-netlib/SRC/chpgvd.f +++ b/lapack-netlib/SRC/chpgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHEReigen * @@ -231,10 +231,10 @@ SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/chpgvx.f b/lapack-netlib/SRC/chpgvx.f index ee100984c7..06a08798a0 100644 --- a/lapack-netlib/SRC/chpgvx.f +++ b/lapack-netlib/SRC/chpgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, * IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDZ, M, N @@ -32,7 +32,7 @@ * REAL RWORK( * ), W( * ) * COMPLEX AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,13 +118,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,14 +136,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,12 +258,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHEReigen * @@ -268,10 +277,10 @@ SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -322,7 +331,7 @@ SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 - ELSE + ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) THEN INFO = -9 diff --git a/lapack-netlib/SRC/chprfs.f b/lapack-netlib/SRC/chprfs.f index 40ec6aa5cf..9fe0532cd7 100644 --- a/lapack-netlib/SRC/chprfs.f +++ b/lapack-netlib/SRC/chprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -180,10 +180,10 @@ SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chpsv.f b/lapack-netlib/SRC/chpsv.f index 8c06193092..af62b5a1e5 100644 --- a/lapack-netlib/SRC/chpsv.f +++ b/lapack-netlib/SRC/chpsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chpsvx.f b/lapack-netlib/SRC/chpsvx.f index 3c04ea60a0..5783a189f7 100644 --- a/lapack-netlib/SRC/chpsvx.f +++ b/lapack-netlib/SRC/chpsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/chptrd.f b/lapack-netlib/SRC/chptrd.f index a5811e6e61..e5caab7b07 100644 --- a/lapack-netlib/SRC/chptrd.f +++ b/lapack-netlib/SRC/chptrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * REAL D( * ), E( * ) * COMPLEX AP( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -151,10 +151,10 @@ * ===================================================================== SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chptrf.f b/lapack-netlib/SRC/chptrf.f index 5caa9c9dff..97c4e96eda 100644 --- a/lapack-netlib/SRC/chptrf.f +++ b/lapack-netlib/SRC/chptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -159,10 +159,10 @@ * ===================================================================== SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chptri.f b/lapack-netlib/SRC/chptri.f index b149504f37..878c88157e 100644 --- a/lapack-netlib/SRC/chptri.f +++ b/lapack-netlib/SRC/chptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chptrs.f b/lapack-netlib/SRC/chptrs.f index 684b229050..bfb8777e5f 100644 --- a/lapack-netlib/SRC/chptrs.f +++ b/lapack-netlib/SRC/chptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/chsein.f b/lapack-netlib/SRC/chsein.f index b4747b53f0..5c15b0b68c 100644 --- a/lapack-netlib/SRC/chsein.f +++ b/lapack-netlib/SRC/chsein.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHSEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHSEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, * LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, * IFAILR, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EIGSRC, INITV, SIDE * INTEGER INFO, LDH, LDVL, LDVR, M, MM, N @@ -33,7 +33,7 @@ * COMPLEX H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -221,12 +221,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -245,10 +245,10 @@ SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE diff --git a/lapack-netlib/SRC/chseqr.f b/lapack-netlib/SRC/chseqr.f index 755ca7f7f7..34bf49249e 100644 --- a/lapack-netlib/SRC/chseqr.f +++ b/lapack-netlib/SRC/chseqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CHSEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * CHARACTER COMPZ, JOB @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -211,12 +211,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -299,10 +299,10 @@ SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/cla_gbamv.f b/lapack-netlib/SRC/cla_gbamv.f index b74156dbc5..e043d74446 100644 --- a/lapack-netlib/SRC/cla_gbamv.f +++ b/lapack-netlib/SRC/cla_gbamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GBAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GBAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, * INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS @@ -29,7 +29,7 @@ * COMPLEX AB( LDAB, * ), X( * ) * REAL Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is REAL array, dimension (LDAB,n) +*> AB is COMPLEX array, dimension (LDAB,n) *> Before entry, the leading m by n part of the array AB must *> contain the matrix of coefficients. *> Unchanged on exit. @@ -124,7 +124,7 @@ *> *> \param[in] X *> \verbatim -*> X is REAL array, dimension +*> X is COMPLEX array, dimension *> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' *> and at least *> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. @@ -173,12 +173,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexGBcomputational * @@ -186,10 +186,10 @@ SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, $ INCX, BETA, Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/cla_gbrcond_c.f b/lapack-netlib/SRC/cla_gbrcond_c.f index 75b80ff7bf..123aee26ec 100644 --- a/lapack-netlib/SRC/cla_gbrcond_c.f +++ b/lapack-netlib/SRC/cla_gbrcond_c.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GBRCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GBRCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, * LDAFB, IPIV, C, CAPPLY, INFO, WORK, * RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CAPPLY @@ -32,7 +32,7 @@ * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) * REAL C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -161,10 +161,10 @@ REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, $ LDAFB, IPIV, C, CAPPLY, INFO, WORK, $ RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cla_gbrcond_x.f b/lapack-netlib/SRC/cla_gbrcond_x.f index b559e47b02..d04aa7fb89 100644 --- a/lapack-netlib/SRC/cla_gbrcond_x.f +++ b/lapack-netlib/SRC/cla_gbrcond_x.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GBRCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GBRCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, * LDAFB, IPIV, X, INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO @@ -31,7 +31,7 @@ * $ X( * ) * REAL RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -153,10 +153,10 @@ REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, $ LDAFB, IPIV, X, INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cla_gbrfsx_extended.f b/lapack-netlib/SRC/cla_gbrfsx_extended.f index 45f72bc97a..441518022e 100644 --- a/lapack-netlib/SRC/cla_gbrfsx_extended.f +++ b/lapack-netlib/SRC/cla_gbrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GBRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GBRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * ERR_BNDS_COMP, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, * $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -394,12 +394,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -412,10 +412,10 @@ SUBROUTINE CLA_GBRFSX_EXTENDED ( PREC_TYPE, TRANS_TYPE, N, KL, KU, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, diff --git a/lapack-netlib/SRC/cla_gbrpvgrw.f b/lapack-netlib/SRC/cla_gbrpvgrw.f index 9d28ed8968..f60b714c08 100644 --- a/lapack-netlib/SRC/cla_gbrpvgrw.f +++ b/lapack-netlib/SRC/cla_gbrpvgrw.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GBRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GBRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, * LDAFB ) -* +* * .. Scalar Arguments .. * INTEGER N, KL, KU, NCOLS, LDAB, LDAFB * .. * .. Array Arguments .. * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBcomputational * @@ -117,10 +117,10 @@ REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, $ LDAFB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, KL, KU, NCOLS, LDAB, LDAFB diff --git a/lapack-netlib/SRC/cla_geamv.f b/lapack-netlib/SRC/cla_geamv.f index b5b987d2ef..cbbcca8932 100644 --- a/lapack-netlib/SRC/cla_geamv.f +++ b/lapack-netlib/SRC/cla_geamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, * Y, INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDA, M, N @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), X( * ) * REAL Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -175,10 +175,10 @@ SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, $ Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/cla_gercond_c.f b/lapack-netlib/SRC/cla_gercond_c.f index da2369cae7..aabdc0bb9a 100644 --- a/lapack-netlib/SRC/cla_gercond_c.f +++ b/lapack-netlib/SRC/cla_gercond_c.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GERCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GERCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, * CAPPLY, INFO, WORK, RWORK ) -* +* * .. Scalar Aguments .. * CHARACTER TRANS * LOGICAL CAPPLY @@ -31,14 +31,14 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) * REAL C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_GERCOND_C computes the infinity norm condition number of *> op(A) * inv(diag(C)) where C is a REAL vector. *> \endverbatim @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -142,10 +142,10 @@ REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, $ CAPPLY, INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Aguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cla_gercond_x.f b/lapack-netlib/SRC/cla_gercond_x.f index 42103f0db5..6dce99f625 100644 --- a/lapack-netlib/SRC/cla_gercond_x.f +++ b/lapack-netlib/SRC/cla_gercond_x.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GERCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GERCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDA, LDAF, INFO @@ -30,14 +30,14 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * REAL RWORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_GERCOND_X computes the infinity norm condition number of *> op(A) * diag(X) where X is a COMPLEX vector. *> \endverbatim @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -135,10 +135,10 @@ REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/cla_gerfsx_extended.f b/lapack-netlib/SRC/cla_gerfsx_extended.f index 08dc65d8d5..2e05963341 100644 --- a/lapack-netlib/SRC/cla_gerfsx_extended.f +++ b/lapack-netlib/SRC/cla_gerfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -24,7 +24,7 @@ * ERRS_N, ERRS_C, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ TRANS_TYPE, N_NORMS @@ -39,14 +39,14 @@ * REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), * $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_GERFSX_EXTENDED improves the computed solution to a system of *> linear equations by performing extra-precise iterative refinement *> and provides error bounds and backward error estimates for the solution. @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -397,10 +397,10 @@ SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/cla_gerpvgrw.f b/lapack-netlib/SRC/cla_gerpvgrw.f index 6764a39598..f6d27c8c0f 100644 --- a/lapack-netlib/SRC/cla_gerpvgrw.f +++ b/lapack-netlib/SRC/cla_gerpvgrw.f @@ -2,38 +2,38 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_GERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_GERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) -* +* * .. Scalar Arguments .. * INTEGER N, NCOLS, LDA, LDAF * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), AF( LDAF, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_GERPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEcomputational * * ===================================================================== REAL FUNCTION CLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NCOLS, LDA, LDAF diff --git a/lapack-netlib/SRC/cla_heamv.f b/lapack-netlib/SRC/cla_heamv.f index 41a4c5b58f..6a3eef1bf5 100644 --- a/lapack-netlib/SRC/cla_heamv.f +++ b/lapack-netlib/SRC/cla_heamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_HEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_HEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDA, N, UPLO @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), X( * ) * REAL Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -178,10 +178,10 @@ SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/cla_hercond_c.f b/lapack-netlib/SRC/cla_hercond_c.f index 9883331271..a5ebaf8a21 100644 --- a/lapack-netlib/SRC/cla_hercond_c.f +++ b/lapack-netlib/SRC/cla_hercond_c.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_HERCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_HERCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, * CAPPLY, INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) * REAL C ( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -138,10 +138,10 @@ REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, $ CAPPLY, INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_hercond_x.f b/lapack-netlib/SRC/cla_hercond_x.f index 3af007d729..f0004102fd 100644 --- a/lapack-netlib/SRC/cla_hercond_x.f +++ b/lapack-netlib/SRC/cla_hercond_x.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_HERCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_HERCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * REAL RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -131,10 +131,10 @@ REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_herfsx_extended.f b/lapack-netlib/SRC/cla_herfsx_extended.f index ac05329be4..7af5441e28 100644 --- a/lapack-netlib/SRC/cla_herfsx_extended.f +++ b/lapack-netlib/SRC/cla_herfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_HERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_HERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,7 +41,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEcomputational * @@ -398,10 +398,10 @@ SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/cla_herpvgrw.f b/lapack-netlib/SRC/cla_herpvgrw.f index dc05aedc9c..0fa26d9e3a 100644 --- a/lapack-netlib/SRC/cla_herpvgrw.f +++ b/lapack-netlib/SRC/cla_herpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_HERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_HERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -30,14 +30,14 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ) * REAL WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_HERPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -104,18 +104,18 @@ *> *> \param[in] WORK *> \verbatim -*> WORK is COMPLEX array, dimension (2*N) +*> WORK is REAL array, dimension (2*N) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexHEcomputational * @@ -123,10 +123,10 @@ REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, $ WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -147,7 +147,7 @@ REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, COMPLEX ZDUM * .. * .. External Functions .. - EXTERNAL LSAME, CLASET + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, AIMAG, MAX, MIN diff --git a/lapack-netlib/SRC/cla_lin_berr.f b/lapack-netlib/SRC/cla_lin_berr.f index 94db81439d..c892d8b0e4 100644 --- a/lapack-netlib/SRC/cla_lin_berr.f +++ b/lapack-netlib/SRC/cla_lin_berr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_LIN_BERR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_LIN_BERR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) -* +* * .. Scalar Arguments .. * INTEGER N, NZ, NRHS * .. @@ -27,7 +27,7 @@ * REAL AYB( N, NRHS ), BERR( NRHS ) * COMPLEX RES( N, NRHS ) * .. -* +* * *> \par Purpose: * ============= @@ -67,7 +67,7 @@ *> *> \param[in] RES *> \verbatim -*> RES is REAL array, dimension (N,NRHS) +*> RES is COMPLEX array, dimension (N,NRHS) *> The residual matrix, i.e., the matrix R in the relative backward *> error formula above. *> \endverbatim @@ -79,32 +79,32 @@ *> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B *> are from iterative refinement (see cla_gerfsx_extended.f). *> \endverbatim -*> +*> *> \param[out] BERR *> \verbatim -*> BERR is COMPLEX array, dimension (NRHS) +*> BERR is REAL array, dimension (NRHS) *> The componentwise relative backward error from the formula above. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. INTEGER N, NZ, NRHS diff --git a/lapack-netlib/SRC/cla_porcond_c.f b/lapack-netlib/SRC/cla_porcond_c.f index 8e2b983713..7a2bcfe638 100644 --- a/lapack-netlib/SRC/cla_porcond_c.f +++ b/lapack-netlib/SRC/cla_porcond_c.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_PORCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_PORCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) * REAL C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -38,7 +38,7 @@ *> \verbatim *> *> CLA_PORCOND_C Computes the infinity norm condition number of -*> op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector +*> op(A) * inv(diag(C)) where C is a REAL vector *> \endverbatim * * Arguments: @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexPOcomputational * @@ -130,10 +130,10 @@ REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_porcond_x.f b/lapack-netlib/SRC/cla_porcond_x.f index efd54432d1..f0844ec893 100644 --- a/lapack-netlib/SRC/cla_porcond_x.f +++ b/lapack-netlib/SRC/cla_porcond_x.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_PORCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_PORCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, * WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * REAL RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPOcomputational * @@ -123,10 +123,10 @@ REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, $ WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_porfsx_extended.f b/lapack-netlib/SRC/cla_porfsx_extended.f index 4f3a0926ca..73184d7616 100644 --- a/lapack-netlib/SRC/cla_porfsx_extended.f +++ b/lapack-netlib/SRC/cla_porfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_PORFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_PORFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -372,12 +372,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPOcomputational * @@ -390,10 +390,10 @@ SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/cla_porpvgrw.f b/lapack-netlib/SRC/cla_porpvgrw.f index 607752adab..bd2e7af1cb 100644 --- a/lapack-netlib/SRC/cla_porpvgrw.f +++ b/lapack-netlib/SRC/cla_porpvgrw.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_PORPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_PORPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER NCOLS, LDA, LDAF @@ -28,14 +28,14 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ) * REAL WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_PORPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -87,28 +87,28 @@ *> *> \param[in] WORK *> \verbatim -*> WORK is COMPLEX array, dimension (2*N) +*> WORK is REAL array, dimension (2*N) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexPOcomputational * * ===================================================================== REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -128,7 +128,7 @@ REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) COMPLEX ZDUM * .. * .. External Functions .. - EXTERNAL LSAME, CLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/cla_syamv.f b/lapack-netlib/SRC/cla_syamv.f index cff3143ff8..362d4559da 100644 --- a/lapack-netlib/SRC/cla_syamv.f +++ b/lapack-netlib/SRC/cla_syamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_SYAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_SYAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDA, N @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), X( * ) * REAL Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -179,10 +179,10 @@ SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/cla_syrcond_c.f b/lapack-netlib/SRC/cla_syrcond_c.f index 0ad1cff936..fc52bf23bc 100644 --- a/lapack-netlib/SRC/cla_syrcond_c.f +++ b/lapack-netlib/SRC/cla_syrcond_c.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_SYRCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_SYRCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, * CAPPLY, INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) * REAL C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -138,10 +138,10 @@ REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, $ CAPPLY, INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_syrcond_x.f b/lapack-netlib/SRC/cla_syrcond_x.f index a390c52e0e..f8fb566e79 100644 --- a/lapack-netlib/SRC/cla_syrcond_x.f +++ b/lapack-netlib/SRC/cla_syrcond_x.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_SYRCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_SYRCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * REAL RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -131,10 +131,10 @@ REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cla_syrfsx_extended.f b/lapack-netlib/SRC/cla_syrfsx_extended.f index 1655f7cee7..f99801c429 100644 --- a/lapack-netlib/SRC/cla_syrfsx_extended.f +++ b/lapack-netlib/SRC/cla_syrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_SYRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_SYRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,7 +41,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -398,10 +398,10 @@ SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/cla_syrpvgrw.f b/lapack-netlib/SRC/cla_syrpvgrw.f index bdd541b723..ccea462c7e 100644 --- a/lapack-netlib/SRC/cla_syrpvgrw.f +++ b/lapack-netlib/SRC/cla_syrpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_SYRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_SYRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -30,14 +30,14 @@ * REAL WORK( * ) * INTEGER IPIV( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> CLA_SYRPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -123,10 +123,10 @@ REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, $ WORK ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -150,7 +150,7 @@ REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, INTRINSIC ABS, REAL, AIMAG, MAX, MIN * .. * .. External Subroutines .. - EXTERNAL LSAME, CLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Statement Functions .. diff --git a/lapack-netlib/SRC/cla_wwaddw.f b/lapack-netlib/SRC/cla_wwaddw.f index 77e6842006..9267c6df2b 100644 --- a/lapack-netlib/SRC/cla_wwaddw.f +++ b/lapack-netlib/SRC/cla_wwaddw.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLA_WWADDW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLA_WWADDW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLA_WWADDW( N, X, Y, W ) -* +* * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * COMPLEX X( * ), Y( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -69,22 +69,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLA_WWADDW( N, X, Y, W ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/SRC/clabrd.f b/lapack-netlib/SRC/clabrd.f index c0c21c72ab..87bcb1bcb7 100644 --- a/lapack-netlib/SRC/clabrd.f +++ b/lapack-netlib/SRC/clabrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), * $ Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -212,10 +212,10 @@ SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB diff --git a/lapack-netlib/SRC/clacgv.f b/lapack-netlib/SRC/clacgv.f index 9604283068..81ecadcdec 100644 --- a/lapack-netlib/SRC/clacgv.f +++ b/lapack-netlib/SRC/clacgv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACGV( N, X, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/clacn2.f b/lapack-netlib/SRC/clacn2.f index 6cdf82c122..132712deb9 100644 --- a/lapack-netlib/SRC/clacn2.f +++ b/lapack-netlib/SRC/clacn2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST @@ -28,7 +28,7 @@ * INTEGER ISAVE( 3 ) * COMPLEX V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -70,7 +70,7 @@ *> EST is REAL *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to CLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -133,10 +133,10 @@ * ===================================================================== SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/clacon.f b/lapack-netlib/SRC/clacon.f index 5c63d5cc4d..2d67b9e695 100644 --- a/lapack-netlib/SRC/clacon.f +++ b/lapack-netlib/SRC/clacon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACON( N, V, X, EST, KASE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX V( N ), X( N ) * .. -* +* * *> \par Purpose: * ============= @@ -69,7 +69,7 @@ *> EST is REAL *> On entry with KASE = 1 or 2 and JUMP = 3, EST should be *> unchanged from the previous call to CLACON. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE CLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/clacp2.f b/lapack-netlib/SRC/clacp2.f index 444ba6bd37..1d04962d3f 100644 --- a/lapack-netlib/SRC/clacp2.f +++ b/lapack-netlib/SRC/clacp2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -28,7 +28,7 @@ * REAL A( LDA, * ) * COMPLEX B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clacpy.f b/lapack-netlib/SRC/clacpy.f index 7f1fddc436..26d5f37da9 100644 --- a/lapack-netlib/SRC/clacpy.f +++ b/lapack-netlib/SRC/clacpy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clacrm.f b/lapack-netlib/SRC/clacrm.f index 8204920513..47c8374852 100644 --- a/lapack-netlib/SRC/clacrm.f +++ b/lapack-netlib/SRC/clacrm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACRM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACRM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, M, N * .. @@ -27,7 +27,7 @@ * REAL B( LDB, * ), RWORK( * ) * COMPLEX A( LDA, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,7 +61,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA, N) -*> A contains the M by N matrix A. +*> On entry, A contains the M by N matrix A. *> \endverbatim *> *> \param[in] LDA @@ -73,7 +73,7 @@ *> \param[in] B *> \verbatim *> B is REAL array, dimension (LDB, N) -*> B contains the N by N matrix B. +*> On entry, B contains the N by N matrix B. *> \endverbatim *> *> \param[in] LDB @@ -82,10 +82,10 @@ *> The leading dimension of the array B. LDB >=max(1,N). *> \endverbatim *> -*> \param[in] C +*> \param[out] C *> \verbatim *> C is COMPLEX array, dimension (LDC, N) -*> C contains the M by N matrix C. +*> On exit, C contains the M by N matrix C. *> \endverbatim *> *> \param[in] LDC @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, M, N diff --git a/lapack-netlib/SRC/clacrt.f b/lapack-netlib/SRC/clacrt.f index 2e19306a8e..1f7181791b 100644 --- a/lapack-netlib/SRC/clacrt.f +++ b/lapack-netlib/SRC/clacrt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLACRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLACRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * COMPLEX C, S @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/cladiv.f b/lapack-netlib/SRC/cladiv.f index 0d0ec666fc..189ef21145 100644 --- a/lapack-netlib/SRC/cladiv.f +++ b/lapack-netlib/SRC/cladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * COMPLEX FUNCTION CLADIV( X, Y ) -* +* * .. Scalar Arguments .. * COMPLEX X, Y * .. -* +* * *> \par Purpose: * ============= @@ -52,22 +52,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== COMPLEX FUNCTION CLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX X, Y diff --git a/lapack-netlib/SRC/claed0.f b/lapack-netlib/SRC/claed0.f index 6d6ed707ef..9907b10168 100644 --- a/lapack-netlib/SRC/claed0.f +++ b/lapack-netlib/SRC/claed0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDQ, LDQS, N, QSIZ * .. @@ -29,7 +29,7 @@ * REAL D( * ), E( * ), RWORK( * ) * COMPLEX Q( LDQ, * ), QSTORE( LDQS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -145,10 +145,10 @@ SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDQ, LDQS, N, QSIZ diff --git a/lapack-netlib/SRC/claed7.f b/lapack-netlib/SRC/claed7.f index c1441393cf..45dd54cade 100644 --- a/lapack-netlib/SRC/claed7.f +++ b/lapack-netlib/SRC/claed7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, * GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, * $ TLVLS @@ -34,7 +34,7 @@ * REAL D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) * COMPLEX Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine SLAED2. *> @@ -234,12 +234,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -249,10 +249,10 @@ SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, diff --git a/lapack-netlib/SRC/claed8.f b/lapack-netlib/SRC/claed8.f index 3d7c69f925..d66bf801ac 100644 --- a/lapack-netlib/SRC/claed8.f +++ b/lapack-netlib/SRC/claed8.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, * Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, * GIVCOL, GIVNUM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ * REAL RHO @@ -33,7 +33,7 @@ * $ Z( * ) * COMPLEX Q( LDQ, * ), Q2( LDQ2, * ) * .. -* +* * *> \par Purpose: * ============= @@ -214,12 +214,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -228,10 +228,10 @@ SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, $ GIVCOL, GIVNUM, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ @@ -291,8 +291,8 @@ SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, END IF * * Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 diff --git a/lapack-netlib/SRC/claein.f b/lapack-netlib/SRC/claein.f index ae7d8ee9b3..c4442d7929 100644 --- a/lapack-netlib/SRC/claein.f +++ b/lapack-netlib/SRC/claein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, * EPS3, SMLNUM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL NOINIT, RIGHTV * INTEGER INFO, LDB, LDH, N @@ -31,7 +31,7 @@ * REAL RWORK( * ) * COMPLEX B( LDB, * ), H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -149,10 +149,10 @@ SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, $ EPS3, SMLNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL NOINIT, RIGHTV diff --git a/lapack-netlib/SRC/claesy.f b/lapack-netlib/SRC/claesy.f index f155983962..c6a7b84318 100644 --- a/lapack-netlib/SRC/claesy.f +++ b/lapack-netlib/SRC/claesy.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAESY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAESY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) -* +* * .. Scalar Arguments .. * COMPLEX A, B, C, CS1, EVSCAL, RT1, RT2, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX A, B, C, CS1, EVSCAL, RT1, RT2, SN1 diff --git a/lapack-netlib/SRC/claev2.f b/lapack-netlib/SRC/claev2.f index dfdd965085..b80397fa7e 100644 --- a/lapack-netlib/SRC/claev2.f +++ b/lapack-netlib/SRC/claev2.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* +* * .. Scalar Arguments .. * REAL CS1, RT1, RT2 * COMPLEX A, B, C, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL CS1, RT1, RT2 diff --git a/lapack-netlib/SRC/clag2z.f b/lapack-netlib/SRC/clag2z.f index c7b4a59e58..a1777f0b59 100644 --- a/lapack-netlib/SRC/clag2z.f +++ b/lapack-netlib/SRC/clag2z.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAG2Z + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAG2Z + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. @@ -27,7 +27,7 @@ * COMPLEX SA( LDSA, * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDSA, M, N diff --git a/lapack-netlib/SRC/clags2.f b/lapack-netlib/SRC/clags2.f index 0feb7e83ab..7f507708fe 100644 --- a/lapack-netlib/SRC/clags2.f +++ b/lapack-netlib/SRC/clags2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, * SNV, CSQ, SNQ ) -* +* * .. Scalar Arguments .. * LOGICAL UPPER * REAL A1, A3, B1, B3, CSQ, CSU, CSV * COMPLEX A2, B2, SNQ, SNU, SNV * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -158,10 +158,10 @@ SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL UPPER diff --git a/lapack-netlib/SRC/clagtm.f b/lapack-netlib/SRC/clagtm.f index 05af7efbe4..dcf47a1e38 100644 --- a/lapack-netlib/SRC/clagtm.f +++ b/lapack-netlib/SRC/clagtm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAGTM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAGTM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -145,10 +145,10 @@ SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/clahef_aa.f b/lapack-netlib/SRC/clahef_aa.f new file mode 100644 index 0000000000..f3a9add2a6 --- /dev/null +++ b/lapack-netlib/SRC/clahef_aa.f @@ -0,0 +1,513 @@ +*> \brief \b CLAHEF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAHEF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAHEF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAHEF_AA factorizes a panel of a complex hermitian matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by CHETRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +* ===================================================================== + SUBROUTINE CLAHEF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = (0.0E+0, 0.0E+0), ONE = (1.0E+0, 0.0E+0) ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX, ILAENV + EXTERNAL LSAME, ILAENV, ICAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CONJG, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from CHETRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CLACGV( J-K1, A( 1, J ), 1 ) + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + CALL CLACGV( J-K1, A( 1, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -CONJG( A( K-1, J ) ) + CALL CAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = REAL( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL CAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) + CALL CLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA ) + CALL CLACGV( I2-I1-1, A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL CSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + END IF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL CCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL CSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL CLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from CHETRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CLACGV( J-K1, A( J, 1 ), LDA ) + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + CALL CLACGV( J-K1, A( J, 1 ), LDA ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -CONJG( A( J, K-1 ) ) + CALL CAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = REAL( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL CAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) + CALL CLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 ) + CALL CLACGV( I2-I1-1, A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL CSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL CCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL CSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL CLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M) + $ .AND. (INFO.EQ.0) ) INFO = J + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of CLAHEF_AA +* + END diff --git a/lapack-netlib/SRC/clahef_rk.f b/lapack-netlib/SRC/clahef_rk.f new file mode 100644 index 0000000000..4d9dfbe8e2 --- /dev/null +++ b/lapack-netlib/SRC/clahef_rk.f @@ -0,0 +1,1234 @@ +*> \brief \b CLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAHEF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CLAHEF_RK computes a partial factorization of a complex Hermitian +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> CLAHEF_RK is an auxiliary routine called by CHETRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), W( LDW, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, K, KK, KKW, + $ KP, KSTEP, KW, P + REAL ABSAKK, ALPHA, COLMAX, STEMP, R1, ROWMAX, T, + $ SFMIN + COMPLEX D11, D21, D22, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, AIMAG, MAX, MIN, REAL, SQRT +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 (note that conjg(W) is actually stored) +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + IF( K.GT.1 ) + $ CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = REAL( A( K, K ) ) + IF( K.LT.N ) THEN + CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) + W( K, KW ) = REAL( W( K, KW ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( W( K, KW ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( W( K, KW ) ) + IF( K.GT.1 ) + $ CALL CCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* +* Lop until pivot found +* + DONE = .FALSE. +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + IF( IMAX.GT.1 ) + $ CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), + $ 1 ) + W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) ) +* + CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) THEN + CALL CGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) + W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( W( IMAX,KW-1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* +* Interchange rows and columns P and K. +* Updated column P is already stored in column KW of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P of submatrix A +* at step K. No need to copy element into columns +* K and K-1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = REAL( A( K, K ) ) + CALL CCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + CALL CLACGV( K-1-P, A( P, P+1 ), LDA ) + IF( P.GT.1 ) + $ CALL CCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in the last K+1 to N columns of A +* (columns K and K-1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) + CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), + $ LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = REAL( A( KK, KK ) ) + CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) + IF( KP.GT.1 ) + $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) + CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column kw of W now holds +* +* W(kw) = U(k)*D(k), +* +* where U(k) is the k-th column of U +* +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = REAL( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL CSSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE + DO 14 II = 1, K-1 + A( II, K ) = A( II, K ) / T + 14 CONTINUE + END IF +* +* (2) Conjugate column W(kw) +* + CALL CLACGV( K-1, W( 1, KW ), 1 ) +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold +* +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) +* + IF( K.GT.2 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / CONJG( D21 ) + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( REAL( D11*D22 )-ONE ) +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = CZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = CZERO +* +* (2) Conjugate columns W(kw) and W(kw-1) +* + CALL CLACGV( K-1, W( 1, KW ), 1 ) + CALL CLACGV( K-2, W( 1, KW-1 ), 1 ) +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**H = A11 - U12*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 (note that conjg(W) is actually stored) +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update column K of W +* + W( K, K ) = REAL( A( K, K ) ) + IF( K.LT.N ) + $ CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + IF( K.GT.1 ) THEN + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) + W( K, K ) = REAL( W( K, K ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( W( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( W( K, K ) ) + IF( K.LT.N ) + $ CALL CCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column k+1 of W and update it +* + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL CLACGV( IMAX-K, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) ) +* + IF( IMAX.LT.N ) + $ CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, + $ W( IMAX+1, K+1 ), 1 ) +* + IF( K.GT.1 ) THEN + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = CABS1( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( W( IMAX,K+1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* +* End pivot search loop body +* + IF( .NOT.DONE ) GOTO 72 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* Interchange rows and columns P and K (only for 2-by-2 pivot). +* Updated column P is already stored in column K of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column KK-1 to column P of submatrix A +* at step K. No need to copy element into columns +* K and K+1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = REAL( A( K, K ) ) + CALL CCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + CALL CLACGV( P-K-1, A( P, K+1 ), LDA ) + IF( P.LT.N ) + $ CALL CCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* +* Interchange rows K and P in first K-1 columns of A +* (columns K and K+1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = REAL( A( KK, KK ) ) + CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) + IF( KP.LT.N ) + $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* +* Interchange rows KK and KP in first K-1 columns of A +* (column K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = REAL( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL CSSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / T + 74 CONTINUE + END IF +* +* (2) Conjugate column W(k) +* + CALL CLACGV( N-K, W( K+1, K ), 1 ) +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored. +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) +* + IF( K.LT.N-1 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / CONJG( D21 ) + T = ONE / ( REAL( D11*D22 )-ONE ) +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = CZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = CZERO +* +* (2) Conjugate columns W(k) and W(k+1) +* + CALL CLACGV( N-K, W( K+1, K ), 1 ) + CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**H = A22 - L21*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of CLAHEF_RK +* + END diff --git a/lapack-netlib/SRC/clahqr.f b/lapack-netlib/SRC/clahqr.f index 10131a45d7..de2b3938b6 100644 --- a/lapack-netlib/SRC/clahqr.f +++ b/lapack-netlib/SRC/clahqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAHQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N @@ -313,7 +313,7 @@ SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * * ITMAX is the total number of QR iterations allowed. * - ITMAX = 30 * MAX( 10, NH ) + ITMAX = 30 * MAX( 10, NH ) * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works diff --git a/lapack-netlib/SRC/clahr2.f b/lapack-netlib/SRC/clahr2.f index 6aea5d7ce9..50547f2cd8 100644 --- a/lapack-netlib/SRC/clahr2.f +++ b/lapack-netlib/SRC/clahr2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAHR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -198,7 +198,7 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Parameters .. COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. @@ -226,10 +226,10 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Update I-th column of A - Y * V**H * - CALL CLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL CLACGV( I-1, A( K+I-1, 1 ), LDA ) CALL CGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) - CALL CLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL CLACGV( I-1, A( K+I-1, 1 ), LDA ) * * Apply I - V * T**H * V**H to this column (call it b) from the * left, using the last column of T as workspace @@ -242,31 +242,31 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * w := V1**H * b1 * CALL CCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL CTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + CALL CTRMV( 'Lower', 'Conjugate transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**H * b2 * - CALL CGEMV( 'Conjugate transpose', N-K-I+1, I-1, + CALL CGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**H * w * - CALL CTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + CALL CTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * - CALL CGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + CALL CGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * - CALL CTRMV( 'Lower', 'NO TRANSPOSE', + CALL CTRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL CAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) @@ -284,13 +284,13 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Compute Y(K+1:N,I) * - CALL CGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + CALL CGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL CGEMV( 'Conjugate transpose', N-K-I+1, I-1, + CALL CGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL CGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + CALL CGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL CSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) @@ -298,7 +298,7 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute T(1:I,I) * CALL CSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL CTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + CALL CTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) @@ -309,15 +309,15 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute Y(1:K,1:NB) * CALL CLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL CTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + CALL CTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) - $ CALL CGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ CALL CGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) - CALL CTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + CALL CTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * diff --git a/lapack-netlib/SRC/claic1.f b/lapack-netlib/SRC/claic1.f index ac08e4161b..9aaecf48eb 100644 --- a/lapack-netlib/SRC/claic1.f +++ b/lapack-netlib/SRC/claic1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAIC1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAIC1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) -* +* * .. Scalar Arguments .. * INTEGER J, JOB * REAL SEST, SESTPR @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX W( J ), X( J ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER J, JOB diff --git a/lapack-netlib/SRC/clals0.f b/lapack-netlib/SRC/clals0.f index 78f18e9eda..90bff5889e 100644 --- a/lapack-netlib/SRC/clals0.f +++ b/lapack-netlib/SRC/clals0.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLALS0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, * $ LDGNUM, NL, NR, NRHS, SQRE @@ -34,7 +34,7 @@ * $ RWORK( * ), Z( * ) * COMPLEX B( LDB, * ), BX( LDBX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -249,12 +249,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -270,10 +270,10 @@ SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, diff --git a/lapack-netlib/SRC/clalsa.f b/lapack-netlib/SRC/clalsa.f index 86700c339e..8a817924d6 100644 --- a/lapack-netlib/SRC/clalsa.f +++ b/lapack-netlib/SRC/clalsa.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLALSA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, * GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, * $ SMLSIZ @@ -35,7 +35,7 @@ * $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * ) * COMPLEX B( LDB, * ), BX( LDBX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -246,12 +246,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -268,10 +268,10 @@ SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, diff --git a/lapack-netlib/SRC/clalsd.f b/lapack-netlib/SRC/clalsd.f index bca5ee93fc..5ebbb23b6c 100644 --- a/lapack-netlib/SRC/clalsd.f +++ b/lapack-netlib/SRC/clalsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLALSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, * RANK, WORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ @@ -31,7 +31,7 @@ * REAL D( * ), E( * ), RWORK( * ) * COMPLEX B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -186,10 +186,10 @@ SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, RWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clamswlq.f b/lapack-netlib/SRC/clamswlq.f new file mode 100644 index 0000000000..fd19f0af7c --- /dev/null +++ b/lapack-netlib/SRC/clamswlq.f @@ -0,0 +1,415 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAMQRTS overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product of blocked +*> elementary reflectors computed by short wide LQ +*> factorization (CLASWLQ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> M >= K >= 0; +*> +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > M. +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the blocked +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DLASWLQ in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension +*> ( M * Number of blocks(CEIL(N-K/NB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,NB) * MB; +*> if SIDE = 'R', LWORK >= max(1,M) * MB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW , CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL CTPMLQT, CGEMLQT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * MB + ELSE + LW = M * MB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, MB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAMSWLQ', -INFO ) + WORK(1) = LW + RETURN + ELSE IF (LQUERY) THEN + WORK(1) = LW + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN + CALL CGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(NB-K)) + CTR = (M-K)/(NB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL CTPMLQT('L','C',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+NB) +* + CTR = CTR - 1 + CALL CTPMLQT('L','C',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:NB) +* + CALL CGEMLQT('L','C',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(NB-K)) + II = M-KK+1 + CTR = 1 + CALL CGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (I:I+NB,1:N) +* + CALL CTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1, CTR *K+1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL CTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1, CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(NB-K)) + CTR = (N-K)/(NB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL CTPMLQT('R','N',M , KK, K, 0, MB, A(1, II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL CTPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL CGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(NB-K)) + II=N-KK+1 + CTR = 1 + CALL CGEMLQT('R','C',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL CTPMLQT('R','C',M , NB-K, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL CTPMLQT('R','C',M , KK, K, 0,MB, A(1,II), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of CLAMSWLQ +* + END diff --git a/lapack-netlib/SRC/clamtsqr.f b/lapack-netlib/SRC/clamtsqr.f new file mode 100644 index 0000000000..a787caab68 --- /dev/null +++ b/lapack-netlib/SRC/clamtsqr.f @@ -0,0 +1,414 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAMTSQR overwrites the general complex M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**C * C C * Q**C +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (CLATSQR) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Conjugate Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> N >= K >= 0; +*> +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > N. (must be the same as DLATSQR) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> blockedelementary reflector H(i), for i = 1,2,...,k, as +*> returned by DLATSQR in the first k columns of +*> its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension +*> ( N * Number of blocks(CEIL(M-K/MB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If SIDE = 'L', LWORK >= max(1,N)*NB; +*> if SIDE = 'R', LWORK >= max(1,MB)*NB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL CGEMQRT, CTPMQRT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * NB + ELSE + LW = M * NB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, NB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* +* Determine the block size if it is tall skinny or short and wide +* + IF( INFO.EQ.0) THEN + WORK(1) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAMTSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN + CALL CGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(MB-K)) + CTR = (M-K)/(MB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL CTPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA, + $ T(1, CTR*K+1),LDT , C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CTR = CTR - 1 + CALL CTPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:MB,1:N) +* + CALL CGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(MB-K)) + II=M-KK+1 + CTR = 1 + CALL CGEMQRT('L','C',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CALL CTPMQRT('L','C',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1, CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL CTPMQRT('L','C',KK , N, K, 0,NB, A(II,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(MB-K)) + CTR = (N-K)/(MB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL CTPMQRT('R','C',M , KK, K, 0, NB, A(II,1), LDA, + $ T(1, CTR*K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL CTPMQRT('R','C',M , MB-K, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL CGEMQRT('R','C',M , MB, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(MB-K)) + II=N-KK+1 + CTR = 1 + CALL CGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL CTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL CTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of CLAMTSQR +* + END diff --git a/lapack-netlib/SRC/clangb.f b/lapack-netlib/SRC/clangb.f index d3cc426ece..14a163ea7d 100644 --- a/lapack-netlib/SRC/clangb.f +++ b/lapack-netlib/SRC/clangb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER KL, KU, LDAB, N @@ -29,7 +29,7 @@ * REAL WORK( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBauxiliary * @@ -125,10 +125,10 @@ REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/clange.f b/lapack-netlib/SRC/clange.f index d5efdc814c..50f705a18d 100644 --- a/lapack-netlib/SRC/clange.f +++ b/lapack-netlib/SRC/clange.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEauxiliary * * ===================================================================== REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/clangt.f b/lapack-netlib/SRC/clangt.f index ff2677d98a..836e127fb2 100644 --- a/lapack-netlib/SRC/clangt.f +++ b/lapack-netlib/SRC/clangt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANGT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANGT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -149,11 +149,11 @@ REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 - IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) + IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) $ ANORM = ABS(DL(I)) - IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) + IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) $ ANORM = ABS(D(I)) - IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) + IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) $ ANORM = ABS(DU(I)) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN @@ -164,7 +164,7 @@ REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) - TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) + TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP DO 20 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) diff --git a/lapack-netlib/SRC/clanhb.f b/lapack-netlib/SRC/clanhb.f index 4ee7209b7e..2b034b19b5 100644 --- a/lapack-netlib/SRC/clanhb.f +++ b/lapack-netlib/SRC/clanhb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * REAL WORK( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -132,10 +132,10 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO @@ -179,7 +179,7 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, DO 20 J = 1, N DO 10 I = MAX( K+2-J, 1 ), K SUM = ABS( AB( I, J ) ) - IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 10 CONTINUE SUM = ABS( REAL( AB( K+1, J ) ) ) IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM diff --git a/lapack-netlib/SRC/clanhe.f b/lapack-netlib/SRC/clanhe.f index f1fc16dd1d..101d778eb0 100644 --- a/lapack-netlib/SRC/clanhe.f +++ b/lapack-netlib/SRC/clanhe.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEauxiliary * * ===================================================================== REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/clanhf.f b/lapack-netlib/SRC/clanhf.f index 3bd7eb146a..13e5fe300d 100644 --- a/lapack-netlib/SRC/clanhf.f +++ b/lapack-netlib/SRC/clanhf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, TRANSR, UPLO * INTEGER N @@ -28,7 +28,7 @@ * REAL WORK( 0: * ) * COMPLEX A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -246,10 +246,10 @@ * ===================================================================== REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, TRANSR, UPLO @@ -339,11 +339,11 @@ REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) J = 0 * -> L(0,0) TEMP = ABS( REAL( A( J+J*LDA ) ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP DO I = 1, N - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO DO J = 1, K - 1 @@ -726,7 +726,7 @@ REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE diff --git a/lapack-netlib/SRC/clanhp.f b/lapack-netlib/SRC/clanhp.f index a0a0d0778d..c8927d5033 100644 --- a/lapack-netlib/SRC/clanhp.f +++ b/lapack-netlib/SRC/clanhp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/clanhs.f b/lapack-netlib/SRC/clanhs.f index 8701cdbb5a..35623b73d7 100644 --- a/lapack-netlib/SRC/clanhs.f +++ b/lapack-netlib/SRC/clanhs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/clanht.f b/lapack-netlib/SRC/clanht.f index 28764a7e05..9e2be72cf8 100644 --- a/lapack-netlib/SRC/clanht.f +++ b/lapack-netlib/SRC/clanht.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANHT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANHT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANHT( NORM, N, D, E ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -28,7 +28,7 @@ * REAL D( * ) * COMPLEX E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANHT( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/clansb.f b/lapack-netlib/SRC/clansb.f index be006e5bb6..fbc50674c0 100644 --- a/lapack-netlib/SRC/clansb.f +++ b/lapack-netlib/SRC/clansb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * REAL WORK( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -130,10 +130,10 @@ REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/clansp.f b/lapack-netlib/SRC/clansp.f index c8c87b4785..fd64366c6e 100644 --- a/lapack-netlib/SRC/clansp.f +++ b/lapack-netlib/SRC/clansp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/clansy.f b/lapack-netlib/SRC/clansy.f index acef655b85..3aa787410c 100644 --- a/lapack-netlib/SRC/clansy.f +++ b/lapack-netlib/SRC/clansy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/clantb.f b/lapack-netlib/SRC/clantb.f index cfc447fd7d..4b4361c796 100644 --- a/lapack-netlib/SRC/clantb.f +++ b/lapack-netlib/SRC/clantb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANTB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANTB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, * LDAB, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * REAL WORK( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -141,10 +141,10 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO @@ -238,7 +238,7 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, SUM = SUM + ABS( AB( I, J ) ) 100 CONTINUE END IF - IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE DO 140 J = 1, N diff --git a/lapack-netlib/SRC/clantp.f b/lapack-netlib/SRC/clantp.f index f1c26dcab3..148ac5436b 100644 --- a/lapack-netlib/SRC/clantp.f +++ b/lapack-netlib/SRC/clantp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * REAL WORK( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,22 +113,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/clantr.f b/lapack-netlib/SRC/clantr.f index b728e1ba8a..4e1843d3dc 100644 --- a/lapack-netlib/SRC/clantr.f +++ b/lapack-netlib/SRC/clantr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLANTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLANTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER LDA, M, N @@ -29,7 +29,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -142,10 +142,10 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/clapll.f b/lapack-netlib/SRC/clapll.f index 58df00be51..5465372da7 100644 --- a/lapack-netlib/SRC/clapll.f +++ b/lapack-netlib/SRC/clapll.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAPLL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAPLL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * REAL SSMIN @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,22 +88,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/clapmr.f b/lapack-netlib/SRC/clapmr.f index c4f8ca6eae..e01d5bfca1 100644 --- a/lapack-netlib/SRC/clapmr.f +++ b/lapack-netlib/SRC/clapmr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAPMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAPMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * COMPLEX X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/clapmt.f b/lapack-netlib/SRC/clapmt.f index fca8606d9d..3b22e09ea9 100644 --- a/lapack-netlib/SRC/clapmt.f +++ b/lapack-netlib/SRC/clapmt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAPMT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAPMT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * COMPLEX X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/claqgb.f b/lapack-netlib/SRC/claqgb.f index 76f5ad765a..636c6842a4 100644 --- a/lapack-netlib/SRC/claqgb.f +++ b/lapack-netlib/SRC/claqgb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER KL, KU, LDAB, M, N @@ -30,7 +30,7 @@ * REAL C( * ), R( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGBauxiliary * @@ -160,10 +160,10 @@ SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/claqge.f b/lapack-netlib/SRC/claqge.f index af73c363b7..9d9efa30fb 100644 --- a/lapack-netlib/SRC/claqge.f +++ b/lapack-netlib/SRC/claqge.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER LDA, M, N @@ -30,7 +30,7 @@ * REAL C( * ), R( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEauxiliary * @@ -143,10 +143,10 @@ SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/claqhb.f b/lapack-netlib/SRC/claqhb.f index 6703a73373..db69875264 100644 --- a/lapack-netlib/SRC/claqhb.f +++ b/lapack-netlib/SRC/claqhb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQHB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQHB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/claqhe.f b/lapack-netlib/SRC/claqhe.f index aac9891a26..14714b5180 100644 --- a/lapack-netlib/SRC/claqhe.f +++ b/lapack-netlib/SRC/claqhe.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQHE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexHEauxiliary * * ===================================================================== SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/claqhp.f b/lapack-netlib/SRC/claqhp.f index 2f2ca428e3..c41eb184b7 100644 --- a/lapack-netlib/SRC/claqhp.f +++ b/lapack-netlib/SRC/claqhp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQHP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQHP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/claqp2.f b/lapack-netlib/SRC/claqp2.f index 06b06e07e3..33f2a8e08d 100644 --- a/lapack-netlib/SRC/claqp2.f +++ b/lapack-netlib/SRC/claqp2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. @@ -29,7 +29,7 @@ * REAL VN1( * ), VN2( * ) * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -67,7 +67,7 @@ *> \verbatim *> A is COMPLEX array, dimension (LDA,N) *> On entry, the M-by-N matrix A. -*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is *> the triangular factor obtained; the elements in block *> A(OFFSET+1:M,1:N) below the diagonal, together with the *> array TAU, represent the orthogonal matrix Q as a product of @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -142,17 +142,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET diff --git a/lapack-netlib/SRC/claqps.f b/lapack-netlib/SRC/claqps.f index a1b183616f..f47e852a04 100644 --- a/lapack-netlib/SRC/claqps.f +++ b/lapack-netlib/SRC/claqps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, * VN2, AUXV, F, LDF ) -* +* * .. Scalar Arguments .. * INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. @@ -29,7 +29,7 @@ * REAL VN1( * ), VN2( * ) * COMPLEX A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -171,17 +171,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET @@ -355,9 +355,9 @@ SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = SCNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * -* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) +* SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP diff --git a/lapack-netlib/SRC/claqr0.f b/lapack-netlib/SRC/claqr0.f index cf97579c69..b61c9f1e9c 100644 --- a/lapack-netlib/SRC/claqr0.f +++ b/lapack-netlib/SRC/claqr0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -209,12 +209,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -240,10 +240,10 @@ SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/claqr1.f b/lapack-netlib/SRC/claqr1.f index 129201d1d4..d3141e8ad8 100644 --- a/lapack-netlib/SRC/claqr1.f +++ b/lapack-netlib/SRC/claqr1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) -* +* * .. Scalar Arguments .. * COMPLEX S1, S2 * INTEGER LDH, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,12 +89,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -107,10 +107,10 @@ * ===================================================================== SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX S1, S2 diff --git a/lapack-netlib/SRC/claqr2.f b/lapack-netlib/SRC/claqr2.f index d7015b5560..aead5d6618 100644 --- a/lapack-netlib/SRC/claqr2.f +++ b/lapack-netlib/SRC/claqr2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, * NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -31,7 +31,7 @@ * COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,7 +140,7 @@ *> Z is COMPLEX array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the unitary *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -249,12 +249,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -269,10 +269,10 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/claqr3.f b/lapack-netlib/SRC/claqr3.f index 53e0e3c42f..eff3f01e73 100644 --- a/lapack-netlib/SRC/claqr3.f +++ b/lapack-netlib/SRC/claqr3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, * NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -31,7 +31,7 @@ * COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,7 +137,7 @@ *> Z is COMPLEX array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the unitary *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -246,12 +246,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * @@ -266,10 +266,10 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/claqr4.f b/lapack-netlib/SRC/claqr4.f index 80db6a2963..573b1aab4a 100644 --- a/lapack-netlib/SRC/claqr4.f +++ b/lapack-netlib/SRC/claqr4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -28,8 +28,8 @@ * .. Array Arguments .. * COMPLEX H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -218,12 +218,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -249,10 +249,10 @@ SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/claqr5.f b/lapack-netlib/SRC/claqr5.f index fc412c4dad..94a5bdf2cc 100644 --- a/lapack-netlib/SRC/claqr5.f +++ b/lapack-netlib/SRC/claqr5.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQR5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, * WV, LDWV, NH, WH, LDWH ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, * $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV @@ -31,7 +31,7 @@ * COMPLEX H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), * $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,10 +142,10 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is COMPLEX array of size (LDZ,IHI) +*> Z is COMPLEX array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep unitary *> similarity transformation is accumulated into -*> Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * @@ -251,10 +251,10 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, $ WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, diff --git a/lapack-netlib/SRC/claqsb.f b/lapack-netlib/SRC/claqsb.f index 09c5eae842..004645a0f3 100644 --- a/lapack-netlib/SRC/claqsb.f +++ b/lapack-netlib/SRC/claqsb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/claqsp.f b/lapack-netlib/SRC/claqsp.f index 6b9a3498ad..2a962d42d4 100644 --- a/lapack-netlib/SRC/claqsp.f +++ b/lapack-netlib/SRC/claqsp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/claqsy.f b/lapack-netlib/SRC/claqsy.f index 6e31e1aa69..6d5f7da1ee 100644 --- a/lapack-netlib/SRC/claqsy.f +++ b/lapack-netlib/SRC/claqsy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAQSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAQSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/clar1v.f b/lapack-netlib/SRC/clar1v.f index c8583735ad..972c82cc78 100644 --- a/lapack-netlib/SRC/clar1v.f +++ b/lapack-netlib/SRC/clar1v.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAR1V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAR1V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, * PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, * R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) -* +* * .. Scalar Arguments .. * LOGICAL WANTNC * INTEGER B1, BN, N, NEGCNT, R @@ -34,7 +34,7 @@ * $ WORK( * ) * COMPLEX Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -207,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -230,10 +230,10 @@ SUBROUTINE CLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTNC diff --git a/lapack-netlib/SRC/clar2v.f b/lapack-netlib/SRC/clar2v.f index d17158aeb0..8dd17164fe 100644 --- a/lapack-netlib/SRC/clar2v.f +++ b/lapack-netlib/SRC/clar2v.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAR2V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAR2V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, N * .. @@ -27,7 +27,7 @@ * REAL C( * ) * COMPLEX S( * ), X( * ), Y( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, N diff --git a/lapack-netlib/SRC/clarcm.f b/lapack-netlib/SRC/clarcm.f index 30a9204377..b22af2da58 100644 --- a/lapack-netlib/SRC/clarcm.f +++ b/lapack-netlib/SRC/clarcm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARCM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARCM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, M, N * .. @@ -27,7 +27,7 @@ * REAL A( LDA, * ), RWORK( * ) * COMPLEX B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,7 +61,7 @@ *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA, M) -*> A contains the M by M matrix A. +*> On entry, A contains the M by M matrix A. *> \endverbatim *> *> \param[in] LDA @@ -72,8 +72,8 @@ *> *> \param[in] B *> \verbatim -*> B is REAL array, dimension (LDB, N) -*> B contains the M by N matrix B. +*> B is COMPLEX array, dimension (LDB, N) +*> On entry, B contains the M by N matrix B. *> \endverbatim *> *> \param[in] LDB @@ -82,10 +82,10 @@ *> The leading dimension of the array B. LDB >=max(1,M). *> \endverbatim *> -*> \param[in] C +*> \param[out] C *> \verbatim *> C is COMPLEX array, dimension (LDC, N) -*> C contains the M by N matrix C. +*> On exit, C contains the M by N matrix C. *> \endverbatim *> *> \param[in] LDC @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, M, N diff --git a/lapack-netlib/SRC/clarf.f b/lapack-netlib/SRC/clarf.f index f075b34690..72140d52a2 100644 --- a/lapack-netlib/SRC/clarf.f +++ b/lapack-netlib/SRC/clarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/clarfb.f b/lapack-netlib/SRC/clarfb.f index 19d7b81ca1..8fdd5c89c2 100644 --- a/lapack-netlib/SRC/clarfb.f +++ b/lapack-netlib/SRC/clarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, * T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,10 +154,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date June 2013 * @@ -195,7 +195,7 @@ SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * June 2013 diff --git a/lapack-netlib/SRC/clarfg.f b/lapack-netlib/SRC/clarfg.f index e63f0582ca..05a27a283c 100644 --- a/lapack-netlib/SRC/clarfg.f +++ b/lapack-netlib/SRC/clarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/clarfgp.f b/lapack-netlib/SRC/clarfgp.f index bdcf8a78ef..d5f19b0411 100644 --- a/lapack-netlib/SRC/clarfgp.f +++ b/lapack-netlib/SRC/clarfgp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARFGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARFGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N @@ -222,7 +222,7 @@ SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU ) IF ( ABS(TAU).LE.SMLNUM ) THEN * * In the case where the computed TAU ends up being a denormalized number, -* it loses relative accuracy. This is a BIG problem. Solution: flush TAU +* it loses relative accuracy. This is a BIG problem. Solution: flush TAU * to ZERO (or TWO or whatever makes a nonnegative real number for BETA). * * (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) @@ -249,7 +249,7 @@ SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU ) BETA = XNORM END IF * - ELSE + ELSE * * This is the general case. * diff --git a/lapack-netlib/SRC/clarft.f b/lapack-netlib/SRC/clarft.f index 681897dcaa..296467a9f2 100644 --- a/lapack-netlib/SRC/clarft.f +++ b/lapack-netlib/SRC/clarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -187,7 +187,7 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. - EXTERNAL CGEMV, CLACGV, CTRMV + EXTERNAL CGEMM, CGEMV, CTRMV * .. * .. External Functions .. LOGICAL LSAME @@ -222,13 +222,13 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) * CALL CGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, + $ -TAU( I ), V( I+1, 1 ), LDV, $ V( I+1, I ), 1, $ ONE, T( 1, I ), 1 ) ELSE @@ -238,14 +238,14 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H * CALL CGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) + $ ONE, T( 1, I ), LDT ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) @@ -282,7 +282,7 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) @@ -297,14 +297,14 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H * CALL CGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) + $ ONE, T( I+1, I ), LDT ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) diff --git a/lapack-netlib/SRC/clarfx.f b/lapack-netlib/SRC/clarfx.f index c05823ce5a..1111c80f79 100644 --- a/lapack-netlib/SRC/clarfx.f +++ b/lapack-netlib/SRC/clarfx.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARFX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,22 +107,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/clarfy.f b/lapack-netlib/SRC/clarfy.f new file mode 100644 index 0000000000..a5743858c4 --- /dev/null +++ b/lapack-netlib/SRC/clarfy.f @@ -0,0 +1,163 @@ +*> \brief \b CLARFY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* COMPLEX TAU +* .. +* .. Array Arguments .. +* COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLARFY applies an elementary reflector, or Householder matrix, H, +*> to an n x n Hermitian matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER INCV, LDC, N + COMPLEX TAU +* .. +* .. Array Arguments .. + COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO, HALF + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ), + $ HALF = ( 0.5E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX ALPHA +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CHEMV, CHER2 +* .. +* .. External Functions .. + COMPLEX CDOTC + EXTERNAL CDOTC +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL CHEMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*CDOTC( N, WORK, 1, V, INCV ) + CALL CAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL CHER2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of CLARFY +* + END diff --git a/lapack-netlib/SRC/clargv.f b/lapack-netlib/SRC/clargv.f index 425a30c1eb..ba53cae6f0 100644 --- a/lapack-netlib/SRC/clargv.f +++ b/lapack-netlib/SRC/clargv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. @@ -27,7 +27,7 @@ * REAL C( * ) * COMPLEX X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,12 +99,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -122,10 +122,10 @@ * ===================================================================== SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/clarnv.f b/lapack-netlib/SRC/clarnv.f index 98ffe29ab2..9b26f4fd14 100644 --- a/lapack-netlib/SRC/clarnv.f +++ b/lapack-netlib/SRC/clarnv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARNV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARNV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARNV( IDIST, ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -76,12 +76,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -99,10 +99,10 @@ * ===================================================================== SUBROUTINE CLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, N diff --git a/lapack-netlib/SRC/clarrv.f b/lapack-netlib/SRC/clarrv.f index ecedfa4d24..1e1a30997f 100644 --- a/lapack-netlib/SRC/clarrv.f +++ b/lapack-netlib/SRC/clarrv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARRV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARRV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RTOL1, RTOL2, W, WERR, WGAP, * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER DOL, DOU, INFO, LDZ, M, N * REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU @@ -35,7 +35,7 @@ * $ WGAP( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,12 +59,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> Lower bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> Lower and upper bounds of the interval that contains the desired +*> Upper bound of the interval that contains the desired *> eigenvalues. VL < VU. Needed to compute gaps on the left or right *> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim @@ -81,7 +84,7 @@ *> L is REAL array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the unit *> bidiagonal matrix L are in elements 1 to N-1 of L -*> (if the matrix is not splitted.) At the end of each block +*> (if the matrix is not split.) At the end of each block *> is stored the corresponding shift as given by SLARRE. *> On exit, L is overwritten. *> \endverbatim @@ -236,7 +239,7 @@ *> INFO is INTEGER *> = 0: successful exit *> -*> > 0: A problem occured in CLARRV. +*> > 0: A problem occurred in CLARRV. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -258,12 +261,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * @@ -283,10 +286,10 @@ SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN, $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER DOL, DOU, INFO, LDZ, M, N diff --git a/lapack-netlib/SRC/clarscl2.f b/lapack-netlib/SRC/clarscl2.f index ada9535c33..e7c1c215d2 100644 --- a/lapack-netlib/SRC/clarscl2.f +++ b/lapack-netlib/SRC/clarscl2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARSCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARSCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARSCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. @@ -27,7 +27,7 @@ * COMPLEX X( LDX, * ) * REAL D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,28 +73,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLARSCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/clartg.f b/lapack-netlib/SRC/clartg.f index cfff122a19..da9a1cdefa 100644 --- a/lapack-netlib/SRC/clartg.f +++ b/lapack-netlib/SRC/clartg.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * REAL CS * COMPLEX F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -80,12 +80,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -103,10 +103,10 @@ * ===================================================================== SUBROUTINE CLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. REAL CS diff --git a/lapack-netlib/SRC/clartv.f b/lapack-netlib/SRC/clartv.f index 843ed4447c..c366c7dccc 100644 --- a/lapack-netlib/SRC/clartv.f +++ b/lapack-netlib/SRC/clartv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARTV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARTV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. @@ -27,7 +27,7 @@ * REAL C( * ) * COMPLEX S( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/clarz.f b/lapack-netlib/SRC/clarz.f index 4ab0477353..b7fde54382 100644 --- a/lapack-netlib/SRC/clarz.f +++ b/lapack-netlib/SRC/clarz.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, L, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/clarzb.f b/lapack-netlib/SRC/clarzb.f index d6c9ef30b9..ffa884282e 100644 --- a/lapack-netlib/SRC/clarzb.f +++ b/lapack-netlib/SRC/clarzb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARZB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARZB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * LDV, T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -183,10 +183,10 @@ SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff --git a/lapack-netlib/SRC/clarzt.f b/lapack-netlib/SRC/clarzt.f index 65e8683038..6bea5d465f 100644 --- a/lapack-netlib/SRC/clarzt.f +++ b/lapack-netlib/SRC/clarzt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLARZT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLARZT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff --git a/lapack-netlib/SRC/clascl.f b/lapack-netlib/SRC/clascl.f index a5ab897ba3..b760bab50d 100644 --- a/lapack-netlib/SRC/clascl.f +++ b/lapack-netlib/SRC/clascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lapack-netlib/SRC/clascl2.f b/lapack-netlib/SRC/clascl2.f index f45f85e183..d3a5b9144d 100644 --- a/lapack-netlib/SRC/clascl2.f +++ b/lapack-netlib/SRC/clascl2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. @@ -27,7 +27,7 @@ * REAL D( * ) * COMPLEX X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,28 +73,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLASCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/claset.f b/lapack-netlib/SRC/claset.f index e12cda8667..fe49fd56fc 100644 --- a/lapack-netlib/SRC/claset.f +++ b/lapack-netlib/SRC/claset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clasr.f b/lapack-netlib/SRC/clasr.f index 7b5daf1d96..8c6216b41b 100644 --- a/lapack-netlib/SRC/clasr.f +++ b/lapack-netlib/SRC/clasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * REAL C( * ), S( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,23 +49,23 @@ *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -74,13 +74,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -89,12 +89,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -103,7 +103,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -188,22 +188,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lapack-netlib/SRC/classq.f b/lapack-netlib/SRC/classq.f index 0c0fd20622..28398596f2 100644 --- a/lapack-netlib/SRC/classq.f +++ b/lapack-netlib/SRC/classq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/claswlq.f b/lapack-netlib/SRC/claswlq.f new file mode 100644 index 0000000000..8b77142dfb --- /dev/null +++ b/lapack-netlib/SRC/claswlq.f @@ -0,0 +1,262 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLASWLQ computes a blocked Short-Wide LQ factorization of a +*> M-by-N matrix A, where N >= M: +*> A = L * Q +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and bleow the diagonal +*> of the array contain the N-by-N lower triangular matrix L; +*> the elements above the diagonal represent Q by the rows +*> of blocked V (see Further Details). +*> +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((N-M)/(NB-M)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= MB*M. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, + $ INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ), T( LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL CGELQT, CTPLQT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.LT.M ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN + INFO = -3 + ELSE IF( NB.LE.M ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -8 + ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = MB*M + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLASWLQ', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN + CALL CGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((N-M),(NB-M)) + II=N-KK+1 +* +* Compute the LQ factorization of the first block A(1:M,1:NB) +* + CALL CGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO) + CTR = 1 +* + DO I = NB+1, II-NB+M , (NB-M) +* +* Compute the QR factorization of the current block A(1:M,I:I+NB-M) +* + CALL CTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ), + $ LDA, T(1,CTR*M+1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(1:M,II:N) +* + IF (II.LE.N) THEN + CALL CTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ), + $ LDA, T(1,CTR*M+1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = M * MB + RETURN +* +* End of CLASWLQ +* + END diff --git a/lapack-netlib/SRC/claswp.f b/lapack-netlib/SRC/claswp.f index 90a2565bbc..8b5632c858 100644 --- a/lapack-netlib/SRC/claswp.f +++ b/lapack-netlib/SRC/claswp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,15 +71,15 @@ *> \param[in] K2 *> \verbatim *> K2 is INTEGER -*> The last element of IPIV for which a row interchange will -*> be done. +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*INCX of IPIV are accessed. *> IPIV(K) = L implies rows K and L are to be interchanged. *> \endverbatim *> @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -143,7 +143,7 @@ SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX + IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 diff --git a/lapack-netlib/SRC/clasyf_aa.f b/lapack-netlib/SRC/clasyf_aa.f new file mode 100644 index 0000000000..2c8cdc46ac --- /dev/null +++ b/lapack-netlib/SRC/clasyf_aa.f @@ -0,0 +1,506 @@ +*> \brief \b CLASYF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLASYF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AA factorizes a panel of a complex symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by CSYTRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is REAL workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +* ===================================================================== + SUBROUTINE CLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX, ILAENV + EXTERNAL LSAME, ILAENV, ICAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from CSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL CAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL CAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL CSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL CCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL CSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL CLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from CSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL CAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL CAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL CSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL CCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL CSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL CLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of CLASYF_AA +* + END diff --git a/lapack-netlib/SRC/clasyf_rk.f b/lapack-netlib/SRC/clasyf_rk.f new file mode 100644 index 0000000000..0700c5cc29 --- /dev/null +++ b/lapack-netlib/SRC/clasyf_rk.f @@ -0,0 +1,974 @@ +*> \brief \b CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLASYF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CLASYF_RK computes a partial factorization of a complex symmetric +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> CLASYF_RK is an auxiliary routine called by CSYTRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, + $ KP, KSTEP, P, II + REAL ABSAKK, ALPHA, COLMAX, ROWMAX, SFMIN, STEMP + COMPLEX D11, D12, D21, D22, R1, T, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, MAX, MIN, REAL, SQRT +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL CGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL CCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL CCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL CSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL CSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = CONE / ( D11*D22-CONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = CZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), + $ LDW, CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = CABS1( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL CCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL CCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL CSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL CSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = CZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF +* + RETURN +* +* End of CLASYF_RK +* + END diff --git a/lapack-netlib/SRC/clatbs.f b/lapack-netlib/SRC/clatbs.f index 223aa26065..3bb7bff880 100644 --- a/lapack-netlib/SRC/clatbs.f +++ b/lapack-netlib/SRC/clatbs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATBS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATBS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, * SCALE, CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * REAL CNORM( * ) * COMPLEX AB( LDAB, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -243,10 +243,10 @@ SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/clatdf.f b/lapack-netlib/SRC/clatdf.f index 11f0dfd9b0..357f664223 100644 --- a/lapack-netlib/SRC/clatdf.f +++ b/lapack-netlib/SRC/clatdf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATDF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATDF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * REAL RDSCAL, RDSUM @@ -29,7 +29,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX RHS( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> Zx = +-e - f with the sign giving the greater value of *> 2-norm(x). About 5 times as expensive as Default. *> IJOB .ne. 2: Local look ahead strategy where -*> all entries of the r.h.s. b is choosen as either +1 or +*> all entries of the r.h.s. b is chosen as either +1 or *> -1. Default. *> \endverbatim *> @@ -70,7 +70,7 @@ *> *> \param[in] Z *> \verbatim -*> Z is REAL array, dimension (LDZ, N) +*> Z is COMPLEX array, dimension (LDZ, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix Z computed by CGETC2: Z = P * L * U * Q *> \endverbatim @@ -83,7 +83,7 @@ *> *> \param[in,out] RHS *> \verbatim -*> RHS is REAL array, dimension (N). +*> RHS is COMPLEX array, dimension (N). *> On entry, RHS contains contributions from other subsystems. *> On exit, RHS contains the solution of the subsystem with *> entries according to the value of IJOB (see above). @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERauxiliary * @@ -169,10 +169,10 @@ SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IJOB, LDZ, N diff --git a/lapack-netlib/SRC/clatps.f b/lapack-netlib/SRC/clatps.f index fbda438d6b..402b33eae4 100644 --- a/lapack-netlib/SRC/clatps.f +++ b/lapack-netlib/SRC/clatps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * REAL CNORM( * ) * COMPLEX AP( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -231,10 +231,10 @@ SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/clatrd.f b/lapack-netlib/SRC/clatrd.f index 9d45668ee1..1ad84c1172 100644 --- a/lapack-netlib/SRC/clatrd.f +++ b/lapack-netlib/SRC/clatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -28,7 +28,7 @@ * REAL E( * ) * COMPLEX A( LDA, * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -199,10 +199,10 @@ * ===================================================================== SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clatrs.f b/lapack-netlib/SRC/clatrs.f index a3f8df3512..8fc539b308 100644 --- a/lapack-netlib/SRC/clatrs.f +++ b/lapack-netlib/SRC/clatrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * REAL CNORM( * ) * COMPLEX A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -239,10 +239,10 @@ SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/clatrz.f b/lapack-netlib/SRC/clatrz.f index afdfc9a13f..0328e31c39 100644 --- a/lapack-netlib/SRC/clatrz.f +++ b/lapack-netlib/SRC/clatrz.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLATRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLATRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK ) -* +* * .. Scalar Arguments .. * INTEGER L, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER L, LDA, M, N diff --git a/lapack-netlib/SRC/clatsqr.f b/lapack-netlib/SRC/clatsqr.f new file mode 100644 index 0000000000..dab5774c1b --- /dev/null +++ b/lapack-netlib/SRC/clatsqr.f @@ -0,0 +1,255 @@ +* +* Definition: +* =========== +* +* SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLATSQR computes a blocked Tall-Skinny QR factorization of +*> an M-by-N matrix A, where M >= N: +*> A = Q * R . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> MB > N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal +*> of the array contain the N-by-N upper triangular matrix R; +*> the elements below the diagonal represent Q by the columns +*> of blocked V (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((M-N)/(MB-N)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= NB*N. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, + $ LWORK, INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ), T(LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL CGEQRT, CTPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. M.LT.N ) THEN + INFO = -2 + ELSE IF( MB.LE.N ) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -8 + ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = NB*N + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLATSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF ((MB.LE.N).OR.(MB.GE.M)) THEN + CALL CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF + KK = MOD((M-N),(MB-N)) + II=M-KK+1 +* +* Compute the QR factorization of the first block A(1:MB,1:N) +* + CALL CGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO ) + CTR = 1 +* + DO I = MB+1, II-MB+N , (MB-N) +* +* Compute the QR factorization of the current block A(I:I+MB-N,1:N) +* + CALL CTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA, + $ T(1,CTR * N + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(II:M,1:N) +* + IF (II.LE.M) THEN + CALL CTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA, + $ T(1, CTR * N + 1), LDT, + $ WORK, INFO ) + END IF +* + work( 1 ) = N*NB + RETURN +* +* End of CLATSQR +* + END diff --git a/lapack-netlib/SRC/clauu2.f b/lapack-netlib/SRC/clauu2.f index 0e0830b2db..930662d0f2 100644 --- a/lapack-netlib/SRC/clauu2.f +++ b/lapack-netlib/SRC/clauu2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAUU2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAUU2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/clauum.f b/lapack-netlib/SRC/clauum.f index 9e12e25d5f..eb9f894867 100644 --- a/lapack-netlib/SRC/clauum.f +++ b/lapack-netlib/SRC/clauum.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAUUM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAUUM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbcon.f b/lapack-netlib/SRC/cpbcon.f index 17f2f6c23a..174f840306 100644 --- a/lapack-netlib/SRC/cpbcon.f +++ b/lapack-netlib/SRC/cpbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -133,10 +133,10 @@ SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbequ.f b/lapack-netlib/SRC/cpbequ.f index 5724553b1b..922c44b1fc 100644 --- a/lapack-netlib/SRC/cpbequ.f +++ b/lapack-netlib/SRC/cpbequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbrfs.f b/lapack-netlib/SRC/cpbrfs.f index c86a6a467c..7bf13e9274 100644 --- a/lapack-netlib/SRC/cpbrfs.f +++ b/lapack-netlib/SRC/cpbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, * LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbstf.f b/lapack-netlib/SRC/cpbstf.f index 4ffc862139..f344bf812c 100644 --- a/lapack-netlib/SRC/cpbstf.f +++ b/lapack-netlib/SRC/cpbstf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBSTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBSTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbsv.f b/lapack-netlib/SRC/cpbsv.f index 4ca0238dc2..b1a1fab0f2 100644 --- a/lapack-netlib/SRC/cpbsv.f +++ b/lapack-netlib/SRC/cpbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsolve * @@ -164,10 +164,10 @@ * ===================================================================== SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbsvx.f b/lapack-netlib/SRC/cpbsvx.f index 53f4469719..fde0564e41 100644 --- a/lapack-netlib/SRC/cpbsvx.f +++ b/lapack-netlib/SRC/cpbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, * EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -296,10 +296,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -342,7 +342,7 @@ SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cpbtf2.f b/lapack-netlib/SRC/cpbtf2.f index 502f6e04db..f871dd7ddd 100644 --- a/lapack-netlib/SRC/cpbtf2.f +++ b/lapack-netlib/SRC/cpbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbtrf.f b/lapack-netlib/SRC/cpbtrf.f index 729374e651..8854cbee70 100644 --- a/lapack-netlib/SRC/cpbtrf.f +++ b/lapack-netlib/SRC/cpbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpbtrs.f b/lapack-netlib/SRC/cpbtrs.f index 67a1fd8652..1fef333373 100644 --- a/lapack-netlib/SRC/cpbtrs.f +++ b/lapack-netlib/SRC/cpbtrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpftrf.f b/lapack-netlib/SRC/cpftrf.f index ce1803d7a4..6d0b527911 100644 --- a/lapack-netlib/SRC/cpftrf.f +++ b/lapack-netlib/SRC/cpftrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPFTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPFTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER N, INFO * .. * .. Array Arguments .. * COMPLEX A( 0: * ) -* +* * *> \par Purpose: * ============= @@ -199,22 +199,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/cpftri.f b/lapack-netlib/SRC/cpftri.f index e6ad0d01c0..e2b5690da7 100644 --- a/lapack-netlib/SRC/cpftri.f +++ b/lapack-netlib/SRC/cpftri.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. Array Arguments .. * COMPLEX A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -212,10 +212,10 @@ * ===================================================================== SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/cpftrs.f b/lapack-netlib/SRC/cpftrs.f index e0abb2b5bb..739ae27de1 100644 --- a/lapack-netlib/SRC/cpftrs.f +++ b/lapack-netlib/SRC/cpftrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPFTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPFTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( 0: * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -220,10 +220,10 @@ * ===================================================================== SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/cpocon.f b/lapack-netlib/SRC/cpocon.f index ad8d65882c..fbaba80b68 100644 --- a/lapack-netlib/SRC/cpocon.f +++ b/lapack-netlib/SRC/cpocon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * @@ -121,10 +121,10 @@ SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpoequ.f b/lapack-netlib/SRC/cpoequ.f index cf9101eafe..1463d3c996 100644 --- a/lapack-netlib/SRC/cpoequ.f +++ b/lapack-netlib/SRC/cpoequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -28,7 +28,7 @@ * REAL S( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/cpoequb.f b/lapack-netlib/SRC/cpoequb.f index d7cb961a10..68641bf676 100644 --- a/lapack-netlib/SRC/cpoequb.f +++ b/lapack-netlib/SRC/cpoequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ) * REAL S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,13 +36,19 @@ *> \verbatim *> *> CPOEQUB computes row and column scalings intended to equilibrate a -*> symmetric positive definite matrix A and reduce its condition number +*> Hermitian positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. +*> +*> This routine differs from CPOEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled diagonal entries are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: @@ -57,7 +63,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) -*> The N-by-N symmetric positive definite matrix whose scaling +*> The N-by-N Hermitian positive definite matrix whose scaling *> factors are to be computed. Only the diagonal elements of A *> are referenced. *> \endverbatim @@ -101,22 +107,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/cporfs.f b/lapack-netlib/SRC/cporfs.f index e296cf04c2..bd4054cecd 100644 --- a/lapack-netlib/SRC/cporfs.f +++ b/lapack-netlib/SRC/cporfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPORFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPORFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, * LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * @@ -183,10 +183,10 @@ SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cporfsx.f b/lapack-netlib/SRC/cporfsx.f index f1d90786e4..872bad36c7 100644 --- a/lapack-netlib/SRC/cporfsx.f +++ b/lapack-netlib/SRC/cporfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPORFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPORFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -378,10 +378,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -393,7 +393,7 @@ SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -453,12 +453,11 @@ SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL SLAMCH, CLANHE, CLA_PORCOND_X, CLA_PORCOND_C REAL SLAMCH, CLANHE, CLA_PORCOND_X, CLA_PORCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/cposv.f b/lapack-netlib/SRC/cposv.f index 68acf218fc..ecd61ec0a4 100644 --- a/lapack-netlib/SRC/cposv.f +++ b/lapack-netlib/SRC/cposv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOsolve * * ===================================================================== SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cposvx.f b/lapack-netlib/SRC/cposvx.f index ee1015905c..aec8db211e 100644 --- a/lapack-netlib/SRC/cposvx.f +++ b/lapack-netlib/SRC/cposvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, * S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -292,10 +292,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -306,7 +306,7 @@ SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cposvxx.f b/lapack-netlib/SRC/cposvxx.f index 6b985e2355..64d1b67fa6 100644 --- a/lapack-netlib/SRC/cposvxx.f +++ b/lapack-netlib/SRC/cposvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -481,10 +481,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -496,7 +496,7 @@ SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -540,7 +540,7 @@ SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, REAL SLAMCH, CLA_PORPVGRW * .. * .. External Subroutines .. - EXTERNAL CPOCON, CPOEQUB, CPOTRF, CPOTRS, CLACPY, + EXTERNAL CPOEQUB, CPOTRF, CPOTRS, CLACPY, $ CLAQHE, XERBLA, CLASCL2, CPORFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/cpotf2.f b/lapack-netlib/SRC/cpotf2.f index cbab9f5a51..16b917ad45 100644 --- a/lapack-netlib/SRC/cpotf2.f +++ b/lapack-netlib/SRC/cpotf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpotrf.f b/lapack-netlib/SRC/cpotrf.f index dcb61f6134..1d981bf7b0 100644 --- a/lapack-netlib/SRC/cpotrf.f +++ b/lapack-netlib/SRC/cpotrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpotrf2.f b/lapack-netlib/SRC/cpotrf2.f index 6ab06a637d..789843c41d 100644 --- a/lapack-netlib/SRC/cpotrf2.f +++ b/lapack-netlib/SRC/cpotrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,7 +41,7 @@ *> *> The subroutine calls itself to factor A11. Update and scale A21 *> or A12, update A22 then calls itself to factor A22. -*> +*> *> \endverbatim * * Arguments: @@ -62,7 +62,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> A is COMPLEX array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexPOcomputational * * ===================================================================== RECURSIVE SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -128,7 +128,7 @@ RECURSIVE SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) PARAMETER ( CONE = (1.0E+0, 0.0E+0) ) * .. * .. Local Scalars .. - LOGICAL UPPER + LOGICAL UPPER INTEGER N1, N2, IINFO REAL AJJ * .. @@ -193,7 +193,7 @@ RECURSIVE SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO RETURN - END IF + END IF * * Compute the Cholesky factorization A = U**H*U * @@ -205,7 +205,7 @@ RECURSIVE SUBROUTINE CPOTRF2( UPLO, N, A, LDA, INFO ) $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) * * Update and factor A22 -* +* CALL CHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) * diff --git a/lapack-netlib/SRC/cpotri.f b/lapack-netlib/SRC/cpotri.f index 0101bd5746..9b548953dd 100644 --- a/lapack-netlib/SRC/cpotri.f +++ b/lapack-netlib/SRC/cpotri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpotrs.f b/lapack-netlib/SRC/cpotrs.f index 6d5566e34c..18c3d0d3ea 100644 --- a/lapack-netlib/SRC/cpotrs.f +++ b/lapack-netlib/SRC/cpotrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPOTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -35,7 +35,7 @@ *> \verbatim *> *> CPOTRS solves a system of linear equations A*X = B with a Hermitian -*> positive definite matrix A using the Cholesky factorization +*> positive definite matrix A using the Cholesky factorization *> A = U**H*U or A = L*L**H computed by CPOTRF. *> \endverbatim * @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexPOcomputational * * ===================================================================== SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cppcon.f b/lapack-netlib/SRC/cppcon.f index e4c48e9802..48b0a338d2 100644 --- a/lapack-netlib/SRC/cppcon.f +++ b/lapack-netlib/SRC/cppcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,14 +29,14 @@ * REAL RWORK( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CPPCON estimates the reciprocal of the condition number (in the +*> CPPCON estimates the reciprocal of the condition number (in the *> 1-norm) of a complex Hermitian positive definite packed matrix using *> the Cholesky factorization A = U**H*U or A = L*L**H computed by *> CPPTRF. @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cppequ.f b/lapack-netlib/SRC/cppequ.f index af8444ca64..2ceeb3f504 100644 --- a/lapack-netlib/SRC/cppequ.f +++ b/lapack-netlib/SRC/cppequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * REAL S( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpprfs.f b/lapack-netlib/SRC/cpprfs.f index 90af0272a7..5206b9526b 100644 --- a/lapack-netlib/SRC/cpprfs.f +++ b/lapack-netlib/SRC/cpprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, * BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cppsv.f b/lapack-netlib/SRC/cppsv.f index a0b53c7003..084ef461e9 100644 --- a/lapack-netlib/SRC/cppsv.f +++ b/lapack-netlib/SRC/cppsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsolve * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cppsvx.f b/lapack-netlib/SRC/cppsvx.f index b653584b91..5ae669c229 100644 --- a/lapack-netlib/SRC/cppsvx.f +++ b/lapack-netlib/SRC/cppsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, * X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -278,10 +278,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -311,7 +311,7 @@ SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cpptrf.f b/lapack-netlib/SRC/cpptrf.f index ea1a4e5db3..bbca265ea6 100644 --- a/lapack-netlib/SRC/cpptrf.f +++ b/lapack-netlib/SRC/cpptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpptri.f b/lapack-netlib/SRC/cpptri.f index 706fac69a6..1340cfb70e 100644 --- a/lapack-netlib/SRC/cpptri.f +++ b/lapack-netlib/SRC/cpptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPTRI( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpptrs.f b/lapack-netlib/SRC/cpptrs.f index 94e623c0d8..7d9b6defce 100644 --- a/lapack-netlib/SRC/cpptrs.f +++ b/lapack-netlib/SRC/cpptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cpstf2.f b/lapack-netlib/SRC/cpstf2.f index 1c298eab0d..f43cb308c5 100644 --- a/lapack-netlib/SRC/cpstf2.f +++ b/lapack-netlib/SRC/cpstf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPSTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPSTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL TOL * INTEGER INFO, LDA, N, RANK @@ -30,7 +30,7 @@ * REAL WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -130,22 +130,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL TOL @@ -252,7 +252,7 @@ SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) DO 130 I = J, N * IF( J.GT.1 ) THEN - WORK( I ) = WORK( I ) + + WORK( I ) = WORK( I ) + $ REAL( CONJG( A( J-1, I ) )* $ A( J-1, I ) ) END IF @@ -324,7 +324,7 @@ SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) DO 160 I = J, N * IF( J.GT.1 ) THEN - WORK( I ) = WORK( I ) + + WORK( I ) = WORK( I ) + $ REAL( CONJG( A( I, J-1 ) )* $ A( I, J-1 ) ) END IF diff --git a/lapack-netlib/SRC/cpstrf.f b/lapack-netlib/SRC/cpstrf.f index 0b4897ca7e..4b6cc41a99 100644 --- a/lapack-netlib/SRC/cpstrf.f +++ b/lapack-netlib/SRC/cpstrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPSTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPSTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL TOL * INTEGER INFO, LDA, N, RANK @@ -30,7 +30,7 @@ * REAL WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -130,22 +130,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL TOL diff --git a/lapack-netlib/SRC/cptcon.f b/lapack-netlib/SRC/cptcon.f index 48897538e6..8956d0b8b6 100644 --- a/lapack-netlib/SRC/cptcon.f +++ b/lapack-netlib/SRC/cptcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * REAL ANORM, RCOND @@ -28,7 +28,7 @@ * REAL D( * ), RWORK( * ) * COMPLEX E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/cpteqr.f b/lapack-netlib/SRC/cpteqr.f index c6e6ce6c7a..07d0779310 100644 --- a/lapack-netlib/SRC/cpteqr.f +++ b/lapack-netlib/SRC/cpteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -28,7 +28,7 @@ * REAL D( * ), E( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,22 +133,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTcomputational * * ===================================================================== SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/cptrfs.f b/lapack-netlib/SRC/cptrfs.f index a8b5b9839b..a01ef9003b 100644 --- a/lapack-netlib/SRC/cptrfs.f +++ b/lapack-netlib/SRC/cptrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX B( LDB, * ), E( * ), EF( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTcomputational * @@ -183,10 +183,10 @@ SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cptsv.f b/lapack-netlib/SRC/cptsv.f index 0c2ca5f9d7..7c6f1ede15 100644 --- a/lapack-netlib/SRC/cptsv.f +++ b/lapack-netlib/SRC/cptsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * REAL D( * ) * COMPLEX B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTsolve * * ===================================================================== SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/cptsvx.f b/lapack-netlib/SRC/cptsvx.f index c7107cf50a..0482f7f35d 100644 --- a/lapack-netlib/SRC/cptsvx.f +++ b/lapack-netlib/SRC/cptsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX B( LDB, * ), E( * ), EF( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -221,12 +221,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTsolve * @@ -234,10 +234,10 @@ SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT diff --git a/lapack-netlib/SRC/cpttrf.f b/lapack-netlib/SRC/cpttrf.f index 3130ce0045..2f7471435f 100644 --- a/lapack-netlib/SRC/cpttrf.f +++ b/lapack-netlib/SRC/cpttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTTRF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * REAL D( * ) * COMPLEX E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -80,22 +80,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexPTcomputational * * ===================================================================== SUBROUTINE CPTTRF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/cpttrs.f b/lapack-netlib/SRC/cpttrs.f index 4214dd11de..8edf726836 100644 --- a/lapack-netlib/SRC/cpttrs.f +++ b/lapack-netlib/SRC/cpttrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * REAL D( * ) * COMPLEX B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,7 +87,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is REAL array, dimension (LDB,NRHS) +*> B is COMPLEX array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexPTcomputational * * ===================================================================== SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cptts2.f b/lapack-netlib/SRC/cptts2.f index 379ca4956d..c2b2b041ec 100644 --- a/lapack-netlib/SRC/cptts2.f +++ b/lapack-netlib/SRC/cptts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CPTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CPTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER IUPLO, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * REAL D( * ) * COMPLEX B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,7 +86,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is REAL array, dimension (LDB,NRHS) +*> B is COMPLEX array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexPTcomputational * * ===================================================================== SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IUPLO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/crot.f b/lapack-netlib/SRC/crot.f index 59b2d4ae6d..849b9be49f 100644 --- a/lapack-netlib/SRC/crot.f +++ b/lapack-netlib/SRC/crot.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CROT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CROT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * REAL C @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/cspcon.f b/lapack-netlib/SRC/cspcon.f index 841040b1bb..f8bcc77642 100644 --- a/lapack-netlib/SRC/cspcon.f +++ b/lapack-netlib/SRC/cspcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cspmv.f b/lapack-netlib/SRC/cspmv.f index ea74107def..80f2cefd36 100644 --- a/lapack-netlib/SRC/cspmv.f +++ b/lapack-netlib/SRC/cspmv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,22 +139,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cspr.f b/lapack-netlib/SRC/cspr.f index eeaa21dfb7..2ea80c145d 100644 --- a/lapack-netlib/SRC/cspr.f +++ b/lapack-netlib/SRC/cspr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csprfs.f b/lapack-netlib/SRC/csprfs.f index 92b84b112c..4ab12208bf 100644 --- a/lapack-netlib/SRC/csprfs.f +++ b/lapack-netlib/SRC/csprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -180,10 +180,10 @@ SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cspsv.f b/lapack-netlib/SRC/cspsv.f index 521e90672d..4bf0781016 100644 --- a/lapack-netlib/SRC/cspsv.f +++ b/lapack-netlib/SRC/cspsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cspsvx.f b/lapack-netlib/SRC/cspsvx.f index d81ad0cfd3..821d82af94 100644 --- a/lapack-netlib/SRC/cspsvx.f +++ b/lapack-netlib/SRC/cspsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/csptrf.f b/lapack-netlib/SRC/csptrf.f index dd7921afb8..3499cb4e6a 100644 --- a/lapack-netlib/SRC/csptrf.f +++ b/lapack-netlib/SRC/csptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -158,10 +158,10 @@ * ===================================================================== SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csptri.f b/lapack-netlib/SRC/csptri.f index 66a5d1d0d6..d8fed87427 100644 --- a/lapack-netlib/SRC/csptri.f +++ b/lapack-netlib/SRC/csptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csptrs.f b/lapack-netlib/SRC/csptrs.f index b1dd48c86e..b13c6514b1 100644 --- a/lapack-netlib/SRC/csptrs.f +++ b/lapack-netlib/SRC/csptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csrscl.f b/lapack-netlib/SRC/csrscl.f index 13b5cda137..e85168e778 100644 --- a/lapack-netlib/SRC/csrscl.f +++ b/lapack-netlib/SRC/csrscl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSRSCL( N, SA, SX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL SA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX SX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== SUBROUTINE CSRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/cstedc.f b/lapack-netlib/SRC/cstedc.f index b21623a7a2..4a00fbabde 100644 --- a/lapack-netlib/SRC/cstedc.f +++ b/lapack-netlib/SRC/cstedc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, * LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL D( * ), E( * ), RWORK( * ) * COMPLEX WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -193,12 +193,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -212,10 +212,10 @@ SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/cstegr.f b/lapack-netlib/SRC/cstegr.f index 6e1eae0553..3209f27eed 100644 --- a/lapack-netlib/SRC/cstegr.f +++ b/lapack-netlib/SRC/cstegr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSTEGR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSTEGR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * REAL D( * ), E( * ), W( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,7 +48,7 @@ *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> -*> CSTEGR is a compatability wrapper around the improved CSTEMR routine. +*> CSTEGR is a compatibility wrapper around the improved CSTEMR routine. *> See SSTEMR for further details. *> *> One important change is that the ABSTOL parameter no longer provides any @@ -105,13 +105,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -119,14 +123,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -235,12 +244,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -256,10 +265,10 @@ SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/cstein.f b/lapack-netlib/SRC/cstein.f index 2e68302458..4f6687d72c 100644 --- a/lapack-netlib/SRC/cstein.f +++ b/lapack-netlib/SRC/cstein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSTEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSTEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDZ, M, N * .. @@ -30,7 +30,7 @@ * REAL D( * ), E( * ), W( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N @@ -221,8 +221,8 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * .. * .. External Functions .. INTEGER ISAMAX - REAL SASUM, SLAMCH, SNRM2 - EXTERNAL ISAMAX, SASUM, SLAMCH, SNRM2 + REAL SLAMCH, SNRM2 + EXTERNAL ISAMAX, SLAMCH, SNRM2 * .. * .. External Subroutines .. EXTERNAL SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, XERBLA diff --git a/lapack-netlib/SRC/cstemr.f b/lapack-netlib/SRC/cstemr.f index 29734964b5..f7e0abbe08 100644 --- a/lapack-netlib/SRC/cstemr.f +++ b/lapack-netlib/SRC/cstemr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSTEMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSTEMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * LOGICAL TRYRAC @@ -33,7 +33,7 @@ * REAL D( * ), E( * ), W( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,13 +153,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -167,14 +171,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -306,12 +315,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -329,10 +338,10 @@ SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/csteqr.f b/lapack-netlib/SRC/csteqr.f index 2c44111589..fa95db6d1f 100644 --- a/lapack-netlib/SRC/csteqr.f +++ b/lapack-netlib/SRC/csteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -28,7 +28,7 @@ * REAL D( * ), E( * ), WORK( * ) * COMPLEX Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/csycon.f b/lapack-netlib/SRC/csycon.f index 4888998b1d..dbd6957d35 100644 --- a/lapack-netlib/SRC/csycon.f +++ b/lapack-netlib/SRC/csycon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -125,10 +125,10 @@ SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csycon_3.f b/lapack-netlib/SRC/csycon_3.f new file mode 100644 index 0000000000..a1ff812b05 --- /dev/null +++ b/lapack-netlib/SRC/csycon_3.f @@ -0,0 +1,287 @@ +*> \brief \b CSYCON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYCON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* COMPLEX A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYCON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex symmetric matrix A using the factorization +*> computed by CSYTRF_RK or CSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver CSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_RK or CSYTRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CSYTRS_3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYCON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL CSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of CSYCON_3 +* + END diff --git a/lapack-netlib/SRC/csycon_rook.f b/lapack-netlib/SRC/csycon_rook.f index 217bae176f..85320baa4c 100644 --- a/lapack-netlib/SRC/csycon_rook.f +++ b/lapack-netlib/SRC/csycon_rook.f @@ -1,26 +1,26 @@ -*> \brief \b CSYCON_ROOK +*> \brief CSYCON_ROOK * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYCON_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,10 +112,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -139,7 +139,7 @@ SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/csyconv.f b/lapack-netlib/SRC/csyconv.f index 654ab188fa..0937f824b8 100644 --- a/lapack-netlib/SRC/csyconv.f +++ b/lapack-netlib/SRC/csyconv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYCONV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, WAY * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,7 +36,7 @@ *> \verbatim *> *> CSYCONV convert A given by TRF into L and D and vice-versa. -*> Get Non-diag elements of D (returned in workspace) and +*> Get Non-diag elements of D (returned in workspace) and *> apply or reverse permutation done in TRF. *> \endverbatim * @@ -55,7 +55,7 @@ *> \param[in] WAY *> \verbatim *> WAY is CHARACTER*1 -*> = 'C': Convert +*> = 'C': Convert *> = 'R': Revert *> \endverbatim *> @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, WAY @@ -194,7 +194,7 @@ SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) END DO * * Convert PERMUTATIONS -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0) THEN @@ -226,7 +226,7 @@ SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * * * Revert PERMUTATIONS -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/csyconvf.f b/lapack-netlib/SRC/csyconvf.f new file mode 100644 index 0000000000..0e843c3f3b --- /dev/null +++ b/lapack-netlib/SRC/csyconvf.f @@ -0,0 +1,562 @@ +*> \brief \b CSYCONVF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYCONVF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> CSYCONVF converts the factorization output format used in +*> CSYTRF provided on entry in parameter A into the factorization +*> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored +*> on exit in parameters A and E. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in CSYTRF into +*> the format used in CSYTRF_RK (or CSYTRF_BK). +*> +*> If parameter WAY = 'R': +*> CSYCONVF performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in CSYTRF_RK +*> (or CSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in CSYTRF that is stored +*> on exit in parameter A. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in CSYTRF_RK +*> (or CSYTRF_BK) into the format used in CSYTRF. +*> +*> CSYCONVF can also convert in Hermitian matrix case, i.e. between +*> formats used in CHETRF and CHETRF_RK (or CHETRF_BK). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> CSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> CSYTRF_RK or CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> CSYTRF_RK or CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> CSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> +*> 1) If WAY ='C': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in CSYTRF. +*> On exit, details of the interchanges and the block +*> structure of D in the format used in CSYTRF_RK +*> ( or CSYTRF_BK). +*> +*> 1) If WAY ='R': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in CSYTRF_RK +*> ( or CSYTRF_BK). +*> On exit, details of the interchanges and the block +*> structure of D in the format used in CSYTRF. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE CSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL CSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYCONVF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL CSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL CSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i-1 and IPIV(i-1), +* so this should be recorded in two consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I-1 ) +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where k increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL CSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL CSWAP( I-1, A( IP, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i+1 and IPIV(i+1), +* so this should be recorded in consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I+1 ) +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of CSYCONVF +* + END diff --git a/lapack-netlib/SRC/csyconvf_rook.f b/lapack-netlib/SRC/csyconvf_rook.f new file mode 100644 index 0000000000..7a8ba601d3 --- /dev/null +++ b/lapack-netlib/SRC/csyconvf_rook.f @@ -0,0 +1,547 @@ +*> \brief \b CSYCONVF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYCONVF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> CSYCONVF_ROOK converts the factorization output format used in +*> CSYTRF_ROOK provided on entry in parameter A into the factorization +*> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored +*> on exit in parameters A and E. IPIV format for CSYTRF_ROOK and +*> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted. +*> +*> If parameter WAY = 'R': +*> CSYCONVF_ROOK performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in CSYTRF_RK +*> (or CSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in CSYTRF_ROOK that is stored +*> on exit in parameter A. IPIV format for CSYTRF_ROOK and +*> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted. +*> +*> CSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between +*> formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> CSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> CSYTRF_RK or CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> CSYTRF_RK or CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> CSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On entry, details of the interchanges and the block +*> structure of D as determined: +*> 1) by CSYTRF_ROOK, if WAY ='C'; +*> 2) by CSYTRF_RK (or CSYTRF_BK), if WAY ='R'. +*> The IPIV format is the same for all these routines. +*> +*> On exit, is not changed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE CSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL CSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, IP2 +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYCONVF_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) +* in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + IF( IP2.NE.(I-1) ) THEN + CALL CSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP2, I+1 ), LDA ) + END IF + END IF + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) +* in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP2.NE.(I-1) ) THEN + CALL CSWAP( N-I, A( IP2, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL CSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) +* in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + IF( IP2.NE.(I+1) ) THEN + CALL CSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP2, 1 ), LDA ) + END IF + END IF + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) +* in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP2.NE.(I+1) ) THEN + CALL CSWAP( I-1, A( IP2, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL CSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of CSYCONVF_ROOK +* + END diff --git a/lapack-netlib/SRC/csyequb.f b/lapack-netlib/SRC/csyequb.f index d640961c47..ff1f014aa5 100644 --- a/lapack-netlib/SRC/csyequb.f +++ b/lapack-netlib/SRC/csyequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), WORK( * ) * REAL S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -37,12 +37,11 @@ *> \verbatim *> *> CSYEQUB computes row and column scalings intended to equilibrate a -*> symmetric matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> symmetric matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -52,30 +51,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> Specifies whether the details of the factorization are stored -*> as an upper or lower triangular matrix. -*> = 'U': Upper triangular, form is A = U*D*U**T; -*> = 'L': Lower triangular, form is A = L*D*L**T. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX array, dimension (LDA,N) -*> The N-by-N symmetric matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N symmetric matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -88,21 +84,21 @@ *> \verbatim *> SCOND is REAL *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is REAL -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension (3*N) +*> WORK is COMPLEX array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -116,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -131,15 +127,15 @@ *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n *> DOI 10.1023/B:NUMA.0000016606.32820.69 \n -*> Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 *> * ===================================================================== SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -180,7 +176,7 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. Statement Functions .. REAL CABS1 * .. -* Statement Function Definitions +* .. Statement Function Definitions .. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) * .. * .. Executable Statements .. @@ -189,15 +185,15 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * INFO = 0 IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'CSYEQUB', -INFO ) - RETURN + CALL XERBLA( 'CSYEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -206,12 +202,12 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -222,7 +218,7 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO - S( J ) = MAX( S( J ), CABS1( A( J, J) ) ) + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) END DO ELSE @@ -231,7 +227,7 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) DO I = J+1, N S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) - S( J ) = MAX( S( J ), CABS1 (A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO END DO @@ -243,90 +239,89 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) TOL = ONE / SQRT( 2.0E0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0 - SUMSQ = 0.0 -* beta = |A|s - DO I = 1, N - WORK( I ) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - DO I = J+1, N - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - END DO - END IF + SCALE = 0.0E0 + SUMSQ = 0.0E0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF -* avg = s^T beta / n - AVG = 0.0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N +* avg = s^T beta / n + AVG = 0.0E0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - STD = 0.0 - DO I = N+1, 2*N - WORK( I ) = S( I-N ) * WORK( I-N ) - AVG - END DO - CALL CLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + STD = 0.0E0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL CLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( STD .LT. TOL * AVG ) GOTO 999 + IF ( STD .LT. TOL * AVG ) GOTO 999 - DO I = 1, N - T = CABS1( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG - D = C1*C1 - 4*C0*C2 + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - D = SI - S( I ) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -339,9 +334,9 @@ SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BASE = SLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) * diff --git a/lapack-netlib/SRC/csymv.f b/lapack-netlib/SRC/csymv.f index 6131e80605..5ae8c219c9 100644 --- a/lapack-netlib/SRC/csymv.f +++ b/lapack-netlib/SRC/csymv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,22 +145,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csyr.f b/lapack-netlib/SRC/csyr.f index b82b9bd32f..9f435cdf11 100644 --- a/lapack-netlib/SRC/csyr.f +++ b/lapack-netlib/SRC/csyr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csyrfs.f b/lapack-netlib/SRC/csyrfs.f index 13403d5a81..b00fde895f 100644 --- a/lapack-netlib/SRC/csyrfs.f +++ b/lapack-netlib/SRC/csyrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -179,12 +179,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -192,10 +192,10 @@ SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csyrfsx.f b/lapack-netlib/SRC/csyrfsx.f index 1625d4fa17..7323ba8eb7 100644 --- a/lapack-netlib/SRC/csyrfsx.f +++ b/lapack-netlib/SRC/csyrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -387,10 +387,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -402,7 +402,7 @@ SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -463,12 +463,11 @@ SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C REAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/csysv.f b/lapack-netlib/SRC/csysv.f index 2634246bc6..827ac093da 100644 --- a/lapack-netlib/SRC/csysv.f +++ b/lapack-netlib/SRC/csysv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYsolve * @@ -171,10 +171,10 @@ SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csysv_aa.f b/lapack-netlib/SRC/csysv_aa.f new file mode 100644 index 0000000000..187a6aaf96 --- /dev/null +++ b/lapack-netlib/SRC/csysv_aa.f @@ -0,0 +1,254 @@ +*> \brief CSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYSV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYSV computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. The factored +*> form of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> CSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(2*N, 3*N-2), and for +*> the best performance, LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for CSYTRF_AA. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYsolve +* +* ===================================================================== + SUBROUTINE CSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_SYTRF, LWKOPT_SYTRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSYTRF, CSYTRS, CSYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL CSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_SYTRF = INT( WORK(1) ) + CALL CSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_SYTRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_SYTRF, LWKOPT_SYTRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYSV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL CSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL CSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CSYSV_AA +* + END diff --git a/lapack-netlib/SRC/csysv_rk.f b/lapack-netlib/SRC/csysv_rk.f new file mode 100644 index 0000000000..f2b21753b2 --- /dev/null +++ b/lapack-netlib/SRC/csysv_rk.f @@ -0,0 +1,316 @@ +*> \brief CSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYSV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYSV_RK computes the solution to a complex system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CSYTRF_RK is called to compute the factorization of a complex +*> symmetric matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine CSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by CSYTRF_RK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of CSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine CSYTRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of CSYTRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CSYTRF_RK. +*> +*> For more info see the description of CSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for CSYTRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSYTRF_RK, CSYTRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYSV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CSYSV_RK +* + END diff --git a/lapack-netlib/SRC/csysv_rook.f b/lapack-netlib/SRC/csysv_rook.f index 2e613628ae..e0ab726509 100644 --- a/lapack-netlib/SRC/csysv_rook.f +++ b/lapack-netlib/SRC/csysv_rook.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYSV_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -47,13 +47,13 @@ *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with -*> 1-by-1 and 2-by-2 diagonal blocks. +*> 1-by-1 and 2-by-2 diagonal blocks. *> *> CSYTRF_ROOK is called to compute the factorization of a complex *> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal *> pivoting method. *> -*> The factored form of A is then used to solve the system +*> The factored form of A is then used to solve the system *> of equations A * X = B by calling CSYTRS_ROOK. *> \endverbatim * @@ -154,7 +154,7 @@ *> The length of WORK. LWORK >= 1, and for best performance *> LWORK >= max(1,N*NB), where NB is the optimal blocksize for *> CSYTRF_ROOK. -*> +*> *> TRS will be done with Level 2 BLAS *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -176,10 +176,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -204,7 +204,7 @@ SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/csysvx.f b/lapack-netlib/SRC/csysvx.f index 0a1c5c7d10..46f65f6a4a 100644 --- a/lapack-netlib/SRC/csysvx.f +++ b/lapack-netlib/SRC/csysvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,10 +271,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -285,7 +285,7 @@ SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/csysvxx.f b/lapack-netlib/SRC/csysvxx.f index 6d57ff879e..2fd2c8771e 100644 --- a/lapack-netlib/SRC/csysvxx.f +++ b/lapack-netlib/SRC/csysvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -494,10 +494,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -509,7 +509,7 @@ SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * April 2012 @@ -554,7 +554,7 @@ SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, REAL SLAMCH, CLA_SYRPVGRW * .. * .. External Subroutines .. - EXTERNAL CSYCON, CSYEQUB, CSYTRF, CSYTRS, CLACPY, + EXTERNAL CSYEQUB, CSYTRF, CSYTRS, CLACPY, $ CLAQSY, XERBLA, CLASCL2, CSYRFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/csyswapr.f b/lapack-netlib/SRC/csyswapr.f index 727dd363ef..b8291dafc5 100644 --- a/lapack-netlib/SRC/csyswapr.f +++ b/lapack-netlib/SRC/csyswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYSWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYSWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * COMPLEX A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYauxiliary * * ===================================================================== SUBROUTINE CSYSWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,12 +136,12 @@ SUBROUTINE CSYSWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL CSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -164,12 +164,12 @@ SUBROUTINE CSYSWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from I1 to I1-1 +* - swap row I1 and I2 from I1 to I1-1 CALL CSWAP ( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP diff --git a/lapack-netlib/SRC/csytf2.f b/lapack-netlib/SRC/csytf2.f index b7dc56f604..370e57d44b 100644 --- a/lapack-netlib/SRC/csytf2.f +++ b/lapack-netlib/SRC/csytf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csytf2_rk.f b/lapack-netlib/SRC/csytf2_rk.f new file mode 100644 index 0000000000..3b5e53a030 --- /dev/null +++ b/lapack-netlib/SRC/csytf2_rk.f @@ -0,0 +1,952 @@ +*> \brief \b CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYTF2_RK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN + COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CSCAL, CSWAP, CSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT, AIMAG, REAL +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX )) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL CSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = CONE / A( K, K ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL CSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = CONE / ( D11*D22-CONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = CZERO + A( K-1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX )) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = CONE / A( K, K ) + CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL CSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = CZERO + A( K+1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of CSYTF2_RK +* + END diff --git a/lapack-netlib/SRC/csytrf.f b/lapack-netlib/SRC/csytrf.f index 86325829cd..c389725e90 100644 --- a/lapack-netlib/SRC/csytrf.f +++ b/lapack-netlib/SRC/csytrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -182,10 +182,10 @@ * ===================================================================== SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csytrf_aa.f b/lapack-netlib/SRC/csytrf_aa.f new file mode 100644 index 0000000000..7fcbb37811 --- /dev/null +++ b/lapack-netlib/SRC/csytrf_aa.f @@ -0,0 +1,480 @@ +*> \brief \b CSYTRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTRF_AA computes the factorization of a complex symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a complex symmetric tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N). For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +* ===================================================================== + SUBROUTINE CSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'CSYTRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL CCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with CGEMM +* + CALL CGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL CCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with CGEMM +* + CALL CGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of CSYTRF_AA +* + END diff --git a/lapack-netlib/SRC/csytrf_rk.f b/lapack-netlib/SRC/csytrf_rk.f new file mode 100644 index 0000000000..f7e3528acc --- /dev/null +++ b/lapack-netlib/SRC/csytrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYTRF_RK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CLASYF_RK, CSYTF2_RK, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'CSYTRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'CSYTRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by CLASYF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL CLASYF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL CSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL CSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by CLASYF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL CLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL CSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL CSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of CSYTRF_RK +* + END diff --git a/lapack-netlib/SRC/csytrf_rook.f b/lapack-netlib/SRC/csytrf_rook.f index fab048162c..c6a8ae5c1d 100644 --- a/lapack-netlib/SRC/csytrf_rook.f +++ b/lapack-netlib/SRC/csytrf_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRF_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complexSYcomputational * @@ -195,7 +195,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> June 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -208,10 +208,10 @@ * ===================================================================== SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -261,7 +261,7 @@ SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'CSYTRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * @@ -321,7 +321,7 @@ SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + $ INFO = IINFO * * No need to adjust IPIV * diff --git a/lapack-netlib/SRC/csytri.f b/lapack-netlib/SRC/csytri.f index 43de3c63a5..8f15e36988 100644 --- a/lapack-netlib/SRC/csytri.f +++ b/lapack-netlib/SRC/csytri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csytri2.f b/lapack-netlib/SRC/csytri2.f index 4585dd1379..34058cb034 100644 --- a/lapack-netlib/SRC/csytri2.f +++ b/lapack-netlib/SRC/csytri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/csytri2x.f b/lapack-netlib/SRC/csytri2x.f index 75b3c31130..046d613467 100644 --- a/lapack-netlib/SRC/csytri2x.f +++ b/lapack-netlib/SRC/csytri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -213,7 +213,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -229,7 +229,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -246,8 +246,8 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K+1,INVD) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K+1,INVD) = -AKKP1 / D K=K+2 END IF END DO @@ -263,7 +263,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -273,7 +273,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -336,7 +336,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**T*invD1*U11->U11 * CALL CTRMM('L','U','T','U',NNB, NNB, @@ -380,7 +380,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -390,9 +390,9 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL CSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL CSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -406,7 +406,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -423,8 +423,8 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K-1,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K-1,INVD+1) = -AKKP1 / D K=K-2 END IF END DO @@ -440,7 +440,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -507,7 +507,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**T*invD1*L11->L11 * CALL CTRMM('L',UPLO,'T','U',NNB, NNB, @@ -525,7 +525,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL CGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**T*invD1*L11 + U01**T*invD*U01 * @@ -563,7 +563,7 @@ SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/csytri_3.f b/lapack-netlib/SRC/csytri_3.f new file mode 100644 index 0000000000..43abc6a74c --- /dev/null +++ b/lapack-netlib/SRC/csytri_3.f @@ -0,0 +1,248 @@ +*> \brief \b CSYTRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYTRI_3 computes the inverse of a complex symmetric indefinite +*> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CSYTRI_3 sets the leading dimension of the workspace before calling +*> CSYTRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_RK or CSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CSYTRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'CSYTRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CSYTRI_3 +* + END diff --git a/lapack-netlib/SRC/csytri_3x.f b/lapack-netlib/SRC/csytri_3x.f new file mode 100644 index 0000000000..2865839f87 --- /dev/null +++ b/lapack-netlib/SRC/csytri_3x.f @@ -0,0 +1,647 @@ +*> \brief \b CSYTRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYTRI_3X computes the inverse of a complex symmetric indefinite +*> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_RK or CSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + COMPLEX AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J, + $ U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CSYSWAPR, CTRTRI, CTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. +* + CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = CONE / A( K, K ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K+1, 1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = WORK( K, INVD+1 ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = CONE + DO J = 1, I-1 + WORK( U11+I, J ) = CZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**T * invD1 * U11 -> U11 +* + CALL CTRMM( 'L', 'U', 'T', 'U', NNB, NNB, + $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**T * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL CGEMM( 'T', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1), + $ N+NB+1 ) + +* +* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T * invD0 * U01 +* + CALL CTRMM( 'L', UPLO, 'T', 'U', CUT, NNB, + $ CONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**T) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. +* + CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = CONE / A( K, K ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K-1, 1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = WORK( K, INVD+1 ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**T) = (inv(L))**T +* +* inv(L**T) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = CONE + DO J = I+1, NNB + WORK( U11+I, J ) = CZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**T * invD1 * L11 -> L11 +* + CALL CTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, CONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL CGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, CONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ CZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T * invD2 * L21 +* + CALL CTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, CONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**T * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**T) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of CSYTRI_3X +* + END + diff --git a/lapack-netlib/SRC/csytri_rook.f b/lapack-netlib/SRC/csytri_rook.f index b11b09f7a7..c375e81dca 100644 --- a/lapack-netlib/SRC/csytri_rook.f +++ b/lapack-netlib/SRC/csytri_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRI_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -116,7 +116,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -129,10 +129,10 @@ * ===================================================================== SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -301,7 +301,7 @@ SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) IF( KP.GT.1 ) $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) -* +* TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP @@ -392,7 +392,7 @@ SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) $ CDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 - END IF + END IF * IF( KSTEP.EQ.1 ) THEN * diff --git a/lapack-netlib/SRC/csytrs.f b/lapack-netlib/SRC/csytrs.f index de23f4f18b..3ab72b8ce3 100644 --- a/lapack-netlib/SRC/csytrs.f +++ b/lapack-netlib/SRC/csytrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/csytrs2.f b/lapack-netlib/SRC/csytrs2.f index 11d94f3445..1002b5461a 100644 --- a/lapack-netlib/SRC/csytrs2.f +++ b/lapack-netlib/SRC/csytrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,23 +119,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * * ===================================================================== - SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -200,7 +200,7 @@ SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**T. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -225,7 +225,7 @@ SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL CTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -277,7 +277,7 @@ SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**T. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -302,7 +302,7 @@ SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL CTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -324,7 +324,7 @@ SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] -* +* CALL CTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/csytrs_3.f b/lapack-netlib/SRC/csytrs_3.f new file mode 100644 index 0000000000..b0e868e1b9 --- /dev/null +++ b/lapack-netlib/SRC/csytrs_3.f @@ -0,0 +1,371 @@ +*> \brief \b CSYTRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> CSYTRS_3 solves a system of linear equations A * X = B with a complex +*> symmetric matrix A using the factorization computed +*> by CSYTRF_RK or CSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_RK or CSYTRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = ( 1.0E+0,0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CSCAL, CSWAP, CTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL CTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + CALL CSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL CTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL CTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + CALL CSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL CTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of CSYTRS_3 +* + END diff --git a/lapack-netlib/SRC/csytrs_aa.f b/lapack-netlib/SRC/csytrs_aa.f new file mode 100644 index 0000000000..6fedf9120d --- /dev/null +++ b/lapack-netlib/SRC/csytrs_aa.f @@ -0,0 +1,285 @@ +*> \brief \b CSYTRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTRS_AA solves a system of linear equations A*X = B with a complex +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by CSYTRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> Details of factors computed by CSYTRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by CSYTRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complexSYcomputational +* +* ===================================================================== + SUBROUTINE CSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGTSV, CSWAP, CTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL CTRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A( 1, 1 ), LDA+1, WORK( N ), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1 ) + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL CGTSV( N, NRHS, WORK( 1 ), WORK( N ), WORK( 2*N ), B, LDB, + $ INFO ) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL CTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1 ) + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL CGTSV( N, NRHS, WORK( 1 ), WORK(N), WORK( 2*N ), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL CTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of CSYTRS_AA +* + END diff --git a/lapack-netlib/SRC/csytrs_rook.f b/lapack-netlib/SRC/csytrs_rook.f index da4e5275e9..3cfe45a741 100644 --- a/lapack-netlib/SRC/csytrs_rook.f +++ b/lapack-netlib/SRC/csytrs_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CSYTRS_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -122,7 +122,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -136,10 +136,10 @@ SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ctbcon.f b/lapack-netlib/SRC/ctbcon.f index a54aecd7ba..a11a55aa64 100644 --- a/lapack-netlib/SRC/ctbcon.f +++ b/lapack-netlib/SRC/ctbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -143,10 +143,10 @@ SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ctbrfs.f b/lapack-netlib/SRC/ctbrfs.f index 44a3dc4185..c6cb9f9c46 100644 --- a/lapack-netlib/SRC/ctbrfs.f +++ b/lapack-netlib/SRC/ctbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -175,12 +175,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctbtrs.f b/lapack-netlib/SRC/ctbtrs.f index 9581431c9c..3ca70c656a 100644 --- a/lapack-netlib/SRC/ctbtrs.f +++ b/lapack-netlib/SRC/ctbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -146,10 +146,10 @@ SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctfsm.f b/lapack-netlib/SRC/ctfsm.f index 3da0087c7a..b4b26dd0e7 100644 --- a/lapack-netlib/SRC/ctfsm.f +++ b/lapack-netlib/SRC/ctfsm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTFSM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTFSM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO * INTEGER LDB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX A( 0: * ), B( 0: LDB-1, 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -298,10 +298,10 @@ SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, $ B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctftri.f b/lapack-netlib/SRC/ctftri.f index 740c79cd45..2e51a3d881 100644 --- a/lapack-netlib/SRC/ctftri.f +++ b/lapack-netlib/SRC/ctftri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO, DIAG * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -221,10 +221,10 @@ * ===================================================================== SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO, DIAG diff --git a/lapack-netlib/SRC/ctfttp.f b/lapack-netlib/SRC/ctfttp.f index da5e810122..6cd47e1769 100644 --- a/lapack-netlib/SRC/ctfttp.f +++ b/lapack-netlib/SRC/ctfttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTFTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTFTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,12 +88,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -208,10 +208,10 @@ * ===================================================================== SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ctfttr.f b/lapack-netlib/SRC/ctfttr.f index 295c206a16..3720b6977f 100644 --- a/lapack-netlib/SRC/ctfttr.f +++ b/lapack-netlib/SRC/ctfttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTFTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTFTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -216,10 +216,10 @@ * ===================================================================== SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ctgevc.f b/lapack-netlib/SRC/ctgevc.f index 86b833c8cb..342d562980 100644 --- a/lapack-netlib/SRC/ctgevc.f +++ b/lapack-netlib/SRC/ctgevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGEVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGEVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, * LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N @@ -31,8 +31,8 @@ * COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -43,20 +43,20 @@ *> a pair of complex matrices (S,P), where S and P are upper triangular. *> Matrix pairs of this type are produced by the generalized Schur *> factorization of a complex matrix pair (A,B): -*> +*> *> A = Q*S*Z**H, B = Q*P*Z**H -*> +*> *> as computed by CGGHRD + CHGEQZ. -*> +*> *> The right eigenvector x and the left eigenvector y of (S,P) *> corresponding to an eigenvalue w are defined by: -*> +*> *> S*x = w*P*x, (y**H)*S = w*(y**H)*P, -*> +*> *> where y**H denotes the conjugate tranpose of y. *> The eigenvalues are not input to this routine, but are computed *> directly from the diagonal elements of S and P. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of (S,P), or the products Z*X and/or Q*Y, *> where Z and Q are input matrices. @@ -206,12 +206,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -219,10 +219,10 @@ SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/ctgex2.f b/lapack-netlib/SRC/ctgex2.f index 51be304291..c487e8f14e 100644 --- a/lapack-netlib/SRC/ctgex2.f +++ b/lapack-netlib/SRC/ctgex2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGEX2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGEX2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, J1, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexGEauxiliary * @@ -190,10 +190,10 @@ SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -266,7 +266,7 @@ SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, CALL CLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SA = SCALE*SQRT( SUM ) * -* THRES has been changed from +* THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) diff --git a/lapack-netlib/SRC/ctgexc.f b/lapack-netlib/SRC/ctgexc.f index 08b84fc8cf..f6ccdcb9bd 100644 --- a/lapack-netlib/SRC/ctgexc.f +++ b/lapack-netlib/SRC/ctgexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, IFST, ILST, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexGEcomputational * @@ -200,10 +200,10 @@ SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ diff --git a/lapack-netlib/SRC/ctgsen.f b/lapack-netlib/SRC/ctgsen.f index d2ba8de8a6..8f02d0e861 100644 --- a/lapack-netlib/SRC/ctgsen.f +++ b/lapack-netlib/SRC/ctgsen.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, * WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, @@ -35,7 +35,7 @@ * COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -285,12 +285,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -433,10 +433,10 @@ SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, $ WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -471,7 +471,7 @@ SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. - REAL SLAMCH + REAL SLAMCH EXTERNAL CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL, $ SLAMCH, XERBLA * .. @@ -515,6 +515,7 @@ SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * subspaces. * M = 0 + IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) @@ -526,6 +527,7 @@ SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ M = M + 1 END IF 10 CONTINUE + END IF * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 2*M*(N-M) ) @@ -748,7 +750,7 @@ SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, END IF * * If B(K,K) is complex, make it real and positive (normalization -* of the generalized Schur form) and Store the generalized +* of the generalized Schur form) and Store the generalized * eigenvalues of reordered pair (A, B) * DO 60 K = 1, N diff --git a/lapack-netlib/SRC/ctgsja.f b/lapack-netlib/SRC/ctgsja.f index 6c04c3a198..38a61068e2 100644 --- a/lapack-netlib/SRC/ctgsja.f +++ b/lapack-netlib/SRC/ctgsja.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGSJA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGSJA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, * LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, * Q, LDQ, WORK, NCYCLE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -346,12 +346,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -379,10 +379,10 @@ SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/ctgsna.f b/lapack-netlib/SRC/ctgsna.f index 1299948698..6081d19b25 100644 --- a/lapack-netlib/SRC/ctgsna.f +++ b/lapack-netlib/SRC/ctgsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, * LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N @@ -33,7 +33,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -208,12 +208,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -311,10 +311,10 @@ SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/ctgsy2.f b/lapack-netlib/SRC/ctgsy2.f index fe1208816e..66a8980d04 100644 --- a/lapack-netlib/SRC/ctgsy2.f +++ b/lapack-netlib/SRC/ctgsy2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGSY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGSY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N @@ -31,7 +31,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. -* +* * *> \par Purpose: * ============= @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexSYauxiliary * @@ -259,10 +259,10 @@ SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/ctgsyl.f b/lapack-netlib/SRC/ctgsyl.f index 49c4fedf68..602e8091cb 100644 --- a/lapack-netlib/SRC/ctgsyl.f +++ b/lapack-netlib/SRC/ctgsyl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTGSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTGSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, @@ -34,7 +34,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -295,10 +295,10 @@ SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/ctpcon.f b/lapack-netlib/SRC/ctpcon.f index f09fb1680b..6b439fb527 100644 --- a/lapack-netlib/SRC/ctpcon.f +++ b/lapack-netlib/SRC/ctpcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -130,10 +130,10 @@ SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ctplqt.f b/lapack-netlib/SRC/ctplqt.f new file mode 100644 index 0000000000..322b6dc5c6 --- /dev/null +++ b/lapack-netlib/SRC/ctplqt.f @@ -0,0 +1,253 @@ +* Definition: +* =========== +* +* SUBROUTINE CTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTPLQT computes a blocked LQ factorization of a complex +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL CTPLQT2, CTPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL CTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL CTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of CTPLQT +* + END diff --git a/lapack-netlib/SRC/ctplqt2.f b/lapack-netlib/SRC/ctplqt2.f new file mode 100644 index 0000000000..1c9b128e9b --- /dev/null +++ b/lapack-netlib/SRC/ctplqt2.f @@ -0,0 +1,316 @@ +* Definition: +* =========== +* +* SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the lower triangular M-by-M matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,M) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ][ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ][ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L lower trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> +*> C = [ A ][ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ][ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> W = [ V1 ][ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W**T * T * W +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER( ZERO = ( 0.0E+0, 0.0E+0 ),ONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + COMPLEX ALPHA +* .. +* .. External Subroutines .. + EXTERNAL CLARFG, CGEMV, CGERC, CTRMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTPLQT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, M +* +* Generate elementary reflector H(I) to annihilate B(I,:) +* + P = N-L+MIN( L, I ) + CALL CLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) ) + T(1,I)=CONJG(T(1,I)) + IF( I.LT.M ) THEN + DO J = 1, P + B( I, J ) = CONJG(B(I,J)) + END DO +* +* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] +* + DO J = 1, M-I + T( M, J ) = (A( I+J, I )) + END DO + CALL CGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB, + $ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT ) +* +* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H +* + ALPHA = -(T( 1, I )) + DO J = 1, M-I + A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J )) + END DO + CALL CGERC( M-I, P, (ALPHA), T( M, 1 ), LDT, + $ B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + DO J = 1, P + B( I, J ) = CONJG(B(I,J)) + END DO + END IF + END DO +* + DO I = 2, M +* +* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N)) +* + ALPHA = -(T( 1, I )) + DO J = 1, I-1 + T( I, J ) = ZERO + END DO + P = MIN( I-1, L ) + NP = MIN( N-L+1, N ) + MP = MIN( P+1, M ) + DO J = 1, N-L+P + B(I,J)=CONJG(B(I,J)) + END DO +* +* Triangular part of B2 +* + DO J = 1, P + T( I, J ) = (ALPHA*B( I, N-L+J )) + END DO + CALL CTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB, + $ T( I, 1 ), LDT ) +* +* Rectangular part of B2 +* + CALL CGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB, + $ B( I, NP ), LDB, ZERO, T( I,MP ), LDT ) +* +* B1 + +* + CALL CGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB, + $ ONE, T( I, 1 ), LDT ) +* + +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) +* + DO J = 1, I-1 + T(I,J)=CONJG(T(I,J)) + END DO + CALL CTRMV( 'L', 'C', 'N', I-1, T, LDT, T( I, 1 ), LDT ) + DO J = 1, I-1 + T(I,J)=CONJG(T(I,J)) + END DO + DO J = 1, N-L+P + B(I,J)=CONJG(B(I,J)) + END DO +* +* T(I,I) = tau(I) +* + T( I, I ) = T( 1, I ) + T( 1, I ) = ZERO + END DO + DO I=1,M + DO J= I+1,M + T(I,J)=(T(J,I)) + T(J,I)=ZERO + END DO + END DO + +* +* End of CTPLQT2 +* + END diff --git a/lapack-netlib/SRC/ctpmlqt.f b/lapack-netlib/SRC/ctpmlqt.f new file mode 100644 index 0000000000..b326d6a2eb --- /dev/null +++ b/lapack-netlib/SRC/ctpmlqt.f @@ -0,0 +1,349 @@ +* Definition: +* =========== +* +* SUBROUTINE CTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. +* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTPMQRT applies a complex orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**C from the Left; +*> = 'R': apply Q or Q**C from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DTPLQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTPLQT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DTPLQT, stored as a MB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array. The dimension of WORK is +*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] [V2]. +*> +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='C' and SIDE='L', C is on exit replaced with Q**C * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**C. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. + COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, NB, LB, KF, LDAQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CTPRFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'C' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.K ) THEN + INFO = -9 + ELSE IF( LDT.LT.MB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTPMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL CTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL CTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL CTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL CTPRFB( 'R', 'C', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of CTPMLQT +* + END diff --git a/lapack-netlib/SRC/ctpmqrt.f b/lapack-netlib/SRC/ctpmqrt.f index 08929b226c..025de8295d 100644 --- a/lapack-netlib/SRC/ctpmqrt.f +++ b/lapack-netlib/SRC/ctpmqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * A, LDA, B, LDB, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. -* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), +* COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CTPMQRT applies a complex orthogonal matrix Q obtained from a +*> CTPMQRT applies a complex orthogonal matrix Q obtained from a *> "triangular-pentagonal" complex block reflector H to a general *> complex matrix C, which consists of two blocks A and B. *> \endverbatim @@ -69,7 +69,7 @@ *> N is INTEGER *> The number of columns of the matrix B. N >= 0. *> \endverbatim -*> +*> *> \param[in] K *> \verbatim *> K is INTEGER @@ -80,7 +80,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -124,19 +124,19 @@ *> \param[in,out] A *> \verbatim *> A is COMPLEX array, dimension -*> (LDA,N) if SIDE = 'L' or +*> (LDA,N) if SIDE = 'L' or *> (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of +*> On exit, A is overwritten by the corresponding block of *> Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -150,7 +150,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -185,20 +185,20 @@ *> \verbatim *> *> The columns of the pentagonal matrix V contain the elementary reflectors -*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a *> trapezoidal block V2: *> *> V = [V1] *> [V2]. *> -*> The size of the trapezoidal block V2 is determined by the parameter L, +*> The size of the trapezoidal block V2 is determined by the parameter L, *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. *> -*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. -*> [B] -*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. +*> [B] +*> *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. *> *> The complex orthogonal matrix Q is formed from V and T. @@ -216,17 +216,17 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. - COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), + COMPLEX V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * @@ -242,7 +242,7 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, CLARFB + EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -256,7 +256,7 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF ( LEFT ) THEN LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) @@ -275,7 +275,7 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN - INFO = -6 + INFO = -6 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN @@ -307,11 +307,11 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-M+L-I+1 END IF - CALL CTPRFB( 'L', 'C', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL CTPRFB( 'L', 'C', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB @@ -322,8 +322,8 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-N+L-I+1 END IF - CALL CTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL CTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * @@ -331,15 +331,15 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 - END IF + END IF CALL CTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * @@ -347,7 +347,7 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 @@ -355,7 +355,7 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, LB = MB-N+L-I+1 END IF CALL CTPRFB( 'R', 'C', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * diff --git a/lapack-netlib/SRC/ctpqrt.f b/lapack-netlib/SRC/ctpqrt.f index 4dc173f0b9..96b3856e27 100644 --- a/lapack-netlib/SRC/ctpqrt.f +++ b/lapack-netlib/SRC/ctpqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CTPQRT computes a blocked QR factorization of a complex -*> "triangular-pentagonal" matrix C, which is composed of a -*> triangular block A and pentagonal block B, using the compact +*> CTPQRT computes a blocked QR factorization of a complex +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact *> WY representation for Q. *> \endverbatim * @@ -46,7 +46,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -88,7 +88,7 @@ *> \param[in,out] B *> \verbatim *> B is COMPLEX array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -105,7 +105,7 @@ *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See Further Details. *> \endverbatim -*> +*> *> \param[in] LDT *> \verbatim *> LDT is INTEGER @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -141,10 +141,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -154,8 +154,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -169,17 +169,17 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> *> The number of blocks is B = ceiling(N/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. @@ -189,10 +189,10 @@ SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -240,7 +240,7 @@ SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, IF( M.EQ.0 .OR. N.EQ.0 ) RETURN * DO I = 1, N, NB -* +* * Compute the QR factorization of the current block * IB = MIN( N-I+1, NB ) @@ -251,20 +251,20 @@ SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, LB = MB-M+L-I+1 END IF * - CALL CTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, + CALL CTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, $ T(1, I ), LDT, IINFO ) * * Update by applying H**H to B(:,I+IB:N) from the left * IF( I+IB.LE.N ) THEN CALL CTPRFB( 'L', 'C', 'F', 'C', MB, N-I-IB+1, IB, LB, - $ B( 1, I ), LDB, T( 1, I ), LDT, - $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, + $ B( 1, I ), LDB, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, $ WORK, IB ) END IF END DO RETURN -* +* * End of CTPQRT * END diff --git a/lapack-netlib/SRC/ctpqrt2.f b/lapack-netlib/SRC/ctpqrt2.f index d5e278599f..4cebe76f78 100644 --- a/lapack-netlib/SRC/ctpqrt2.f +++ b/lapack-netlib/SRC/ctpqrt2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> CTPQRT2 computes a QR factorization of a complex "triangular-pentagonal" -*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> matrix C, which is composed of a triangular block A and pentagonal block B, *> using the compact WY representation for Q. *> \endverbatim * @@ -44,7 +44,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The total number of rows of the matrix B. +*> The total number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -59,7 +59,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The number of rows of the upper trapezoidal part of B. +*> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> @@ -80,7 +80,7 @@ *> \param[in,out] B *> \verbatim *> B is COMPLEX array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -128,10 +128,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -141,8 +141,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -156,12 +156,12 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> The (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**H @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L @@ -227,7 +227,7 @@ SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) RETURN -* +* DO I = 1, N * * Generate elementary reflector H(I) to annihilate B(:,I) @@ -241,16 +241,16 @@ SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) DO J = 1, N-I T( J, N ) = CONJG(A( I, I+J )) END DO - CALL CGEMV( 'C', P, N-I, ONE, B( 1, I+1 ), LDB, + CALL CGEMV( 'C', P, N-I, ONE, B( 1, I+1 ), LDB, $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) * * C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)**H * - ALPHA = -CONJG(T( I, 1 )) + ALPHA = -CONJG(T( I, 1 )) DO J = 1, N-I A( I, I+J ) = A( I, I+J ) + ALPHA*CONJG(T( J, N )) END DO - CALL CGERC( P, N-I, ALPHA, B( 1, I ), 1, + CALL CGERC( P, N-I, ALPHA, B( 1, I ), 1, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO @@ -278,13 +278,13 @@ SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * Rectangular part of B2 * - CALL CGEMV( 'C', L, I-1-P, ALPHA, B( MP, NP ), LDB, + CALL CGEMV( 'C', L, I-1-P, ALPHA, B( MP, NP ), LDB, $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) * * B1 * - CALL CGEMV( 'C', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, - $ ONE, T( 1, I ), 1 ) + CALL CGEMV( 'C', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, + $ ONE, T( 1, I ), 1 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * @@ -295,7 +295,7 @@ SUBROUTINE CTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO - + * * End of CTPQRT2 * diff --git a/lapack-netlib/SRC/ctprfb.f b/lapack-netlib/SRC/ctprfb.f index 77b376f326..1538deb561 100644 --- a/lapack-netlib/SRC/ctprfb.f +++ b/lapack-netlib/SRC/ctprfb.f @@ -2,44 +2,44 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPRFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPRFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, +* SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. -* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), +* COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ V( LDV, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CTPRFB applies a complex "triangular-pentagonal" block reflector H or its -*> conjugate transpose H**H to a complex matrix C, which is composed of two +*> CTPRFB applies a complex "triangular-pentagonal" block reflector H or its +*> conjugate transpose H**H to a complex matrix C, which is composed of two *> blocks A and B, either from the left or right. -*> +*> *> \endverbatim * * Arguments: @@ -80,14 +80,14 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The number of columns of the matrix B. +*> The number of columns of the matrix B. *> N >= 0. *> \endverbatim *> @@ -95,14 +95,14 @@ *> \verbatim *> K is INTEGER *> The order of the matrix T, i.e. the number of elementary -*> reflectors whose product defines the block reflector. +*> reflectors whose product defines the block reflector. *> K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -129,13 +129,13 @@ *> \verbatim *> T is COMPLEX array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the -*> block reflector. +*> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER -*> The leading dimension of the array T. +*> The leading dimension of the array T. *> LDT >= K. *> \endverbatim *> @@ -144,16 +144,16 @@ *> A is COMPLEX array, dimension *> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of -*> H*C or H**H*C or C*H or C*H**H. See Futher Details. +*> On exit, A is overwritten by the corresponding block of +*> H*C or H**H*C or C*H or C*H**H. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -167,7 +167,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -182,19 +182,19 @@ *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= K; +*> If SIDE = 'L', LDWORK >= K; *> if SIDE = 'R', LDWORK >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -204,21 +204,21 @@ *> \verbatim *> *> The matrix C is a composite matrix formed from blocks A and B. -*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, +*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, *> and if SIDE = 'L', A is of size K-by-N. *> *> If SIDE = 'R' and DIRECT = 'F', C = [A B]. *> -*> If SIDE = 'L' and DIRECT = 'F', C = [A] +*> If SIDE = 'L' and DIRECT = 'F', C = [A] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] -*> [A]. +*> [A]. *> -*> The pentagonal matrix V is composed of a rectangular block V1 and a -*> trapezoidal block V2. The size of the trapezoidal block is determined by +*> The pentagonal matrix V is composed of a rectangular block V1 and a +*> trapezoidal block V2. The size of the trapezoidal block is determined by *> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; *> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. *> @@ -235,7 +235,7 @@ *> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] -*> +*> *> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) *> *> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. @@ -248,20 +248,20 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, + SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), + COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * @@ -325,7 +325,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END IF * * --------------------------------------------------------------------------- -* +* IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -339,34 +339,34 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - T (A + V**H B) or A = A - T**H (A + V**H B) -* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) +* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) -* +* DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL CTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( MP, 1 ), LDV, - $ WORK, LDWORK ) - CALL CGEMM( 'C', 'N', L, N, M-L, ONE, V, LDV, B, LDB, + $ WORK, LDWORK ) + CALL CGEMM( 'C', 'N', L, N, M-L, ONE, V, LDV, B, LDB, $ ONE, WORK, LDWORK ) - CALL CGEMM( 'C', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, + CALL CGEMM( 'C', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) -* +* DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL CTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL CTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) @@ -376,7 +376,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL CGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL CGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, - $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL CTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N @@ -386,7 +386,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -405,7 +405,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) @@ -413,20 +413,20 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL CTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) - CALL CGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, + CALL CGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, $ V, LDV, ONE, WORK, LDWORK ) - CALL CGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL CGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL CTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL CTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -446,7 +446,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -460,7 +460,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - T (A + V**H B) or A = A - T**H (A + V**H B) -* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) +* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) * * --------------------------------------------------------------------------- * @@ -475,10 +475,10 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL CTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) - CALL CGEMM( 'C', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, + CALL CGEMM( 'C', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL CGEMM( 'C', 'N', K-L, N, M, ONE, V, LDV, - $ B, LDB, ZERO, WORK, LDWORK ) + $ B, LDB, ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K @@ -486,16 +486,16 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, + CALL CTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * - CALL CGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, + CALL CGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL CGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) @@ -508,7 +508,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -527,7 +527,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) @@ -535,20 +535,20 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL CTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) - CALL CGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, + CALL CGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) - CALL CGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL CGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V, LDV, ZERO, WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL CTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL CTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -568,7 +568,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -581,7 +581,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - T (A + V B) or A = A - T**H (A + V B) -* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) +* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) * * --------------------------------------------------------------------------- * @@ -592,12 +592,12 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO - END DO + END DO CALL CTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDB ) - CALL CGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, + CALL CGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, $ ONE, WORK, LDWORK ) - CALL CGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, + CALL CGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N @@ -606,7 +606,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL CTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N @@ -617,7 +617,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL CGEMM( 'C', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) - CALL CGEMM( 'C', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, + CALL CGEMM( 'C', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL CTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) @@ -628,7 +628,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -656,7 +656,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ WORK, LDWORK ) CALL CGEMM( 'N', 'C', M, L, N-L, ONE, B, LDB, V, LDV, $ ONE, WORK, LDWORK ) - CALL CGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, + CALL CGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K @@ -665,7 +665,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL CTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -674,10 +674,10 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL CGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL CGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, - $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) + $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL CTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L @@ -687,7 +687,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -700,7 +700,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - T (A + V B) or A = A - T**H (A + V B) -* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) +* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) * * --------------------------------------------------------------------------- * @@ -736,10 +736,10 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL CGEMM( 'C', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) - CALL CGEMM( 'C', 'N', L, N, K-L, -ONE, V, LDV, + CALL CGEMM( 'C', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL CTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( KP, 1 ), LDV, - $ WORK( KP, 1 ), LDWORK ) + $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) @@ -747,7 +747,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -776,7 +776,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL CGEMM( 'N', 'C', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL CGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, V, LDV, - $ ZERO, WORK, LDWORK ) + $ ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M @@ -784,7 +784,7 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL CTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -793,9 +793,9 @@ SUBROUTINE CTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL CGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL CGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) - CALL CGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, + CALL CGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL CTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) diff --git a/lapack-netlib/SRC/ctprfs.f b/lapack-netlib/SRC/ctprfs.f index 6247489d66..b66bd7c887 100644 --- a/lapack-netlib/SRC/ctprfs.f +++ b/lapack-netlib/SRC/ctprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -29,7 +29,7 @@ * REAL BERR( * ), FERR( * ), RWORK( * ) * COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,7 +99,7 @@ *> \param[in] B *> \verbatim *> B is COMPLEX array, dimension (LDB,NRHS) -*> The right hand side matrix B. +*> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -174,10 +174,10 @@ SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctptri.f b/lapack-netlib/SRC/ctptri.f index cb940ac6e9..b6566ae3ab 100644 --- a/lapack-netlib/SRC/ctptri.f +++ b/lapack-netlib/SRC/ctptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -117,10 +117,10 @@ * ===================================================================== SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ctptrs.f b/lapack-netlib/SRC/ctptrs.f index e97d0d65f0..8a75e2fdfa 100644 --- a/lapack-netlib/SRC/ctptrs.f +++ b/lapack-netlib/SRC/ctptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctpttf.f b/lapack-netlib/SRC/ctpttf.f index 50cd1478eb..91e6fa70fd 100644 --- a/lapack-netlib/SRC/ctpttf.f +++ b/lapack-netlib/SRC/ctpttf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * COMPLEX AP( 0: * ), ARF( 0: * ) -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -207,10 +207,10 @@ * ===================================================================== SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ctpttr.f b/lapack-netlib/SRC/ctpttr.f index f5dacf4d71..a0548a3a69 100644 --- a/lapack-netlib/SRC/ctpttr.f +++ b/lapack-netlib/SRC/ctpttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTPTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTPTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ctrcon.f b/lapack-netlib/SRC/ctrcon.f index 20d25c4177..81ba45d013 100644 --- a/lapack-netlib/SRC/ctrcon.f +++ b/lapack-netlib/SRC/ctrcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -137,10 +137,10 @@ SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ctrevc.f b/lapack-netlib/SRC/ctrevc.f index ca51180720..2b950348cb 100644 --- a/lapack-netlib/SRC/ctrevc.f +++ b/lapack-netlib/SRC/ctrevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTREVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, MM, M, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, M, MM, N @@ -31,7 +31,7 @@ * COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -42,16 +42,16 @@ *> a complex upper triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. -*> +*> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: -*> +*> *> T*x = w*x, (y**H)*T = w*(y**H) -*> +*> *> where y**H denotes the conjugate transpose of the vector y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal of T. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the unitary factor that reduces a matrix A to @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -218,10 +218,10 @@ SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/ctrevc3.f b/lapack-netlib/SRC/ctrevc3.f new file mode 100644 index 0000000000..bb4c32ef29 --- /dev/null +++ b/lapack-netlib/SRC/ctrevc3.f @@ -0,0 +1,631 @@ +*> \brief \b CTREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CTREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* REAL RWORK( * ) +* COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CTREVC3 computes some or all of the right and/or left eigenvectors of +*> a complex upper triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of the vector y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the unitary factor that reduces a matrix A to +*> Schur form T, then Q*X and Q*Y are the matrices of right and left +*> eigenvectors of A. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed using the matrices supplied in +*> VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> The eigenvector corresponding to the j-th eigenvalue is +*> computed if SELECT(j) = .TRUE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDT,N) +*> The upper triangular matrix T. T is modified, but restored +*> on exit. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is COMPLEX array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by CHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is COMPLEX array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by CHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected eigenvector occupies one column. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,2*N). +*> For optimum performance, LWORK >= N + 2*N*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (LRWORK) +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of array RWORK. LRWORK >= max(1,N). +*> +*> If LRWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the RWORK array, returns +*> this value as the first entry of the RWORK array, and no error +*> message related to LRWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @generated from ztrevc3.f, fortran z -> c, Tue Apr 19 01:47:44 2016 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + REAL RWORK( * ) + COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER NBMIN, NBMAX + PARAMETER ( NBMIN = 8, NBMAX = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB + REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV, ICAMAX + REAL SLAMCH, SCASUM + EXTERNAL LSAME, ILAENV, ICAMAX, SLAMCH, SCASUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CCOPY, CLASET, CSSCAL, CGEMM, CGEMV, + $ CLATRS, SLABAD +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CMPLX, CONJG, AIMAG, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( SOMEV ) THEN + M = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ M = M + 1 + 10 CONTINUE + ELSE + M = N + END IF +* + INFO = 0 + NB = ILAENV( 1, 'CTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) + MAXWRK = N + 2*N*NB + WORK(1) = MAXWRK + RWORK(1) = N + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( MM.LT.M ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -14 + ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTREVC3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN + NB = (LWORK - N) / (2*N) + NB = MIN( NB, NBMAX ) + CALL CLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N ) + ELSE + NB = 1 + END IF +* +* Set the constants to control overflow. +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 I = 1, N + WORK( I ) = T( I, I ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + RWORK( 1 ) = ZERO + DO 30 J = 2, N + RWORK( J ) = SCASUM( J-1, T( 1, J ), 1 ) + 30 CONTINUE +* + IF( RIGHTV ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=NB=1; +* blocked version starts with IV=NB, goes down to 1. +* (Note the "0-th" column is used to store the original diagonal.) + IV = NB + IS = M + DO 80 KI = N, 1, -1 + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 80 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* +* -------------------------------------------------------- +* Complex right eigenvector +* + WORK( KI + IV*N ) = CONE +* +* Form right-hand side. +* + DO 40 K = 1, KI - 1 + WORK( K + IV*N ) = -T( K, KI ) + 40 CONTINUE +* +* Solve upper triangular system: +* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK. +* + DO 50 K = 1, KI - 1 + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 50 CONTINUE +* + IF( KI.GT.1 ) THEN + CALL CLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ KI-1, T, LDT, WORK( 1 + IV*N ), SCALE, + $ RWORK, INFO ) + WORK( KI + IV*N ) = SCALE + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL CCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) +* + II = ICAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / CABS1( VR( II, IS ) ) + CALL CSSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 60 K = KI + 1, N + VR( K, IS ) = CZERO + 60 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.1 ) + $ CALL CGEMV( 'N', N, KI-1, CONE, VR, LDVR, + $ WORK( 1 + IV*N ), 1, CMPLX( SCALE ), + $ VR( 1, KI ), 1 ) +* + II = ICAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / CABS1( VR( II, KI ) ) + CALL CSSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + IV*N ) = CZERO + END DO +* +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN + CALL CGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE, + $ VR, LDVR, + $ WORK( 1 + (IV)*N ), N, + $ CZERO, + $ WORK( 1 + (NB+IV)*N ), N ) +* normalize vectors + DO K = IV, NB + II = ICAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) + CALL CSSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL CLACPY( 'F', N, NB-IV+1, + $ WORK( 1 + (NB+IV)*N ), N, + $ VR( 1, KI ), LDVR ) + IV = NB + ELSE + IV = IV - 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 70 K = 1, KI - 1 + T( K, K ) = WORK( K ) + 70 CONTINUE +* + IS = IS - 1 + 80 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB. +* (Note the "0-th" column is used to store the original diagonal.) + IV = 1 + IS = 1 + DO 130 KI = 1, N +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* +* -------------------------------------------------------- +* Complex left eigenvector +* + WORK( KI + IV*N ) = CONE +* +* Form right-hand side. +* + DO 90 K = KI + 1, N + WORK( K + IV*N ) = -CONJG( T( KI, K ) ) + 90 CONTINUE +* +* Solve conjugate-transposed triangular system: +* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK. +* + DO 100 K = KI + 1, N + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 100 CONTINUE +* + IF( KI.LT.N ) THEN + CALL CLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, + $ WORK( KI+1 + IV*N ), SCALE, RWORK, INFO ) + WORK( KI + IV*N ) = SCALE + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL CCOPY( N-KI+1, WORK( KI + IV*N ), 1, VL(KI,IS), 1 ) +* + II = ICAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / CABS1( VL( II, IS ) ) + CALL CSSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 110 K = 1, KI - 1 + VL( K, IS ) = CZERO + 110 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N ) + $ CALL CGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 + IV*N ), 1, CMPLX( SCALE ), + $ VL( 1, KI ), 1 ) +* + II = ICAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / CABS1( VL( II, KI ) ) + CALL CSSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + IV*N ) = CZERO + END DO +* +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN + CALL CGEMM( 'N', 'N', N, IV, N-KI+IV, CONE, + $ VL( 1, KI-IV+1 ), LDVL, + $ WORK( KI-IV+1 + (1)*N ), N, + $ CZERO, + $ WORK( 1 + (NB+1)*N ), N ) +* normalize vectors + DO K = 1, IV + II = ICAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) + CALL CSSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL CLACPY( 'F', N, IV, + $ WORK( 1 + (NB+1)*N ), N, + $ VL( 1, KI-IV+1 ), LDVL ) + IV = 1 + ELSE + IV = IV + 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 120 K = KI + 1, N + T( K, K ) = WORK( K ) + 120 CONTINUE +* + IS = IS + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of CTREVC3 +* + END diff --git a/lapack-netlib/SRC/ctrexc.f b/lapack-netlib/SRC/ctrexc.f index 7abfd2b463..cefc32cb9f 100644 --- a/lapack-netlib/SRC/ctrexc.f +++ b/lapack-netlib/SRC/ctrexc.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTREXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX Q( LDQ, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,6 +57,7 @@ *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. *> \endverbatim *> *> \param[in,out] T @@ -84,7 +85,8 @@ *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in] IFST @@ -112,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ @@ -169,9 +171,9 @@ SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -181,7 +183,7 @@ SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * Quick return if possible * - IF( N.EQ.1 .OR. IFST.EQ.ILST ) + IF( N.LE.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN diff --git a/lapack-netlib/SRC/ctrrfs.f b/lapack-netlib/SRC/ctrrfs.f index 110ec4e366..840f9b5096 100644 --- a/lapack-netlib/SRC/ctrrfs.f +++ b/lapack-netlib/SRC/ctrrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctrsen.f b/lapack-netlib/SRC/ctrsen.f index 034176aec6..aaba3c5a21 100644 --- a/lapack-netlib/SRC/ctrsen.f +++ b/lapack-netlib/SRC/ctrsen.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, * SEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, JOB * INTEGER INFO, LDQ, LDT, LWORK, M, N @@ -30,7 +30,7 @@ * LOGICAL SELECT( * ) * COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -264,10 +264,10 @@ SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB diff --git a/lapack-netlib/SRC/ctrsna.f b/lapack-netlib/SRC/ctrsna.f index 53c34ba3a9..e08185b08b 100644 --- a/lapack-netlib/SRC/ctrsna.f +++ b/lapack-netlib/SRC/ctrsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N @@ -32,7 +32,7 @@ * COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -249,10 +249,10 @@ SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/ctrsyl.f b/lapack-netlib/SRC/ctrsyl.f index 5b584826f9..2561804de7 100644 --- a/lapack-netlib/SRC/ctrsyl.f +++ b/lapack-netlib/SRC/ctrsyl.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, * LDC, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANA, TRANB * INTEGER INFO, ISGN, LDA, LDB, LDC, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexSYcomputational * @@ -157,10 +157,10 @@ SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB diff --git a/lapack-netlib/SRC/ctrti2.f b/lapack-netlib/SRC/ctrti2.f index c4203dbab0..55d8d1fa76 100644 --- a/lapack-netlib/SRC/ctrti2.f +++ b/lapack-netlib/SRC/ctrti2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ctrtri.f b/lapack-netlib/SRC/ctrtri.f index 5631ae59c2..4c284d18db 100644 --- a/lapack-netlib/SRC/ctrtri.f +++ b/lapack-netlib/SRC/ctrtri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ctrtrs.f b/lapack-netlib/SRC/ctrtrs.f index b7b505f817..4019ced039 100644 --- a/lapack-netlib/SRC/ctrtrs.f +++ b/lapack-netlib/SRC/ctrtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -140,10 +140,10 @@ SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ctrttf.f b/lapack-netlib/SRC/ctrttf.f index b1086b6fe1..c762b0c334 100644 --- a/lapack-netlib/SRC/ctrttf.f +++ b/lapack-netlib/SRC/ctrttf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,7 +81,7 @@ *> *> \param[out] ARF *> \verbatim -*> ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ), +*> ARF is COMPLEX array, dimension ( N*(N+1)/2 ), *> On exit, the upper or lower triangular matrix A stored in *> RFP format. For a further discussion see Notes below. *> \endverbatim @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -216,10 +216,10 @@ * ===================================================================== SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ctrttp.f b/lapack-netlib/SRC/ctrttp.f index 323ce03dfc..0fa3e1a5a7 100644 --- a/lapack-netlib/SRC/ctrttp.f +++ b/lapack-netlib/SRC/ctrttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTRTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTRTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ctzrzf.f b/lapack-netlib/SRC/ctzrzf.f index 041a4c70e3..f3f5fdfc3c 100644 --- a/lapack-netlib/SRC/ctzrzf.f +++ b/lapack-netlib/SRC/ctzrzf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CTZRZF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CTZRZF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,10 +111,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -142,7 +142,7 @@ *> *> V = ( I A(:,M+1:N) ) *> -*> I is the M-by-M identity matrix, A(:,M+1:N) +*> I is the M-by-M identity matrix, A(:,M+1:N) *> is the output stored in A on exit from DTZRZF, *> and tau(k) is the kth element of the array TAU. *> @@ -151,7 +151,7 @@ * ===================================================================== SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/cunbdb.f b/lapack-netlib/SRC/cunbdb.f index 36c52d18f2..9006242c6f 100644 --- a/lapack-netlib/SRC/cunbdb.f +++ b/lapack-netlib/SRC/cunbdb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNBDB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, * TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIGNS, TRANS * INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, @@ -33,7 +33,7 @@ * $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), * $ X21( LDX21, * ), X22( LDX22, * ) * .. -* +* * *> \par Purpose: * ============= @@ -250,12 +250,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -287,10 +287,10 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -396,7 +396,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * IF( COLMAJOR ) THEN * -* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 * DO I = 1, Q * @@ -427,7 +427,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, END IF X11(I,I) = ONE IF ( M-P .GT. I ) THEN - CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) ELSE IF ( M-P .EQ. I ) THEN CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, @@ -436,7 +436,7 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, + CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) diff --git a/lapack-netlib/SRC/cunbdb1.f b/lapack-netlib/SRC/cunbdb1.f index fea26b21a8..fdcc686d2c 100644 --- a/lapack-netlib/SRC/cunbdb1.f +++ b/lapack-netlib/SRC/cunbdb1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB1 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -151,7 +151,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -168,10 +168,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -202,7 +202,7 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -307,9 +307,8 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) - C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), - $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), - $ 1 )**2 ) + C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + SCNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) CALL CUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, diff --git a/lapack-netlib/SRC/cunbdb2.f b/lapack-netlib/SRC/cunbdb2.f index cec00f93cd..d95276e59e 100644 --- a/lapack-netlib/SRC/cunbdb2.f +++ b/lapack-netlib/SRC/cunbdb2.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB2 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -168,10 +168,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -202,7 +202,7 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -282,7 +282,7 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., P of X11 and X21 * DO I = 1, P -* +* IF( I .GT. 1 ) THEN CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, $ S ) @@ -296,8 +296,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), $ X21(I,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) - S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + SCNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 + $ + SCNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL CUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, diff --git a/lapack-netlib/SRC/cunbdb3.f b/lapack-netlib/SRC/cunbdb3.f index 5451ef0031..a9d05c20e0 100644 --- a/lapack-netlib/SRC/cunbdb3.f +++ b/lapack-netlib/SRC/cunbdb3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB3 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -168,10 +168,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -202,7 +202,7 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -281,7 +281,7 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., M-P of X11 and X21 * DO I = 1, M-P -* +* IF( I .GT. 1 ) THEN CALL CSROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, $ S ) @@ -296,8 +296,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) - C = SQRT( SCNRM2( P-I+1, X11(I,I), 1, X11(I,I), - $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + C = SQRT( SCNRM2( P-I+1, X11(I,I), 1 )**2 + $ + SCNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL CUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, diff --git a/lapack-netlib/SRC/cunbdb4.f b/lapack-netlib/SRC/cunbdb4.f index bc948a30f5..8388e4e8cd 100644 --- a/lapack-netlib/SRC/cunbdb4.f +++ b/lapack-netlib/SRC/cunbdb4.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB4 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -30,8 +30,8 @@ * COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), * $ WORK(*), X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -161,7 +161,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -178,10 +178,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -213,7 +213,7 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -344,9 +344,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) IF( I .LT. M-Q ) THEN - S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), - $ 1 )**2 ) + S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 + $ + SCNRM2( M-P-I, X21(I+1,I), 1 )**2 ) PHI(I) = ATAN2( S, C ) END IF * diff --git a/lapack-netlib/SRC/cunbdb5.f b/lapack-netlib/SRC/cunbdb5.f index d3a7d1535e..006522d25d 100644 --- a/lapack-netlib/SRC/cunbdb5.f +++ b/lapack-netlib/SRC/cunbdb5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB5 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -156,7 +156,7 @@ SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -269,6 +269,6 @@ SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, RETURN * * End of CUNBDB5 -* +* END diff --git a/lapack-netlib/SRC/cunbdb6.f b/lapack-netlib/SRC/cunbdb6.f index 943e522496..ab7fe8a48e 100644 --- a/lapack-netlib/SRC/cunbdb6.f +++ b/lapack-netlib/SRC/cunbdb6.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNBDB6 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -141,10 +141,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -154,7 +154,7 @@ SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -261,7 +261,7 @@ SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, IF( NORMSQ2 .EQ. ZERO ) THEN RETURN END IF -* +* NORMSQ1 = NORMSQ2 * DO I = 1, N @@ -306,7 +306,7 @@ SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, END IF * RETURN -* +* * End of CUNBDB6 * END diff --git a/lapack-netlib/SRC/cuncsd.f b/lapack-netlib/SRC/cuncsd.f index ca3922da4a..829c4bcf98 100644 --- a/lapack-netlib/SRC/cuncsd.f +++ b/lapack-netlib/SRC/cuncsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -24,7 +24,7 @@ * U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, * LDV2T, WORK, LWORK, RWORK, LRWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, @@ -39,7 +39,7 @@ * $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, * $ * ) * .. -* +* * *> \par Purpose: * ============= @@ -303,12 +303,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -320,10 +320,10 @@ RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ LDV2T, WORK, LWORK, RWORK, LRWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -363,15 +363,15 @@ RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, LOGICAL LRQUERY * .. * .. External Subroutines .. - EXTERNAL XERBLA, CBBCSD, CLACPY, CLAPMR, CLAPMT, CLASCL, - $ CLASET, CUNBDB, CUNGLQ, CUNGQR + EXTERNAL XERBLA, CBBCSD, CLACPY, CLAPMR, CLAPMT, + $ CUNBDB, CUNGLQ, CUNGQR * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions - INTRINSIC COS, INT, MAX, MIN, SIN + INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * @@ -471,7 +471,7 @@ RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, $ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA, $ THETA, THETA, THETA, RWORK, -1, CHILDINFO ) @@ -488,12 +488,12 @@ RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) - CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1, + CALL CUNGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) - CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1, + CALL CUNGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) @@ -621,7 +621,7 @@ RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, * Permute rows and columns to place identity submatrices in top- * left corner of (1,1)-block and/or bottom-right corner of (1,2)- * block and/or bottom-right corner of (2,1)-block and/or top-left -* corner of (2,2)-block +* corner of (2,2)-block * IF( Q .GT. 0 .AND. WANTU2 ) THEN DO I = 1, Q diff --git a/lapack-netlib/SRC/cuncsd2by1.f b/lapack-netlib/SRC/cuncsd2by1.f index 1b2b0fb2ac..64070ca9a4 100644 --- a/lapack-netlib/SRC/cuncsd2by1.f +++ b/lapack-netlib/SRC/cuncsd2by1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download CUNCSD2BY1 + dependencies @@ -22,7 +22,7 @@ * X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, * LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T * INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, @@ -36,8 +36,8 @@ * $ X11(LDX11,*), X21(LDX21,*) * INTEGER IWORK(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -47,18 +47,19 @@ *> orthonormal columns that has been partitioned into a 2-by-1 block *> structure: *> -*> [ I 0 0 ] +*> [ I1 0 0 ] *> [ 0 C 0 ] *> [ X11 ] [ U1 | ] [ 0 0 0 ] *> X = [-----] = [---------] [----------] V1**T . *> [ X21 ] [ | U2 ] [ 0 0 0 ] *> [ 0 S 0 ] -*> [ 0 0 I ] -*> +*> [ 0 0 I2] +*> *> X11 is P-by-Q. The unitary matrices U1, U2, and V1 are P-by-P, *> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R *> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which -*> R = MIN(P,M-P,Q,M-Q). +*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a +*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). *> *> \endverbatim * @@ -209,7 +210,7 @@ *> \verbatim *> LRWORK is INTEGER *> The dimension of the array RWORK. -*> +*> *> If LRWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the RWORK array, returns *> this value as the first entry of the work array, and no error @@ -239,12 +240,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date July 2012 +*> \date June 2016 * *> \ingroup complexOTHERcomputational * @@ -254,10 +255,10 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* July 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T @@ -272,7 +273,7 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ X11(LDX11,*), X21(LDX21,*) INTEGER IWORK(*) * .. -* +* * ===================================================================== * * .. Parameters .. @@ -288,6 +289,10 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LWORKMIN, LWORKOPT, R LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T * .. +* .. Local Arrays .. + REAL DUM( 1 ) + COMPLEX CDUM( 1, 1 ) +* .. * .. External Subroutines .. EXTERNAL CBBCSD, CCOPY, CLACPY, CLAPMR, CLAPMT, CUNBDB1, $ CUNBDB2, CUNBDB3, CUNBDB4, CUNGLQ, CUNGQR, @@ -320,11 +325,11 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, INFO = -8 ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -10 - ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN INFO = -13 - ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN INFO = -15 - ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN INFO = -17 END IF * @@ -380,99 +385,119 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, IORBDB = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ1 + MAX( 1, Q ) IORGLQ = ITAUQ1 + MAX( 1, Q ) + LORGQRMIN = 1 + LORGQROPT = 1 + LORGLQMIN = 1 + LORGLQOPT = 1 IF( R .EQ. Q ) THEN - CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK, -1, CHILDINFO ) + CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM, CDUM, CDUM, CDUM, WORK, -1, + $ CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CUNGQR( P, P, Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + ENDIF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CUNGLQ( Q-1, Q-1, Q-1, V1T, LDV1T, + $ CDUM, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q-1 ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL CUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, - $ 0, WORK(1), -1, CHILDINFO ) - LORGLQMIN = MAX( 1, Q-1 ) - LORGLQOPT = INT( WORK(1) ) CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, - $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + $ DUM(1), U1, LDU1, U2, LDU2, V1T, LDV1T, CDUM, + $ 1, DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE IF( R .EQ. P ) THEN - CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P-1 .GE. M-P ) THEN - CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, CDUM, WORK(1), $ -1, CHILDINFO ) - LORGQRMIN = MAX( 1, P-1 ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, - $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + $ DUM, V1T, LDV1T, CDUM, 1, U1, LDU1, U2, LDU2, + $ DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE IF( R .EQ. M-P ) THEN - CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P-1 ) THEN - CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CUNGQR( P, P, Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, CDUM, $ WORK(1), -1, CHILDINFO ) - LORGQRMIN = MAX( 1, M-P-1 ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, - $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM, CDUM, 1, V1T, LDV1T, U2, LDU2, U1, + $ LDU1, DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE - CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO + $ ) LORBDB = M + INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL CUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CUNGQR( P, P, M-Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, - $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM, U2, LDU2, U1, LDU1, CDUM, 1, V1T, + $ LDV1T, DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) END IF LRWORKMIN = IBBCSD+LBBCSD-1 @@ -534,16 +559,16 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL CUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, - $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, CDUM, + $ 1, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place zero submatrices in * preferred positions * @@ -588,16 +613,16 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, - $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IPHI), V1T, LDV1T, CDUM, 1, U1, LDU1, U2, + $ LDU2, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -643,16 +668,16 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, + $ THETA, RWORK(IPHI), CDUM, 1, V1T, LDV1T, U2, LDU2, $ U1, LDU1, RWORK(IB11D), RWORK(IB11E), $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -712,16 +737,16 @@ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, - $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), - $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), - $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, CDUM, 1, + $ V1T, LDV1T, RWORK(IB11D), RWORK(IB11E), + $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), + $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), + $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place identity submatrices in * preferred positions * diff --git a/lapack-netlib/SRC/cung2l.f b/lapack-netlib/SRC/cung2l.f index 7a8c235d1a..88d285e9fa 100644 --- a/lapack-netlib/SRC/cung2l.f +++ b/lapack-netlib/SRC/cung2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/cung2r.f b/lapack-netlib/SRC/cung2r.f index 93196c4d3f..eea37d18e0 100644 --- a/lapack-netlib/SRC/cung2r.f +++ b/lapack-netlib/SRC/cung2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/cungbr.f b/lapack-netlib/SRC/cungbr.f index 8eb62b724d..df25799ca1 100644 --- a/lapack-netlib/SRC/cungbr.f +++ b/lapack-netlib/SRC/cungbr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,10 +145,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ * ===================================================================== SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -183,8 +183,7 @@ SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CUNGLQ, CUNGQR, XERBLA diff --git a/lapack-netlib/SRC/cunghr.f b/lapack-netlib/SRC/cunghr.f index 5eb6b58d31..40c71d4a77 100644 --- a/lapack-netlib/SRC/cunghr.f +++ b/lapack-netlib/SRC/cunghr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/cungl2.f b/lapack-netlib/SRC/cungl2.f index ab52342112..837354da23 100644 --- a/lapack-netlib/SRC/cungl2.f +++ b/lapack-netlib/SRC/cungl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/cunglq.f b/lapack-netlib/SRC/cunglq.f index c6a7cdd786..10c2deef32 100644 --- a/lapack-netlib/SRC/cunglq.f +++ b/lapack-netlib/SRC/cunglq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cungql.f b/lapack-netlib/SRC/cungql.f index 2da65467e4..4a13826ebe 100644 --- a/lapack-netlib/SRC/cungql.f +++ b/lapack-netlib/SRC/cungql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cungqr.f b/lapack-netlib/SRC/cungqr.f index 8e1a3dfde0..f8d06429a9 100644 --- a/lapack-netlib/SRC/cungqr.f +++ b/lapack-netlib/SRC/cungqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cungr2.f b/lapack-netlib/SRC/cungr2.f index 51e3a29b73..defc5859fa 100644 --- a/lapack-netlib/SRC/cungr2.f +++ b/lapack-netlib/SRC/cungr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/cungrq.f b/lapack-netlib/SRC/cungrq.f index 6c8005db42..50837445e3 100644 --- a/lapack-netlib/SRC/cungrq.f +++ b/lapack-netlib/SRC/cungrq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/cungtr.f b/lapack-netlib/SRC/cungtr.f index 45a43df1c6..2749bc366c 100644 --- a/lapack-netlib/SRC/cungtr.f +++ b/lapack-netlib/SRC/cungtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cunm2l.f b/lapack-netlib/SRC/cunm2l.f index 09e3e54a62..75dd5f911e 100644 --- a/lapack-netlib/SRC/cunm2l.f +++ b/lapack-netlib/SRC/cunm2l.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunm2r.f b/lapack-netlib/SRC/cunm2r.f index 72eee72220..569276f8c6 100644 --- a/lapack-netlib/SRC/cunm2r.f +++ b/lapack-netlib/SRC/cunm2r.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmbr.f b/lapack-netlib/SRC/cunmbr.f index 2f6211528e..4136fcd4b9 100644 --- a/lapack-netlib/SRC/cunmbr.f +++ b/lapack-netlib/SRC/cunmbr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -197,10 +197,10 @@ SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT diff --git a/lapack-netlib/SRC/cunmhr.f b/lapack-netlib/SRC/cunmhr.f index 65e6b1e080..aa6588631e 100644 --- a/lapack-netlib/SRC/cunmhr.f +++ b/lapack-netlib/SRC/cunmhr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunml2.f b/lapack-netlib/SRC/cunml2.f index 06b03f6223..b55b0c2442 100644 --- a/lapack-netlib/SRC/cunml2.f +++ b/lapack-netlib/SRC/cunml2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmlq.f b/lapack-netlib/SRC/cunmlq.f index c5a5876292..8cf4442c27 100644 --- a/lapack-netlib/SRC/cunmlq.f +++ b/lapack-netlib/SRC/cunmlq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -243,9 +243,9 @@ SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, END IF * IF( INFO.EQ.0 ) THEN -* +* * Compute the workspace requirements -* +* IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN LWKOPT = 1 ELSE diff --git a/lapack-netlib/SRC/cunmql.f b/lapack-netlib/SRC/cunmql.f index 02f6aa46d3..e7279607a8 100644 --- a/lapack-netlib/SRC/cunmql.f +++ b/lapack-netlib/SRC/cunmql.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmqr.f b/lapack-netlib/SRC/cunmqr.f index 2334dbc792..41fee718ea 100644 --- a/lapack-netlib/SRC/cunmqr.f +++ b/lapack-netlib/SRC/cunmqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmr2.f b/lapack-netlib/SRC/cunmr2.f index 1daec6e700..40b6583d19 100644 --- a/lapack-netlib/SRC/cunmr2.f +++ b/lapack-netlib/SRC/cunmr2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmr3.f b/lapack-netlib/SRC/cunmr3.f index 9ce2582843..0a8bad8f09 100644 --- a/lapack-netlib/SRC/cunmr3.f +++ b/lapack-netlib/SRC/cunmr3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmrq.f b/lapack-netlib/SRC/cunmrq.f index ecde2cd19c..3513215a8e 100644 --- a/lapack-netlib/SRC/cunmrq.f +++ b/lapack-netlib/SRC/cunmrq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmrz.f b/lapack-netlib/SRC/cunmrz.f index 205f550d31..ccf9cd5d06 100644 --- a/lapack-netlib/SRC/cunmrz.f +++ b/lapack-netlib/SRC/cunmrz.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -187,10 +187,10 @@ SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/cunmtr.f b/lapack-netlib/SRC/cunmtr.f index b6ee941dca..81d2ca6d2c 100644 --- a/lapack-netlib/SRC/cunmtr.f +++ b/lapack-netlib/SRC/cunmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUNMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUNMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -172,10 +172,10 @@ SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/cupgtr.f b/lapack-netlib/SRC/cupgtr.f index fddf562bc4..4c75d3ea1c 100644 --- a/lapack-netlib/SRC/cupgtr.f +++ b/lapack-netlib/SRC/cupgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUPGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUPGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDQ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/cupmtr.f b/lapack-netlib/SRC/cupmtr.f index a55d65a709..eb6d219c68 100644 --- a/lapack-netlib/SRC/cupmtr.f +++ b/lapack-netlib/SRC/cupmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CUPMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CUPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complexOTHERcomputational * @@ -150,10 +150,10 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/dbbcsd.f b/lapack-netlib/SRC/dbbcsd.f index 2c54d1c5d2..d7c7d14a78 100644 --- a/lapack-netlib/SRC/dbbcsd.f +++ b/lapack-netlib/SRC/dbbcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DBBCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DBBCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, * V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, * B22D, B22E, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -34,7 +34,7 @@ * DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,7 +149,7 @@ *> \param[in,out] U1 *> \verbatim *> U1 is DOUBLE PRECISION array, dimension (LDU1,P) -*> On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied +*> On entry, a P-by-P matrix. On exit, U1 is postmultiplied *> by the left singular vector matrix common to [ B11 ; 0 ] and *> [ B12 0 0 ; 0 -I 0 0 ]. *> \endverbatim @@ -157,13 +157,13 @@ *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER -*> The leading dimension of the array U1. +*> The leading dimension of the array U1, LDU1 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] U2 *> \verbatim *> U2 is DOUBLE PRECISION array, dimension (LDU2,M-P) -*> On entry, an LDU2-by-(M-P) matrix. On exit, U2 is +*> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is *> postmultiplied by the left singular vector matrix common to *> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. *> \endverbatim @@ -171,13 +171,13 @@ *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER -*> The leading dimension of the array U2. +*> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] V1T *> \verbatim *> V1T is DOUBLE PRECISION array, dimension (LDV1T,Q) -*> On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied +*> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied *> by the transpose of the right singular vector *> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. *> \endverbatim @@ -185,13 +185,13 @@ *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER -*> The leading dimension of the array V1T. +*> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). *> \endverbatim *> *> \param[in,out] V2T *> \verbatim *> V2T is DOUBLE PRECISION array, dimenison (LDV2T,M-Q) -*> On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is +*> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is *> premultiplied by the transpose of the right *> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and *> [ B22 0 0 ; 0 0 I ]. @@ -200,7 +200,7 @@ *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER -*> The leading dimension of the array V2T. +*> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). *> \endverbatim *> *> \param[out] B11D @@ -317,12 +317,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * @@ -332,10 +332,10 @@ SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS diff --git a/lapack-netlib/SRC/dbdsdc.f b/lapack-netlib/SRC/dbdsdc.f index 2c572f12ce..e349b0cc08 100644 --- a/lapack-netlib/SRC/dbdsdc.f +++ b/lapack-netlib/SRC/dbdsdc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DBDSDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DBDSDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, UPLO * INTEGER INFO, LDU, LDVT, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -186,12 +186,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -205,10 +205,10 @@ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, UPLO @@ -311,7 +311,7 @@ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WSTART = 1 QSTART = 3 IF( ICOMPQ.EQ.1 ) THEN - CALL DCOPY( N, D, 1, Q( 1 ), 1 ) + CALL DCOPY( N, D, 1, Q( 1 ), 1 ) CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 ) END IF IF( IUPLO.EQ.2 ) THEN @@ -335,8 +335,11 @@ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, * If ICOMPQ = 0, use DLASDQ to compute the singular values. * IF( ICOMPQ.EQ.0 ) THEN +* Ignore WSTART, instead using WORK( 1 ), since the two vectors +* for CS and -SN above are added only if ICOMPQ == 2, +* and adding them exceeds documented WORK size of 4*n. CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, - $ LDU, WORK( WSTART ), INFO ) + $ LDU, WORK( 1 ), INFO ) GO TO 40 END IF * @@ -412,24 +415,24 @@ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, DO 30 I = 1, NM1 IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN * -* Subproblem found. First determine its size and then -* apply divide and conquer on it. +* Subproblem found. First determine its size and then +* apply divide and conquer on it. * IF( I.LT.NM1 ) THEN * -* A subproblem with E(I) small for I < NM1. +* A subproblem with E(I) small for I < NM1. * NSIZE = I - START + 1 ELSE IF( ABS( E( I ) ).GE.EPS ) THEN * -* A subproblem with E(NM1) not too small but I = NM1. +* A subproblem with E(NM1) not too small but I = NM1. * NSIZE = N - START + 1 ELSE * -* A subproblem with E(NM1) small. This implies an -* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem -* first. +* A subproblem with E(NM1) small. This implies an +* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem +* first. * NSIZE = I - START + 1 IF( ICOMPQ.EQ.2 ) THEN diff --git a/lapack-netlib/SRC/dbdsqr.f b/lapack-netlib/SRC/dbdsqr.f index 007e99779b..c4cfbb3f7e 100644 --- a/lapack-netlib/SRC/dbdsqr.f +++ b/lapack-netlib/SRC/dbdsqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,9 +40,9 @@ *> left singular vectors from the singular value decomposition (SVD) of *> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit *> zero-shift QR algorithm. The SVD of B has the form -*> +*> *> B = Q * S * P**T -*> +*> *> where S is the diagonal matrix of singular values, Q is an orthogonal *> matrix of left singular vectors, and P is an orthogonal matrix of *> right singular vectors. If left singular vectors are requested, this @@ -113,7 +113,7 @@ *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the N-1 offdiagonal elements of the bidiagonal -*> matrix B. +*> matrix B. *> On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E *> will contain the diagonal and superdiagonal elements of a *> bidiagonal matrix orthogonally equivalent to the one given @@ -179,7 +179,7 @@ *> = 1, a split was marked by a positive value in E *> = 2, current block of Z not diagonalized after 30*N *> iterations (in inner while loop) -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> else NCVT = NRU = NCC = 0, *> the algorithm did not converge; D and E contain the @@ -214,15 +214,25 @@ *> through the inner loop exceeds MAXITR*N**2. *> \endverbatim * +*> \par Note: +* =========== +*> +*> \verbatim +*> Bug report from Cezary Dendek. +*> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is +*> removed since it can overflow pretty easily (for N larger or equal +*> than 18,919). We instead use MAXITDIVN = MAXITR*N. +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -230,10 +240,10 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -266,8 +276,8 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, - $ NM12, NM13, OLDLL, OLDM + INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M, + $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, @@ -300,7 +310,7 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, ELSE IF( NRU.LT.0 ) THEN INFO = -4 ELSE IF( NCC.LT.0 ) THEN - INFO = -5 + INFO = -5 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN INFO = -9 @@ -329,7 +339,7 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, CALL DLASQ1( N, D, E, WORK, INFO ) * * If INFO equals 2, dqds didn't finish, try to finish -* +* IF( INFO .NE. 2 ) RETURN INFO = 0 END IF @@ -400,20 +410,21 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) + THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) ELSE * * Absolute accuracy desired * - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) + THRESH = MAX( ABS( TOL )*SMAX, MAXITR*(N*(N*UNFL)) ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * - MAXIT = MAXITR*N*N - ITER = 0 + MAXITDIVN = MAXITR*N + ITERDIVN = 0 + ITER = -1 OLDLL = -1 OLDM = -1 * @@ -429,8 +440,13 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * IF( M.LE.1 ) $ GO TO 160 - IF( ITER.GT.MAXIT ) +* + IF( ITER.GE.N ) THEN + ITER = ITER - N + ITERDIVN = ITERDIVN + 1 + IF (ITERDIVN.GE.MAXITDIVN ) $ GO TO 200 + END IF * * Find diagonal block of matrix to work on * diff --git a/lapack-netlib/SRC/dbdsvdx.f b/lapack-netlib/SRC/dbdsvdx.f index 7ceb9392c3..94f52b4e60 100644 --- a/lapack-netlib/SRC/dbdsvdx.f +++ b/lapack-netlib/SRC/dbdsvdx.f @@ -2,23 +2,23 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DBDSVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DBDSVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * $ NS, S, Z, LDZ, WORK, IWORK, INFO ) * * .. Scalar Arguments .. @@ -28,45 +28,45 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), +* DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), * Z( LDZ, * ) * .. -* +* *> \par Purpose: * ============= *> *> \verbatim *> *> DBDSVDX computes the singular value decomposition (SVD) of a real -*> N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, -*> where S is a diagonal matrix with non-negative diagonal elements -*> (the singular values of B), and U and VT are orthogonal matrices +*> N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, +*> where S is a diagonal matrix with non-negative diagonal elements +*> (the singular values of B), and U and VT are orthogonal matrices *> of left and right singular vectors, respectively. *> -*> Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] -*> and superdiagonal E = [ e_1 e_2 ... e_N-1 ], DBDSVDX computes the -*> singular value decompositon of B through the eigenvalues and +*> Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] +*> and superdiagonal E = [ e_1 e_2 ... e_N-1 ], DBDSVDX computes the +*> singular value decompositon of B through the eigenvalues and *> eigenvectors of the N*2-by-N*2 tridiagonal matrix -*> -*> | 0 d_1 | -*> | d_1 0 e_1 | -*> TGK = | e_1 0 d_2 | -*> | d_2 . . | +*> +*> | 0 d_1 | +*> | d_1 0 e_1 | +*> TGK = | e_1 0 d_2 | +*> | d_2 . . | *> | . . . | *> -*> If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then -*> (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / -*> sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and -*> P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. +*> If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then +*> (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / +*> sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and +*> P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. *> -*> Given a TGK matrix, one can either a) compute -s,-v and change signs -*> so that the singular values (and corresponding vectors) are already in -*> descending order (as in DGESVD/DGESDD) or b) compute s,v and reorder -*> the values (and corresponding vectors). DBDSVDX implements a) by -*> calling DSTEVX (bisection plus inverse iteration, to be replaced -*> with a version of the Multiple Relative Robust Representation -*> algorithm. (See P. Willems and B. Lang, A framework for the MR^3 -*> algorithm: theory and implementation, SIAM J. Sci. Comput., +*> Given a TGK matrix, one can either a) compute -s,-v and change signs +*> so that the singular values (and corresponding vectors) are already in +*> descending order (as in DGESVD/DGESDD) or b) compute s,v and reorder +*> the values (and corresponding vectors). DBDSVDX implements a) by +*> calling DSTEVX (bisection plus inverse iteration, to be replaced +*> with a version of the Multiple Relative Robust Representation +*> algorithm. (See P. Willems and B. Lang, A framework for the MR^3 +*> algorithm: theory and implementation, SIAM J. Sci. Comput., *> 35:740-766, 2013.) *> \endverbatim * @@ -80,7 +80,7 @@ *> = 'L': B is lower bidiagonal. *> \endverbatim *> -*> \param[in] JOBXZ +*> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute singular values only; @@ -101,13 +101,13 @@ *> N is INTEGER *> The order of the bidiagonal matrix. N >= 0. *> \endverbatim -*> +*> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the bidiagonal matrix B. *> \endverbatim -*> +*> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (max(1,N-1)) @@ -117,14 +117,16 @@ *> *> \param[in] VL *> \verbatim -*> VL is DOUBLE PRECISION -*> VL >=0. +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,13 +134,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -161,14 +167,14 @@ *> \verbatim *> Z is DOUBLE PRECISION array, dimension (2*N,K) ) *> If JOBZ = 'V', then if INFO = 0 the first NS columns of Z -*> contain the singular vectors of the matrix B corresponding to +*> contain the singular vectors of the matrix B corresponding to *> the selected singular values, with U in rows 1 to N and V *> in rows N+1 to N*2, i.e. -*> Z = [ U ] +*> Z = [ U ] *> [ V ] -*> If JOBZ = 'N', then Z is not referenced. -*> Note: The user must ensure that at least K = NS+1 columns are -*> supplied in the array Z; if RANGE = 'V', the exact value of +*> If JOBZ = 'N', then Z is not referenced. +*> Note: The user must ensure that at least K = NS+1 columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of *> NS is not known in advance and an upper bound must be used. *> \endverbatim *> @@ -188,9 +194,12 @@ *> \verbatim *> IWORK is INTEGER array, dimension (12*N) *> If JOBZ = 'V', then if INFO = 0, the first NS elements of -*> IWORK are zero. If INFO > 0, then IWORK contains the indices +*> IWORK are zero. If INFO > 0, then IWORK contains the indices *> of the eigenvectors that failed to converge in DSTEVX. +*> \endverbatim *> +*> \param[out] INFO +*> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value @@ -204,24 +213,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * -* ===================================================================== - SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* ===================================================================== + SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ NS, S, Z, LDZ, WORK, IWORK, INFO) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2016 -* +* December 2016 +* * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDZ, N, NS @@ -229,28 +238,28 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * .. * .. Array Arguments .. INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), + DOUBLE PRECISION D( * ), E( * ), S( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN, HNDRD, MEIGTH - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, + DOUBLE PRECISION ZERO, ONE, TEN, HNDRD, MEIGTH + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, $ HNDRD = 100.0D0, MEIGTH = -0.1250D0 ) DOUBLE PRECISION FUDGE PARAMETER ( FUDGE = 2.0D0 ) * .. -* .. Local Scalars .. +* .. Local Scalars .. CHARACTER RNGVX - LOGICAL ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ - INTEGER I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR, - $ IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV, - $ IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K, + LOGICAL ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ + INTEGER I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR, + $ IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV, + $ IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K, $ NTGK, NRU, NRV, NSL DOUBLE PRECISION ABSTOL, EPS, EMIN, MU, NRMU, NRMV, ORTOL, SMAX, - $ SMIN, SQRT2, THRESH, TOL, ULP, + $ SMIN, SQRT2, THRESH, TOL, ULP, $ VLTGK, VUTGK, ZJTJI * .. * .. External Functions .. @@ -265,7 +274,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, SIGN, SQRT * .. -* .. Executable Statements .. +* .. Executable Statements .. * * Test the input parameters. * @@ -312,7 +321,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * NS = 0 IF( N.EQ.0 ) RETURN -* +* IF( N.EQ.1 ) THEN IF( ALLSV .OR. INDSV ) THEN NS = 1 @@ -330,17 +339,17 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, RETURN END IF * - ABSTOL = 2*DLAMCH( 'Safe Minimum' ) + ABSTOL = 2*DLAMCH( 'Safe Minimum' ) ULP = DLAMCH( 'Precision' ) EPS = DLAMCH( 'Epsilon' ) SQRT2 = SQRT( 2.0D0 ) ORTOL = SQRT( ULP ) -* +* * Criterion for splitting is taken from DBDSQR when singular -* values are computed to relative accuracy TOL. (See J. Demmel and -* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM +* values are computed to relative accuracy TOL. (See J. Demmel and +* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM * J. Sci. and Stat. Comput., 11:873–912, 1990.) -* +* TOL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS * * Compute approximate maximum, minimum singular values. @@ -371,7 +380,6 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( ABS( E( I ) ).LE.THRESH ) E( I ) = ZERO END DO IF( ABS( D( N ) ).LE.THRESH ) D( N ) = ZERO - E( N ) = ZERO * * Pointers for arrays used by DSTEVX. * @@ -382,23 +390,23 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IIWORK = IIFAIL + N*2 * * Set RNGVX, which corresponds to RANGE for DSTEVX in TGK mode. -* VL,VU or IL,IU are redefined to conform to implementation a) +* VL,VU or IL,IU are redefined to conform to implementation a) * described in the leading comments. * ILTGK = 0 - IUTGK = 0 + IUTGK = 0 VLTGK = ZERO VUTGK = ZERO * IF( ALLSV ) THEN * -* All singular values will be found. We aim at -s (see +* All singular values will be found. We aim at -s (see * leading comments) with RNGVX = 'I'. IL and IU are set -* later (as ILTGK and IUTGK) according to the dimension +* later (as ILTGK and IUTGK) according to the dimension * of the active submatrix. * RNGVX = 'I' - CALL DLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ ) + IF( WANTZ ) CALL DLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ ) ELSE IF( VALSV ) THEN * * Find singular values in a half-open interval. We aim @@ -411,31 +419,31 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL DSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL DSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ), $ VLTGK, VUTGK, ILTGK, ILTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) IF( NS.EQ.0 ) THEN RETURN ELSE - CALL DLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ ) + IF( WANTZ ) CALL DLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ ) END IF ELSE IF( INDSV ) THEN * -* Find the IL-th through the IU-th singular values. We aim -* at -s (see leading comments) and indices are mapped into +* Find the IL-th through the IU-th singular values. We aim +* at -s (see leading comments) and indices are mapped into * values, therefore mimicking DSTEBZ, where * * GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN * GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN * ILTGK = IL - IUTGK = IU + IUTGK = IU RNGVX = 'V' WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), $ VLTGK, VLTGK, ILTGK, ILTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) @@ -443,7 +451,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL DCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), $ VUTGK, VUTGK, IUTGK, IUTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) @@ -451,12 +459,12 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, VUTGK = MIN( VUTGK, ZERO ) * * If VLTGK=VUTGK, DSTEVX returns an error message, -* so if needed we change VUTGK slightly. +* so if needed we change VUTGK slightly. * IF( VLTGK.EQ.VUTGK ) VLTGK = VLTGK - TOL * - CALL DLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ ) - END IF + IF( WANTZ ) CALL DLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ) + END IF * * Initialize variables and pointers for S, Z, and WORK. * @@ -475,7 +483,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IROWU = 2 IROWV = 1 SPLIT = .FALSE. - SVEQ0 = .FALSE. + SVEQ0 = .FALSE. * * Form the tridiagonal TGK matrix. * @@ -486,15 +494,15 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) * * -* Check for splits in two levels, outer level +* Check for splits in two levels, outer level * in E and inner level in D. * - DO IEPTR = 2, N*2, 2 - IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN + DO IEPTR = 2, N*2, 2 + IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN * * Split in E (this piece of B is square) or bottom * of the (input bidiagonal) matrix. -* +* ISPLT = IDBEG IDEND = IEPTR - 1 DO IDPTR = IDBEG, IDEND, 2 @@ -511,22 +519,22 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( IDBEG.EQ.IDEND) THEN NRU = 1 NRV = 1 - END IF + END IF ELSE IF( IDPTR.EQ.IDEND ) THEN * * D=0 at the bottom. * SVEQ0 = .TRUE. - NRU = (IDEND-ISPLT)/2 + 1 - NRV = NRU + NRU = (IDEND-ISPLT)/2 + 1 + NRV = NRU IF( ISPLT.NE.IDBEG ) THEN NRU = NRU + 1 - END IF + END IF ELSE IF( ISPLT.EQ.IDBEG ) THEN * * Split: top rectangular submatrix. -* +* NRU = (IDPTR-IDBEG)/2 NRV = NRU + 1 ELSE @@ -534,7 +542,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * Split: middle square submatrix. * NRU = (IDPTR-ISPLT)/2 + 1 - NRV = NRU + NRV = NRU END IF END IF ELSE IF( IDPTR.EQ.IDEND ) THEN @@ -552,7 +560,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * Split: bottom rectangular submatrix. * NRV = (IDEND-ISPLT)/2 + 1 - NRU = NRV + 1 + NRU = NRV + 1 END IF END IF * @@ -560,32 +568,32 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * IF( NTGK.GT.0 ) THEN * -* Compute eigenvalues/vectors of the active -* submatrix according to RANGE: +* Compute eigenvalues/vectors of the active +* submatrix according to RANGE: * if RANGE='A' (ALLSV) then RNGVX = 'I' * if RANGE='V' (VALSV) then RNGVX = 'V' * if RANGE='I' (INDSV) then RNGVX = 'V' * ILTGK = 1 - IUTGK = NTGK / 2 + IUTGK = NTGK / 2 IF( ALLSV .OR. VUTGK.EQ.ZERO ) THEN - IF( SVEQ0 .OR. - $ SMIN.LT.EPS .OR. + IF( SVEQ0 .OR. + $ SMIN.LT.EPS .OR. $ MOD(NTGK,2).GT.0 ) THEN * Special case: eigenvalue equal to zero or very * small, additional eigenvector is needed. IUTGK = IUTGK + 1 - END IF + END IF END IF * -* Workspace needed by DSTEVX: -* WORK( ITEMP: ): 2*5*NTGK +* Workspace needed by DSTEVX: +* WORK( ITEMP: ): 2*5*NTGK * IWORK( 1: ): 2*6*NTGK * - CALL DSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ), - $ WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK, - $ ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ), - $ Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ), + CALL DSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ), + $ WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK, + $ ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ), + $ Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ), $ IWORK( IIWORK ), IWORK( IIFAIL ), $ INFO ) IF( INFO.NE.0 ) THEN @@ -593,7 +601,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, RETURN END IF EMIN = ABS( MAXVAL( S( ISBEG:ISBEG+NSL-1 ) ) ) -* +* IF( NSL.GT.0 .AND. WANTZ ) THEN * * Normalize u=Z([2,4,...],:) and v=Z([1,3,...],:), @@ -607,22 +615,22 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( NSL.GT.1 .AND. $ VUTGK.EQ.ZERO .AND. $ MOD(NTGK,2).EQ.0 .AND. - $ EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN + $ EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN * * D=0 at the top or bottom of the active submatrix: -* one eigenvalue is equal to zero; concatenate the -* eigenvectors corresponding to the two smallest +* one eigenvalue is equal to zero; concatenate the +* eigenvectors corresponding to the two smallest * eigenvalues. * Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) = $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) + $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) - Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = - $ ZERO + Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = + $ ZERO * IF( IUTGK*2.GT.NTGK ) THEN * Eigenvalue equal to zero or very small. * NSL = NSL - 1 -* END IF +* END IF END IF * DO I = 0, MIN( NSL-1, NRU-1 ) @@ -631,20 +639,20 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, INFO = N*2 + 1 RETURN END IF - CALL DSCAL( NRU, ONE/NRMU, + CALL DSCAL( NRU, ONE/NRMU, $ Z( IROWU,ICOLZ+I ), 2 ) IF( NRMU.NE.ONE .AND. $ ABS( NRMU-ORTOL )*SQRT2.GT.ONE ) $ THEN DO J = 0, I-1 - ZJTJI = -DDOT( NRU, Z( IROWU, ICOLZ+J ), + ZJTJI = -DDOT( NRU, Z( IROWU, ICOLZ+J ), $ 2, Z( IROWU, ICOLZ+I ), 2 ) - CALL DAXPY( NRU, ZJTJI, + CALL DAXPY( NRU, ZJTJI, $ Z( IROWU, ICOLZ+J ), 2, $ Z( IROWU, ICOLZ+I ), 2 ) END DO NRMU = DNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 ) - CALL DSCAL( NRU, ONE/NRMU, + CALL DSCAL( NRU, ONE/NRMU, $ Z( IROWU,ICOLZ+I ), 2 ) END IF END DO @@ -654,7 +662,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, INFO = N*2 + 1 RETURN END IF - CALL DSCAL( NRV, -ONE/NRMV, + CALL DSCAL( NRV, -ONE/NRMV, $ Z( IROWV,ICOLZ+I ), 2 ) IF( NRMV.NE.ONE .AND. $ ABS( NRMV-ORTOL )*SQRT2.GT.ONE ) @@ -662,12 +670,12 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, DO J = 0, I-1 ZJTJI = -DDOT( NRV, Z( IROWV, ICOLZ+J ), $ 2, Z( IROWV, ICOLZ+I ), 2 ) - CALL DAXPY( NRU, ZJTJI, + CALL DAXPY( NRU, ZJTJI, $ Z( IROWV, ICOLZ+J ), 2, $ Z( IROWV, ICOLZ+I ), 2 ) END DO NRMV = DNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 ) - CALL DSCAL( NRV, ONE/NRMV, + CALL DSCAL( NRV, ONE/NRMV, $ Z( IROWV,ICOLZ+I ), 2 ) END IF END DO @@ -676,18 +684,18 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ MOD(NTGK,2).GT.0 ) THEN * * D=0 in the middle of the active submatrix (one -* eigenvalue is equal to zero): save the corresponding +* eigenvalue is equal to zero): save the corresponding * eigenvector for later use (when bottom of the * active submatrix is reached). * SPLIT = .TRUE. - Z( IROWZ:IROWZ+NTGK-1,N+1 ) = + Z( IROWZ:IROWZ+NTGK-1,N+1 ) = $ Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) - Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = - $ ZERO - END IF + Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = + $ ZERO + END IF END IF !** WANTZ **! -* +* NSL = MIN( NSL, NRU ) SVEQ0 = .FALSE. * @@ -698,25 +706,27 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, END DO * * Update pointers for TGK, S and Z. -* +* ISBEG = ISBEG + NSL IROWZ = IROWZ + NTGK ICOLZ = ICOLZ + NSL IROWU = IROWZ - IROWV = IROWZ + 1 + IROWV = IROWZ + 1 ISPLT = IDPTR + 1 NS = NS + NSL NRU = 0 - NRV = 0 - END IF !** NTGK.GT.0 **! - IF( IROWZ.LT.N*2 ) Z( 1:IROWZ-1, ICOLZ ) = ZERO + NRV = 0 + END IF !** NTGK.GT.0 **! + IF( IROWZ.LT.N*2 .AND. WANTZ ) THEN + Z( 1:IROWZ-1, ICOLZ ) = ZERO + END IF END DO !** IDPTR loop **! - IF( SPLIT ) THEN + IF( SPLIT .AND. WANTZ ) THEN * * Bring back eigenvector corresponding * to eigenvalue equal to zero. * - Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = + Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = $ Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) + $ Z( IDBEG:IDEND-NTGK+1,N+1 ) Z( IDBEG:IDEND-NTGK+1,N+1 ) = 0 @@ -725,7 +735,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IROWU = IROWU + 1 IDBEG = IEPTR + 1 SVEQ0 = .FALSE. - SPLIT = .FALSE. + SPLIT = .FALSE. END IF !** Check for split in E **! END DO !** IEPTR loop **! * @@ -744,24 +754,25 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( K.NE.NS+1-I ) THEN S( K ) = S( NS+1-I ) S( NS+1-I ) = SMIN - CALL DSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 ) + IF( WANTZ ) CALL DSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 ) END IF END DO -* +* * If RANGE=I, check for singular values/vectors to be discarded. * IF( INDSV ) THEN K = IU - IL + 1 IF( K.LT.NS ) THEN S( K+1:NS ) = ZERO - Z( 1:N*2,K+1:NS ) = ZERO + IF( WANTZ ) Z( 1:N*2,K+1:NS ) = ZERO NS = K END IF - END IF + END IF * * Reorder Z: U = Z( 1:N,1:NS ), V = Z( N+1:N*2,1:NS ). * If B is a lower diagonal, swap U and V. * + IF( WANTZ ) THEN DO I = 1, NS CALL DCOPY( N*2, Z( 1,I ), 1, WORK, 1 ) IF( LOWER ) THEN @@ -772,6 +783,7 @@ SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, CALL DCOPY( N, WORK( 1 ), 2, Z( N+1,I ), 1 ) END IF END DO + END IF * RETURN * diff --git a/lapack-netlib/SRC/ddisna.f b/lapack-netlib/SRC/ddisna.f index 60952f6e2b..61345c6e7a 100644 --- a/lapack-netlib/SRC/ddisna.f +++ b/lapack-netlib/SRC/ddisna.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DDISNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DDISNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER INFO, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), SEP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/dgbbrd.f b/lapack-netlib/SRC/dgbbrd.f index 3d11411627..350a982fb5 100644 --- a/lapack-netlib/SRC/dgbbrd.f +++ b/lapack-netlib/SRC/dgbbrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, * LDQ, PT, LDPT, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC @@ -29,7 +29,7 @@ * DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), * $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -174,12 +174,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -187,10 +187,10 @@ SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER VECT diff --git a/lapack-netlib/SRC/dgbcon.f b/lapack-netlib/SRC/dgbcon.f index bf6933faf5..26f14fd64f 100644 --- a/lapack-netlib/SRC/dgbcon.f +++ b/lapack-netlib/SRC/dgbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, KL, KU, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -146,10 +146,10 @@ SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dgbequ.f b/lapack-netlib/SRC/dgbequ.f index cc94fdb5be..486c88de52 100644 --- a/lapack-netlib/SRC/dgbequ.f +++ b/lapack-netlib/SRC/dgbequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -153,10 +153,10 @@ SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/dgbequb.f b/lapack-netlib/SRC/dgbequb.f index 6be60278df..f7543aa0cb 100644 --- a/lapack-netlib/SRC/dgbequb.f +++ b/lapack-netlib/SRC/dgbequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,9 +48,9 @@ *> number of A but works well in practice. *> *> This routine differs from DGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -160,10 +160,10 @@ SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/dgbrfs.f b/lapack-netlib/SRC/dgbrfs.f index 39d91981bc..179ddfe572 100644 --- a/lapack-netlib/SRC/dgbrfs.f +++ b/lapack-netlib/SRC/dgbrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -205,10 +205,10 @@ SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgbrfsx.f b/lapack-netlib/SRC/dgbrfsx.f index c96c623388..fb52d643ff 100644 --- a/lapack-netlib/SRC/dgbrfsx.f +++ b/lapack-netlib/SRC/dgbrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -424,10 +424,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -440,7 +440,7 @@ SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -502,11 +502,10 @@ SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL DLAMCH, DLANGB, DLA_GBRCOND DOUBLE PRECISION DLAMCH, DLANGB, DLA_GBRCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. @@ -646,7 +645,7 @@ SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, * * Perform refinement on each right-hand side * - IF (REF_TYPE .NE. 0) THEN + IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN PREC_TYPE = ILAPREC( 'E' ) diff --git a/lapack-netlib/SRC/dgbsv.f b/lapack-netlib/SRC/dgbsv.f index 93769d3872..b14fcaa5ac 100644 --- a/lapack-netlib/SRC/dgbsv.f +++ b/lapack-netlib/SRC/dgbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dgbsvx.f b/lapack-netlib/SRC/dgbsvx.f index f6911b2678..da4bf91036 100644 --- a/lapack-netlib/SRC/dgbsvx.f +++ b/lapack-netlib/SRC/dgbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -355,10 +355,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -369,7 +369,7 @@ SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dgbsvxx.f b/lapack-netlib/SRC/dgbsvxx.f index 3f6c3b68ee..819d20c6d8 100644 --- a/lapack-netlib/SRC/dgbsvxx.f +++ b/lapack-netlib/SRC/dgbsvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RCOND, RPVGRW, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -544,10 +544,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -560,7 +560,7 @@ SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dgbtf2.f b/lapack-netlib/SRC/dgbtf2.f index dc1fd99456..eae7d27941 100644 --- a/lapack-netlib/SRC/dgbtf2.f +++ b/lapack-netlib/SRC/dgbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/dgbtrf.f b/lapack-netlib/SRC/dgbtrf.f index 653f8e376e..86fad80e3f 100644 --- a/lapack-netlib/SRC/dgbtrf.f +++ b/lapack-netlib/SRC/dgbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/dgbtrs.f b/lapack-netlib/SRC/dgbtrs.f index f34ae750ae..0837349613 100644 --- a/lapack-netlib/SRC/dgbtrs.f +++ b/lapack-netlib/SRC/dgbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -138,10 +138,10 @@ SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgebak.f b/lapack-netlib/SRC/dgebak.f index 276a298182..45a86ee573 100644 --- a/lapack-netlib/SRC/dgebak.f +++ b/lapack-netlib/SRC/dgebak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -130,10 +130,10 @@ SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/dgebal.f b/lapack-netlib/SRC/dgebal.f index 591319ddda..93efd28923 100644 --- a/lapack-netlib/SRC/dgebal.f +++ b/lapack-netlib/SRC/dgebal.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/dgebd2.f b/lapack-netlib/SRC/dgebd2.f index 4b4dcc9641..bb4035dbb1 100644 --- a/lapack-netlib/SRC/dgebd2.f +++ b/lapack-netlib/SRC/dgebd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgebrd.f b/lapack-netlib/SRC/dgebrd.f index 6cb61f002f..885ad9bb41 100644 --- a/lapack-netlib/SRC/dgebrd.f +++ b/lapack-netlib/SRC/dgebrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -205,10 +205,10 @@ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgecon.f b/lapack-netlib/SRC/dgecon.f index df9d8e1c40..be20bbcd2a 100644 --- a/lapack-netlib/SRC/dgecon.f +++ b/lapack-netlib/SRC/dgecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -124,10 +124,10 @@ SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dgeequ.f b/lapack-netlib/SRC/dgeequ.f index a93af8f8db..2d9475cc70 100644 --- a/lapack-netlib/SRC/dgeequ.f +++ b/lapack-netlib/SRC/dgeequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -139,10 +139,10 @@ SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgeequb.f b/lapack-netlib/SRC/dgeequb.f index c9dd481ccc..0404274d37 100644 --- a/lapack-netlib/SRC/dgeequb.f +++ b/lapack-netlib/SRC/dgeequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,9 +48,9 @@ *> number of A but works well in practice. *> *> This routine differs from DGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -146,10 +146,10 @@ SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgees.f b/lapack-netlib/SRC/dgees.f index cb5794b661..c2723f619f 100644 --- a/lapack-netlib/SRC/dgees.f +++ b/lapack-netlib/SRC/dgees.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, * VS, LDVS, WORK, LWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -34,7 +34,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -203,12 +203,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEeigen * @@ -216,10 +216,10 @@ SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT diff --git a/lapack-netlib/SRC/dgeesx.f b/lapack-netlib/SRC/dgeesx.f index 2a3e963fdc..26042a5f91 100644 --- a/lapack-netlib/SRC/dgeesx.f +++ b/lapack-netlib/SRC/dgeesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, * WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, * IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SENSE, SORT * INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM @@ -37,7 +37,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -90,7 +90,7 @@ *> *> \param[in] SELECT *> \verbatim -*> SELECT is procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments +*> SELECT is a LOGICAL FUNCTION of two DOUBLE PRECISION arguments *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to sort *> to the top left of the Schur form. @@ -267,12 +267,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleGEeigen * @@ -281,10 +281,10 @@ SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT diff --git a/lapack-netlib/SRC/dgeev.f b/lapack-netlib/SRC/dgeev.f index 328eaa39c3..2dc1588ab2 100644 --- a/lapack-netlib/SRC/dgeev.f +++ b/lapack-netlib/SRC/dgeev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, * LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDVL, LDVR, LWORK, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,23 +176,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date September 2012 +* @precisions fortran d -> s * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -213,7 +216,7 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, - $ MAXWRK, MINWRK, NOUT + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. @@ -223,7 +226,7 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, * .. * .. External Subroutines .. EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, - $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC3, $ XERBLA * .. * .. External Functions .. @@ -279,24 +282,34 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) ELSE IF( WANTVR ) THEN MINWRK = 4*N MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) - ELSE + ELSE MINWRK = 3*N CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) END IF MAXWRK = MAX( MAXWRK, MINWRK ) @@ -426,10 +439,10 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (Workspace: need 4*N) +* (Workspace: need 4*N, prefer N + N + 2*N*NB) * - CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), IERR ) + CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * IF( WANTVL ) THEN diff --git a/lapack-netlib/SRC/dgeevx.f b/lapack-netlib/SRC/dgeevx.f index 81f30f9367..edf6a4366e 100644 --- a/lapack-netlib/SRC/dgeevx.f +++ b/lapack-netlib/SRC/dgeevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, * VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, * RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N @@ -33,7 +33,7 @@ * $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -289,12 +289,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date September 2012 +* @precisions fortran d -> s * *> \ingroup doubleGEeigen * @@ -302,11 +304,12 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -330,8 +333,8 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, $ WNTSNN, WNTSNV CHARACTER JOB, SIDE - INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK, - $ MINWRK, NOUT + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. @@ -341,7 +344,7 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, * .. * .. External Subroutines .. EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, - $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC3, $ DTRSNA, XERBLA * .. * .. External Functions .. @@ -366,8 +369,8 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, WNTSNE = LSAME( SENSE, 'E' ) WNTSNV = LSAME( SENSE, 'V' ) WNTSNB = LSAME( SENSE, 'B' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, - $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) + $ .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN INFO = -1 ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN @@ -406,9 +409,19 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) * IF( WANTVL ) THEN + CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN + CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, $ WORK, -1, INFO ) ELSE @@ -420,7 +433,7 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ LDVR, WORK, -1, INFO ) END IF END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) * IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = 2*N @@ -572,18 +585,18 @@ SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * -* If INFO > 0 from DHSEQR, then quit +* If INFO .NE. 0 from DHSEQR, then quit * - IF( INFO.GT.0 ) + IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (Workspace: need 3*N) +* (Workspace: need 3*N, prefer N + 2*N*NB) * - CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), IERR ) + CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * * Compute condition numbers if desired diff --git a/lapack-netlib/SRC/dgehd2.f b/lapack-netlib/SRC/dgehd2.f index 089fad1e0d..4521b66e1a 100644 --- a/lapack-netlib/SRC/dgehd2.f +++ b/lapack-netlib/SRC/dgehd2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEHD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff --git a/lapack-netlib/SRC/dgehrd.f b/lapack-netlib/SRC/dgehrd.f index 181990dbb0..23fd872507 100644 --- a/lapack-netlib/SRC/dgehrd.f +++ b/lapack-netlib/SRC/dgehrd.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -186,7 +186,7 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, + PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. @@ -232,7 +232,7 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT END IF -* +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHRD', -INFO ) RETURN @@ -316,7 +316,7 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL DGEMM( 'No transpose', 'Transpose', + CALL DGEMM( 'No transpose', 'Transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) diff --git a/lapack-netlib/SRC/dgejsv.f b/lapack-netlib/SRC/dgejsv.f index 4b26a1d683..81c0a21ae4 100644 --- a/lapack-netlib/SRC/dgejsv.f +++ b/lapack-netlib/SRC/dgejsv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEJSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEJSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * M, N, A, LDA, SVA, U, LDU, V, LDV, * WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * IMPLICIT NONE * INTEGER INFO, LDA, LDU, LDV, LWORK, M, N @@ -32,7 +32,7 @@ * INTEGER IWORK( * ) * CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV * .. -* +* * *> \par Purpose: * ============= @@ -52,7 +52,8 @@ *> are computed and stored in the arrays U and V, respectively. The diagonal *> of [SIGMA] is computed and stored in the array SVA. *> DGEJSV can sometimes compute tiny singular values and their singular vectors much -*> more accurately than other SVD routines, see below under Further Details.*> \endverbatim +*> more accurately than other SVD routines, see below under Further Details. +*> \endverbatim * * Arguments: * ========== @@ -86,7 +87,7 @@ *> rows, then using this condition number gives too pessimistic *> error bound. *> = 'A': Small singular values are the noise and the matrix is treated -*> as numerically rank defficient. The error in the computed +*> as numerically rank deficient. The error in the computed *> singular values is bounded by f(m,n)*epsilon*||A||. *> The computed SVD A = U * S * V^t restores A up to *> f(m,n)*epsilon*||A||. @@ -236,7 +237,7 @@ *> copied back to the V array. This 'W' option is just *> a reminder to the caller that in this case U is *> reserved as workspace of length N*N. -*> If JOBU = 'N' U is not referenced. +*> If JOBU = 'N' U is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDU @@ -258,7 +259,7 @@ *> copied back to the U array. This 'W' option is just *> a reminder to the caller that in this case V is *> reserved as workspace of length N*N. -*> If JOBV = 'N' V is not referenced. +*> If JOBV = 'N' V is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDV @@ -271,7 +272,7 @@ *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension at least LWORK. -*> On exit, if N.GT.0 .AND. M.GT.0 (else not referenced), +*> On exit, if N.GT.0 .AND. M.GT.0 (else not referenced), *> WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such *> that SCALE*SVA(1:N) are the computed singular values *> of A. (See the description of SVA().) @@ -318,24 +319,24 @@ *> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal *> block size for DGEQP3 and DGEQRF. -*> In general, optimal LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7). +*> In general, optimal LWORK is computed as +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7). *> -> .. an estimate of the scaled condition number of A is *> required (JOBA='E', 'G'). In this case, LWORK is the maximum *> of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4*N,7). -*> ->> For optimal performance (blocked code) the optimal value +*> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB, N*N+4*N, 7). *> In general, the optimal length LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), *> N+N*N+LWORK(DPOCON),7). *> *> If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), *> -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7). *> -> For optimal performance, LWORK >= max(2*M+N,3*N+(N+1)*NB,7), -*> where NB is the optimal block size for DGEQP3, DGEQRF, DGELQ, +*> where NB is the optimal block size for DGEQP3, DGEQRF, DGELQF, *> DORMLQ. In general, the optimal length LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON), -*> N+LWORK(DGELQ), 2*N+LWORK(DGEQRF), N+LWORK(DORMLQ)). +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON), +*> N+LWORK(DGELQF), 2*N+LWORK(DGEQRF), N+LWORK(DORMLQ)). *> *> If SIGMA and the left singular vectors are needed *> -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7). @@ -345,14 +346,14 @@ *> where NB is the optimal block size for DGEQP3, DGEQRF, DORMQR. *> In general, the optimal length LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DPOCON), -*> 2*N+LWORK(DGEQRF), N+LWORK(DORMQR)). -*> Here LWORK(DORMQR) equals N*NB (for JOBU.EQ.'U') or +*> 2*N+LWORK(DGEQRF), N+LWORK(DORMQR)). +*> Here LWORK(DORMQR) equals N*NB (for JOBU.EQ.'U') or *> M*NB (for JOBU.EQ.'F'). -*> -*> If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and -*> -> if JOBV.EQ.'V' -*> the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N). -*> -> if JOBV.EQ.'J' the minimal requirement is +*> +*> If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and +*> -> if JOBV.EQ.'V' +*> the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N). +*> -> if JOBV.EQ.'J' the minimal requirement is *> LWORK >= max(2*M+N, 4*N+N*N,2*N+N*N+6). *> -> For optimal performance, LWORK should be additionally *> larger than N+M*NB, where NB is the optimal block size @@ -377,7 +378,7 @@ *> \verbatim *> INFO is INTEGER *> < 0 : if INFO = -i, then the i-th argument had an illegal value. -*> = 0 : successfull exit; +*> = 0 : successful exit; *> > 0 : DGEJSV did not converge in the maximal allowed number *> of sweeps. The computed values may be inaccurate. *> \endverbatim @@ -385,12 +386,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleGEsing * @@ -427,8 +428,8 @@ *> The rank revealing QR factorization (in this code: DGEQP3) should be *> implemented as in [3]. We have a new version of DGEQP3 under development *> that is more robust than the current one in LAPACK, with a cleaner cut in -*> rank defficient cases. It will be available in the SIGMA library [4]. -*> If M is much larger than N, it is obvious that the inital QRF with +*> rank deficient cases. It will be available in the SIGMA library [4]. +*> If M is much larger than N, it is obvious that the initial QRF with *> column pivoting can be preprocessed by the QRF without pivoting. That *> well known trick is not used in DGEJSV because in some cases heavy row *> weighting can be treated with complete pivoting. The overhead in cases @@ -475,10 +476,10 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ M, N, A, LDA, SVA, U, LDU, V, LDV, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. IMPLICIT NONE @@ -561,7 +562,7 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN INFO = - 13 ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN - INFO = - 14 + INFO = - 15 ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. & (LWORK .LT. MAX(7,4*N+1,2*M+N))) .OR. & (.NOT.(LSVEC .OR. RSVEC) .AND. ERREST .AND. @@ -570,7 +571,7 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, & .OR. & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX(7,2*M+N,4*N+1))) & .OR. - & (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. + & (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. & (LWORK.LT.MAX(2*M+N,6*N+2*N*N))) & .OR. (LSVEC .AND. RSVEC .AND. JRACC .AND. & LWORK.LT.MAX(2*M+N,4*N+N*N,2*N+N*N+6))) @@ -589,7 +590,11 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * * Quick return for void matrix (Y3K safe) * #:) - IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) THEN + IWORK(1:3) = 0 + WORK(1:7) = 0 + RETURN + ENDIF * * Determine whether the matrix U should be M x N or M x M * @@ -715,6 +720,7 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, IWORK(1) = 0 IWORK(2) = 0 END IF + IWORK(3) = 0 IF ( ERREST ) WORK(3) = ONE IF ( LSVEC .AND. RSVEC ) THEN WORK(4) = ONE @@ -961,7 +967,7 @@ SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, ELSE IF ( L2RANK ) THEN * .. similarly as above, only slightly more gentle (less agressive). * Sudden drop on the diagonal of R1 is used as the criterion for -* close-to-rank-defficient. +* close-to-rank-deficient. TEMP1 = DSQRT(SFMIN) DO 3401 p = 2, N IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR. diff --git a/lapack-netlib/SRC/dgelq.f b/lapack-netlib/SRC/dgelq.f new file mode 100644 index 0000000000..ece6450791 --- /dev/null +++ b/lapack-netlib/SRC/dgelq.f @@ -0,0 +1,306 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DGELQ computes a LQ factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-min(M,N) lower trapezoidal matrix L +*> (L is lower triangular if M <= N); +*> the elements above the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any LQ factorization algorithm they wish. The triangular +*> (trapezoidal) L has to be stored in the lower part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLASWLQ or DGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGELQ will use either +*> DLASWLQ (if the matrix is short-and-wide) or DGELQT to compute +*> the LQ factorization. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGELQT, DLASWLQ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'DGELQ ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'DGELQ ', ' ', M, N, 2, -1 ) + ELSE + MB = 1 + NB = N + END IF + IF( MB.GT.MIN( M, N ) .OR. MB.LT.1 ) MB = 1 + IF( NB.GT.N .OR. NB.LE.M ) NB = N + MINTSZ = M + 5 + IF ( NB.GT.M .AND. N.GT.M ) THEN + IF( MOD( N - M, NB - M ).EQ.0 ) THEN + NBLCKS = ( N - M ) / ( NB - M ) + ELSE + NBLCKS = ( N - M ) / ( NB - M ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) .OR. LWORK.LT.MB*M ) + $ .AND. ( LWORK.GE.M ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + MB = 1 + NB = N + END IF + IF( LWORK.LT.MB*M ) THEN + LMINWS = .TRUE. + MB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, M*MB ) ) .AND .( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = MB*M*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, MB*M ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF( ( N.LE.M ) .OR. ( NB.LE.M ) .OR. ( NB.GE.N ) ) THEN + CALL DGELQT( M, N, MB, A, LDA, T( 6 ), MB, WORK, INFO ) + ELSE + CALL DLASWLQ( M, N, MB, NB, A, LDA, T( 6 ), MB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, MB*M ) +* + RETURN +* +* End of DGELQ +* + END diff --git a/lapack-netlib/SRC/dgelq2.f b/lapack-netlib/SRC/dgelq2.f index 0d64ba5210..04aa57fc19 100644 --- a/lapack-netlib/SRC/dgelq2.f +++ b/lapack-netlib/SRC/dgelq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgelqf.f b/lapack-netlib/SRC/dgelqf.f index d27b04ab1d..834c47168f 100644 --- a/lapack-netlib/SRC/dgelqf.f +++ b/lapack-netlib/SRC/dgelqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgelqt.f b/lapack-netlib/SRC/dgelqt.f new file mode 100644 index 0000000000..b11e9d6eee --- /dev/null +++ b/lapack-netlib/SRC/dgelqt.f @@ -0,0 +1,210 @@ +*> \brief \b DGELQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is +*> lower triangular if M <= N); the elements above the diagonal +*> are the rows of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K +* .. +* .. External Subroutines .. + EXTERNAL DGEQRT2, DGEQRT3, DLARFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, MB + IB = MIN( K-I+1, MB ) +* +* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) +* + CALL DGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO ) + IF( I+IB.LE.M ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the right +* + CALL DLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, WORK , M-I-IB+1 ) + END IF + END DO + RETURN +* +* End of DGELQT +* + END diff --git a/lapack-netlib/SRC/dgelqt3.f b/lapack-netlib/SRC/dgelqt3.f new file mode 100644 index 0000000000..b0bb242a61 --- /dev/null +++ b/lapack-netlib/SRC/dgelqt3.f @@ -0,0 +1,259 @@ +*> \brief \b DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT3 recursively computes a LQ factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M =< N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> below the diagonal contain the N-by-N lower triangular matrix L; the +*> elements above the diagonal are the rows of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE DGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+00 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, M1, M2, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( N .LT. M ) THEN + INFO = -2 + ELSE IF( LDA .LT. MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LDT .LT. MAX( 1, M ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELQT3', -INFO ) + RETURN + END IF +* + IF( M.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL DLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T ) +* + ELSE +* +* Otherwise, split A into blocks... +* + M1 = M/2 + M2 = M-M1 + I1 = MIN( M1+1, M ) + J1 = MIN( M+1, N ) +* +* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL DGELQT3( M1, N, A, LDA, T, LDT, IINFO ) +* +* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)] +* + DO I=1,M2 + DO J=1,M1 + T( I+M1, J ) = A( I+M1, J ) + END DO + END DO + CALL DTRMM( 'R', 'U', 'T', 'U', M2, M1, ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + CALL DGEMM( 'N', 'T', M2, M1, N-M1, ONE, A( I1, I1 ), LDA, + & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT) +* + CALL DTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE, + & T, LDT, T( I1, 1 ), LDT ) +* + CALL DGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT, + & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA ) +* + CALL DTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + DO I=1,M2 + DO J=1,M1 + A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J ) + T( I+M1, J )=0 + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL DGELQT3( M2, N-M1, A( I1, I1 ), LDA, + & T( I1, I1 ), LDT, IINFO ) +* +* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,M2 + DO J=1,M1 + T( J, I+M1 ) = (A( J, I+M1 )) + END DO + END DO +* + CALL DTRMM( 'R', 'U', 'T', 'U', M1, M2, ONE, + & A( I1, I1 ), LDA, T( 1, I1 ), LDT ) +* + CALL DGEMM( 'N', 'T', M1, M2, N-M, ONE, A( 1, J1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT ) +* + CALL DTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT, + & T( 1, I1 ), LDT ) +* + CALL DTRMM( 'R', 'U', 'N', 'N', M1, M2, ONE, + & T( I1, I1 ), LDT, T( 1, I1 ), LDT ) +* +* +* +* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] +* [ A(1:N1,J1:N) L2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of DGELQT3 +* + END diff --git a/lapack-netlib/SRC/dgels.f b/lapack-netlib/SRC/dgels.f index 3d3cb88bae..33e6d51bff 100644 --- a/lapack-netlib/SRC/dgels.f +++ b/lapack-netlib/SRC/dgels.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,7 +49,7 @@ *> an underdetermined system A * X = B. *> *> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of -*> an undetermined system A**T * X = B. +*> an underdetermined system A**T * X = B. *> *> 4. If TRANS = 'T' and m < n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * @@ -183,10 +183,10 @@ SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -379,7 +379,7 @@ SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * ELSE * -* Overdetermined system of equations A**T * X = B +* Underdetermined system of equations A**T * X = B * * B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) * diff --git a/lapack-netlib/SRC/dgelsd.f b/lapack-netlib/SRC/dgelsd.f index 7629071f42..d24b2559a4 100644 --- a/lapack-netlib/SRC/dgelsd.f +++ b/lapack-netlib/SRC/dgelsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,7 +52,7 @@ *> Householder transformations, reducing the original problem *> into a "bidiagonal least squares problem" (BLS) *> (2) Solve the BLS using a divide and conquer approach. -*> (3) Apply back all the Householder tranformations to solve +*> (3) Apply back all the Householder transformations to solve *> the original least squares problem. *> *> The effective rank of A is determined by treating as zero those @@ -189,12 +189,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * @@ -209,10 +209,10 @@ SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/dgelss.f b/lapack-netlib/SRC/dgelss.f index 843f319c9f..674a7ba784 100644 --- a/lapack-netlib/SRC/dgelss.f +++ b/lapack-netlib/SRC/dgelss.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELSS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * @@ -172,10 +172,10 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -285,7 +285,7 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_DORGBR=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) @@ -314,7 +314,7 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ DUM(1), DUM(1), -1, INFO ) LWORK_DGEBRD=DUM(1) * Compute space needed for DORMBR - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_DORMBR=DUM(1) * Compute space needed for DORGBR @@ -325,7 +325,7 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_DORMLQ=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = M + LWORK_DGELQF MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) @@ -346,7 +346,7 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ DUM(1), DUM(1), -1, INFO ) LWORK_DGEBRD=DUM(1) * Compute space needed for DORMBR - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_DORMBR=DUM(1) * Compute space needed for DORGBR diff --git a/lapack-netlib/SRC/dgelsy.f b/lapack-netlib/SRC/dgelsy.f index 87bc23cb2d..1ca238d1f5 100644 --- a/lapack-netlib/SRC/dgelsy.f +++ b/lapack-netlib/SRC/dgelsy.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGELSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGELSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -29,7 +29,7 @@ * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,19 +184,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * *> \par Contributors: * ================== *> -*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n *> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> @@ -204,10 +204,10 @@ SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/dgemlq.f b/lapack-netlib/SRC/dgemlq.f new file mode 100644 index 0000000000..bb6b2868f8 --- /dev/null +++ b/lapack-netlib/SRC/dgemlq.f @@ -0,0 +1,284 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMLQ overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by short wide LQ +*> factorization (DGELQ) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> Part of the data structure to represent Q as returned by DGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by DGELQ. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLASWLQ or DGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGELQ will use either +*> DLASWLQ (if the matrix is wide-and-short) or DGELQT to compute +*> the LQ factorization. +*> This version of DGEMLQ will use either DLAMSWLQ or DGEMLQT to +*> multiply matrix Q by another matrix. +*> Further Details in DLAMSWLQ or DGEMLQT. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAMSWLQ, DGEMLQT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * MB + MN = M + ELSE + LW = M * MB + MN = N + END IF +* + IF( ( NB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, NB - K ) .EQ. 0 ) THEN + NBLCKS = ( MN - K ) / ( NB - K ) + ELSE + NBLCKS = ( MN - K ) / ( NB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( NB.LE.K ) .OR. ( NB.GE.MAX( M, N, K ) ) ) THEN + CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T( 6 ), MB, C, LDC, WORK, INFO ) + ELSE + CALL DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ MB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of DGEMLQ +* + END diff --git a/lapack-netlib/SRC/dgemlqt.f b/lapack-netlib/SRC/dgemlqt.f new file mode 100644 index 0000000000..41a517a2df --- /dev/null +++ b/lapack-netlib/SRC/dgemlqt.f @@ -0,0 +1,289 @@ +*> \brief \b DGEMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQRT overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q C C Q +*> TRANS = 'T': Q**T C C Q**T +*> +*> where Q is a real orthogonal matrix defined as the product of K +*> elementary reflectors: +*> +*> Q = H(1) H(2) . . . H(K) = I - V T V**T +*> +*> generated using the compact WY representation as returned by DGELQT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DGELQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQT in the first K rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DGELQT, stored as a MB-by-M matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of +*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0) THEN + INFO = -5 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL DLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of DGEMLQT +* + END diff --git a/lapack-netlib/SRC/dgemqr.f b/lapack-netlib/SRC/dgemqr.f new file mode 100644 index 0000000000..8509b13d97 --- /dev/null +++ b/lapack-netlib/SRC/dgemqr.f @@ -0,0 +1,285 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (DGEQR) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> Part of the data structure to represent Q as returned by DGEQR. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by DGEQR. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLATSQR or DGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGEQR will use either +*> DLATSQR (if the matrix is tall-and-skinny) or DGEQRT to compute +*> the QR factorization. +*> This version of DGEMQR will use either DLAMTSQR or DGEMQRT to +*> multiply matrix Q by another matrix. +*> Further Details in DLATMSQR or DGEMQRT. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMQRT, DLAMTSQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * NB + MN = M + ELSE + LW = MB * NB + MN = N + END IF +* + IF( ( MB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, MB - K ).EQ.0 ) THEN + NBLCKS = ( MN - K ) / ( MB - K ) + ELSE + NBLCKS = ( MN - K ) / ( MB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, MN ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( MB.LE.K ) .OR. ( MB.GE.MAX( M, N, K ) ) ) THEN + CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, INFO ) + ELSE + CALL DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of DGEMQR +* + END diff --git a/lapack-netlib/SRC/dgemqrt.f b/lapack-netlib/SRC/dgemqrt.f index ef79221c30..12cf929817 100644 --- a/lapack-netlib/SRC/dgemqrt.f +++ b/lapack-netlib/SRC/dgemqrt.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, +* SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDC, M, N, NB, LDT @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -46,7 +46,7 @@ *> *> Q = H(1) H(2) . . . H(K) = I - V T V**T *> -*> generated using the compact WY representation as returned by DGEQRT. +*> generated using the compact WY representation as returned by DGEQRT. *> *> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. *> \endverbatim @@ -155,23 +155,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== - SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, + SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -207,7 +207,7 @@ SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF( LEFT ) THEN LDWORK = MAX( 1, N ) Q = M @@ -248,17 +248,17 @@ SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL DLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL DLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * @@ -266,9 +266,9 @@ SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL DLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * @@ -276,9 +276,9 @@ SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL DLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL DLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * diff --git a/lapack-netlib/SRC/dgeql2.f b/lapack-netlib/SRC/dgeql2.f index 25651cdb5b..539ef29f26 100644 --- a/lapack-netlib/SRC/dgeql2.f +++ b/lapack-netlib/SRC/dgeql2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgeqlf.f b/lapack-netlib/SRC/dgeqlf.f index 1efeba12e2..e8c3f8e53e 100644 --- a/lapack-netlib/SRC/dgeqlf.f +++ b/lapack-netlib/SRC/dgeqlf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQLF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQLF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgeqp3.f b/lapack-netlib/SRC/dgeqp3.f index 6d43542496..2b9faf663d 100644 --- a/lapack-netlib/SRC/dgeqp3.f +++ b/lapack-netlib/SRC/dgeqp3.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -27,7 +27,7 @@ * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -151,10 +151,10 @@ * ===================================================================== SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgeqr.f b/lapack-netlib/SRC/dgeqr.f new file mode 100644 index 0000000000..d0a1a18f99 --- /dev/null +++ b/lapack-netlib/SRC/dgeqr.f @@ -0,0 +1,307 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DGEQR computes a QR factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R +*> (R is upper triangular if M >= N); +*> the elements below the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any QR factorization algorithm they wish. The triangular +*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> DLATSQR or DGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, DGEQR will use either +*> DLATSQR (if the matrix is tall-and-skinny) or DGEQRT to compute +*> the QR factorization. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLATSQR, DGEQRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'DGEQR ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'DGEQR ', ' ', M, N, 2, -1 ) + ELSE + MB = M + NB = 1 + END IF + IF( MB.GT.M .OR. MB.LE.N ) MB = M + IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1 + MINTSZ = N + 5 + IF( MB.GT.N .AND. M.GT.N ) THEN + IF( MOD( M - N, MB - N ).EQ.0 ) THEN + NBLCKS = ( M - N ) / ( MB - N ) + ELSE + NBLCKS = ( M - N ) / ( MB - N ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N ) + $ .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + NB = 1 + MB = M + END IF + IF( LWORK.LT.NB*N ) THEN + LMINWS = .TRUE. + NB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = NB*N*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, NB*N ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN + CALL DGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO ) + ELSE + CALL DLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, NB*N ) +* + RETURN +* +* End of DGEQR +* + END diff --git a/lapack-netlib/SRC/dgeqr2.f b/lapack-netlib/SRC/dgeqr2.f index 8e63db8866..c1e91e9bde 100644 --- a/lapack-netlib/SRC/dgeqr2.f +++ b/lapack-netlib/SRC/dgeqr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgeqr2p.f b/lapack-netlib/SRC/dgeqr2p.f index 46de429284..921f799215 100644 --- a/lapack-netlib/SRC/dgeqr2p.f +++ b/lapack-netlib/SRC/dgeqr2p.f @@ -2,38 +2,38 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQR2P + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DGEQR2 computes a QR factorization of a real m by n matrix A: +*> DGEQR2P computes a QR factorization of a real m by n matrix A: *> A = Q * R. The diagonal entries of R are nonnegative. *> \endverbatim * @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -124,10 +124,10 @@ * ===================================================================== SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgeqrf.f b/lapack-netlib/SRC/dgeqrf.f index 2990257581..83d7d8dd71 100644 --- a/lapack-netlib/SRC/dgeqrf.f +++ b/lapack-netlib/SRC/dgeqrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgeqrfp.f b/lapack-netlib/SRC/dgeqrfp.f index b82bce1b8c..d182f98c9d 100644 --- a/lapack-netlib/SRC/dgeqrfp.f +++ b/lapack-netlib/SRC/dgeqrfp.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRFP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRFP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -139,10 +139,10 @@ * ===================================================================== SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgeqrt.f b/lapack-netlib/SRC/dgeqrt.f index 0ba5c7fcf8..6856bac07d 100644 --- a/lapack-netlib/SRC/dgeqrt.f +++ b/lapack-netlib/SRC/dgeqrt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> DGEQRT computes a blocked QR factorization of a real M-by-N matrix A -*> using the compact WY representation of Q. +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -130,9 +130,9 @@ *> in the matrix A. The 1's along the diagonal of V are not stored in A. *> *> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = (T1 T2 ... TB). @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -194,7 +194,7 @@ SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * DO I = 1, K, NB IB = MIN( K-I+1, NB ) -* +* * Compute the QR factorization of the current block A(I:M,I:I+IB-1) * IF( USE_RECURSIVE_QR ) THEN @@ -207,12 +207,12 @@ SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * Update by applying H**T to A(I:M,I+IB:N) from the left * CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I, I ), LDA, T( 1, I ), LDT, $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN -* +* * End of DGEQRT * END diff --git a/lapack-netlib/SRC/dgeqrt2.f b/lapack-netlib/SRC/dgeqrt2.f index 399d563e22..138dd4d9c1 100644 --- a/lapack-netlib/SRC/dgeqrt2.f +++ b/lapack-netlib/SRC/dgeqrt2.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DGEQRT2 computes a QR factorization of a real M-by-N matrix A, -*> using the compact WY representation of Q. +*> DGEQRT2 computes a QR factorization of a real M-by-N matrix A, +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N @@ -170,7 +170,7 @@ SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) CALL XERBLA( 'DGEQRT2', -INFO ) RETURN END IF -* +* K = MIN( M, N ) * DO I = 1, K @@ -188,13 +188,13 @@ SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)] * - CALL DGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, + CALL DGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) * * A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H * ALPHA = -(T( I, 1 )) - CALL DGER( M-I+1, N-I, ALPHA, A( I, I ), 1, + CALL DGER( M-I+1, N-I, ALPHA, A( I, I ), 1, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF @@ -207,7 +207,7 @@ SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) * T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I) * ALPHA = -T( I, 1 ) - CALL DGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, + CALL DGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * @@ -220,7 +220,7 @@ SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO - + * * End of DGEQRT2 * diff --git a/lapack-netlib/SRC/dgeqrt3.f b/lapack-netlib/SRC/dgeqrt3.f index c5f57a29f4..efec07850a 100644 --- a/lapack-netlib/SRC/dgeqrt3.f +++ b/lapack-netlib/SRC/dgeqrt3.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQRT3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DGEQRT3 recursively computes a QR factorization of a real M-by-N -*> matrix A, using the compact WY representation of Q. +*> DGEQRT3 recursively computes a QR factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. *> -*> Based on the algorithm of Elmroth and Gustavson, +*> Based on the algorithm of Elmroth and Gustavson, *> IBM J. Res. Develop. Vol 44 No. 4 July 2000. *> \endverbatim * @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleGEcomputational * @@ -132,10 +132,10 @@ * ===================================================================== RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT @@ -177,8 +177,8 @@ RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute Householder transform when N=1 * - CALL DLARFG( M, A, A( MIN( 2, M ), 1 ), 1, T ) -* + CALL DLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) +* ELSE * * Otherwise, split A into blocks... @@ -199,7 +199,7 @@ RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) T( I, J+N1 ) = A( I, J+N1 ) END DO END DO - CALL DTRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, + CALL DTRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * CALL DGEMM( 'T', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, @@ -208,7 +208,7 @@ RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL DTRMM( 'L', 'U', 'T', 'N', N1, N2, ONE, & T, LDT, T( 1, J1 ), LDT ) * - CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, + CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL DTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, @@ -222,7 +222,7 @@ RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H * - CALL DGEQRT3( M-N1, N2, A( J1, J1 ), LDA, + CALL DGEQRT3( M-N1, N2, A( J1, J1 ), LDA, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 @@ -236,13 +236,13 @@ RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL DTRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) * - CALL DGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, + CALL DGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) * - CALL DTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, + CALL DTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, & T( 1, J1 ), LDT ) * - CALL DTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, + CALL DTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] diff --git a/lapack-netlib/SRC/dgerfs.f b/lapack-netlib/SRC/dgerfs.f index 9a48db9e11..a6f14e2b58 100644 --- a/lapack-netlib/SRC/dgerfs.f +++ b/lapack-netlib/SRC/dgerfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -185,10 +185,10 @@ SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgerfsx.f b/lapack-netlib/SRC/dgerfsx.f index 6f1921739c..aafca8d10d 100644 --- a/lapack-netlib/SRC/dgerfsx.f +++ b/lapack-netlib/SRC/dgerfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,7 +143,7 @@ *> R is DOUBLE PRECISION array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. +*> is not accessed. *> If R is accessed, each element of R should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -158,7 +158,7 @@ *> C is DOUBLE PRECISION array, dimension (N) *> The column scale factors for A. If EQUED = 'C' or 'B', A is *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C -*> is not accessed. +*> is not accessed. *> If C is accessed, each element of C should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -399,12 +399,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -414,10 +414,10 @@ SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, EQUED @@ -475,11 +475,10 @@ SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL DLAMCH, DLANGE, DLA_GERCOND DOUBLE PRECISION DLAMCH, DLANGE, DLA_GERCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/dgerq2.f b/lapack-netlib/SRC/dgerq2.f index 310e80c3d2..b1713c1fb7 100644 --- a/lapack-netlib/SRC/dgerq2.f +++ b/lapack-netlib/SRC/dgerq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGERQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgerqf.f b/lapack-netlib/SRC/dgerqf.f index 033913d77b..20f2668ef8 100644 --- a/lapack-netlib/SRC/dgerqf.f +++ b/lapack-netlib/SRC/dgerqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGERQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGERQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dgesc2.f b/lapack-netlib/SRC/dgesc2.f index 75c0607a22..db684bae4a 100644 --- a/lapack-netlib/SRC/dgesc2.f +++ b/lapack-netlib/SRC/dgesc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, N * DOUBLE PRECISION SCALE @@ -28,7 +28,7 @@ * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ), RHS( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, N diff --git a/lapack-netlib/SRC/dgesdd.f b/lapack-netlib/SRC/dgesdd.f index 54e2652e44..926607f983 100644 --- a/lapack-netlib/SRC/dgesdd.f +++ b/lapack-netlib/SRC/dgesdd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESDD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESDD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, -* LWORK, IWORK, INFO ) -* +* SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, +* WORK, LWORK, IWORK, INFO ) +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,8 +154,8 @@ *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; +*> The leading dimension of the array VT. LDVT >= 1; +*> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; *> if JOBZ = 'S', LDVT >= min(M,N). *> \endverbatim *> @@ -169,16 +169,18 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. -*> If JOBZ = 'N', -*> LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)). -*> If JOBZ = 'O', -*> LWORK >= 3*min(M,N) + -*> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). -*> If JOBZ = 'S' or 'A' -*> LWORK >= min(M,N)*(7+4*min(M,N)) -*> For good performance, LWORK should generally be larger. -*> If LWORK = -1 but other input arguments are legal, WORK(1) -*> returns the optimal LWORK. +*> If LWORK = -1, a workspace query is assumed. The optimal +*> size for the WORK array is calculated and stored in WORK(1), +*> and no other work except argument checking is performed. +*> +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ). +*> If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ). +*> If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn. +*> If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx. +*> These are not tight minimums in all cases; see comments inside code. +*> For good performance, LWORK should generally be larger; +*> a query is recommended. *> \endverbatim *> *> \param[out] IWORK @@ -197,12 +199,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleGEsing * @@ -213,13 +215,14 @@ *> California at Berkeley, USA *> * ===================================================================== - SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, - $ LWORK, IWORK, INFO ) + SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ @@ -243,6 +246,15 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, $ MNTHR, NWORK, WRKBL + INTEGER LWORK_DGEBRD_MN, LWORK_DGEBRD_MM, + $ LWORK_DGEBRD_NN, LWORK_DGELQF_MN, + $ LWORK_DGEQRF_MN, + $ LWORK_DORGBR_P_MM, LWORK_DORGBR_Q_NN, + $ LWORK_DORGLQ_MN, LWORK_DORGLQ_NN, + $ LWORK_DORGQR_MM, LWORK_DORGQR_MN, + $ LWORK_DORMBR_PRT_MM, LWORK_DORMBR_QLN_MM, + $ LWORK_DORMBR_PRT_MN, LWORK_DORMBR_QLN_MN, + $ LWORK_DORMBR_PRT_NN, LWORK_DORMBR_QLN_NN DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. @@ -256,9 +268,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME + EXTERNAL DLAMCH, DLANGE, LSAME * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -267,13 +278,13 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Test the input arguments * - INFO = 0 - MINMN = MIN( M, N ) - WNTQA = LSAME( JOBZ, 'A' ) - WNTQS = LSAME( JOBZ, 'S' ) + INFO = 0 + MINMN = MIN( M, N ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS - WNTQO = LSAME( JOBZ, 'O' ) - WNTQN = LSAME( JOBZ, 'N' ) + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN @@ -294,115 +305,140 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF * * Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, +* Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace allocated at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) +* following subroutine, as returned by ILAENV. * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 + BDSPAC = 0 + MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for DBDSDC * - MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) IF( WNTQN ) THEN +* dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. BDSPAC = 7*N ELSE BDSPAC = 3*N*N + 4*N END IF +* +* Compute space preferred for each routine + CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MN = INT( DUM(1) ) +* + CALL DGEBRD( N, N, DUM(1), N, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_NN = INT( DUM(1) ) +* + CALL DGEQRF( M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DGEQRF_MN = INT( DUM(1) ) +* + CALL DORGBR( 'Q', N, N, N, DUM(1), N, DUM(1), DUM(1), -1, + $ IERR ) + LWORK_DORGBR_Q_NN = INT( DUM(1) ) +* + CALL DORGQR( M, M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGQR_MM = INT( DUM(1) ) +* + CALL DORGQR( M, N, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGQR_MN = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, N, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MM = INT( DUM(1) ) +* IF( M.GE.MNTHR ) THEN IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+N ) + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + MAXWRK = MAX( WRKBL, BDSPAC + N ) MINWRK = BDSPAC + N ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 2 (M >> N, JOBZ='O') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + 2*N*N MINWRK = BDSPAC + 2*N*N + 3*N ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 3 (M >> N, JOBZ='S') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N MINWRK = BDSPAC + N*N + 3*N ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 4 (M >> N, JOBZ='A') +* + WRKBL = N + LWORK_DGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 2*N + M + MINWRK = N*N + MAX( 3*N + BDSPAC, N + M ) END IF ELSE * -* Path 5 (M at least N, but not much larger) +* Path 5 (M >= N, but not much larger) * - WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, - $ -1 ) + WRKBL = 3*N + LWORK_DGEBRD_MN IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) +* Path 5n (M >= N, jobz='N') + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQO ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 5o (M >= N, jobz='O') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + M*N - MINWRK = 3*N + MAX( M, N*N+BDSPAC ) + MINWRK = 3*N + MAX( M, N*N + BDSPAC ) ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) +* Path 5s (M >= N, jobz='S') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*N+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC+3*N ) +* Path 5a (M >= N, jobz='A') + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) END IF END IF @@ -410,106 +446,129 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Compute space needed for DBDSDC * - MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) IF( WNTQN ) THEN +* dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. BDSPAC = 7*M ELSE BDSPAC = 3*M*M + 4*M END IF +* +* Compute space preferred for each routine + CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MN = INT( DUM(1) ) +* + CALL DGEBRD( M, M, A, M, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_DGEBRD_MM = INT( DUM(1) ) +* + CALL DGELQF( M, N, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_DGELQF_MN = INT( DUM(1) ) +* + CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGLQ_NN = INT( DUM(1) ) +* + CALL DORGLQ( M, N, M, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGLQ_MN = INT( DUM(1) ) +* + CALL DORGBR( 'P', M, M, M, A, N, DUM(1), DUM(1), -1, IERR ) + LWORK_DORGBR_P_MM = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_MM = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', M, N, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_MN = INT( DUM(1) ) +* + CALL DORMBR( 'P', 'R', 'T', N, N, M, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_DORMBR_PRT_NN = INT( DUM(1) ) +* + CALL DORMBR( 'Q', 'L', 'N', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_DORMBR_QLN_MM = INT( DUM(1) ) +* IF( N.GE.MNTHR ) THEN IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+M ) + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + MAXWRK = MAX( WRKBL, BDSPAC + M ) MINWRK = BDSPAC + M ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 2t (N >> M, JOBZ='O') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + 2*M*M MINWRK = BDSPAC + 2*M*M + 3*M ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 3t (N >> M, JOBZ='S') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M MINWRK = BDSPAC + M*M + 3*M ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 4t (N >> M, JOBZ='A') +* + WRKBL = M + LWORK_DGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_NN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = M*M + MAX( 3*M + BDSPAC, M + N ) END IF ELSE * -* Path 5t (N greater than M, but not much larger) +* Path 5t (N > M, but not much larger) * - WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, - $ -1 ) + WRKBL = 3*M + LWORK_DGEBRD_MN IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5tn (N > M, jobz='N') + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQO ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 5to (N > M, jobz='O') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*N - MINWRK = 3*M + MAX( N, M*M+BDSPAC ) + MINWRK = 3*M + MAX( N, M*M + BDSPAC ) ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5ts (N > M, jobz='S') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5ta (N > M, jobz='A') + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) END IF END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * @@ -559,17 +618,18 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* Workspace: need N [tau] + N [work] +* Workspace: prefer N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Zero out below R * @@ -580,7 +640,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -588,14 +649,14 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IE + N * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need N+BDSPAC) +* Workspace: need N [e] + BDSPAC * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ = 'O') +* Path 2 (M >> N, JOBZ = 'O') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * @@ -603,42 +664,45 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK(IR) is LDWRKR by N * - IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. LDA*N + N*N + 3*N + BDSPAC ) THEN LDWRKR = LDA ELSE - LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N + LDWRKR = ( LWORK - N*N - 3*N - BDSPAC ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), + CALL DLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * -* Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Bidiagonalize R in WORK(IR) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * WORK(IU) is N by N * @@ -648,7 +712,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -656,21 +720,23 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite WORK(IU) by left singular vectors of R * and VT by right singular vectors of R -* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in WORK(IR) and copying to A -* (Workspace: need 2*N*N, prefer N*N+M*N) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] +* Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U] * DO 10 I = 1, M, LDWRKR - CHUNK = MIN( M-I+1, LDWRKR ) + CHUNK = MIN( M - I + 1, LDWRKR ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), N, ZERO, WORK( IR ), $ LDWRKR ) @@ -680,7 +746,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') +* Path 3 (M >> N, JOBZ='S') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -693,38 +759,41 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), + CALL DLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagoal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -732,19 +801,20 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of R and VT * by right singular vectors of R -* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U -* (Workspace: need N*N) +* Workspace: need N*N [R] * CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), @@ -752,7 +822,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') +* Path 4 (M >> N, JOBZ='A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -765,16 +835,18 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* Workspace: need N*N [U] + N [tau] + N [work] +* Workspace: prefer N*N [U] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* Workspace: need N*N [U] + N [tau] + M [work] +* Workspace: prefer N*N [U] + N [tau] + M*NB [work] CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce R in A, zeroing out other entries * @@ -785,7 +857,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -794,7 +867,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -802,18 +875,19 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite WORK(IU) by left singular vectors of R and VT * by right singular vectors of R -* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A -* (Workspace: need N*N) +* Workspace: need N*N [U] * CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ), $ LDWRKU, ZERO, A, LDA ) @@ -828,7 +902,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * M .LT. MNTHR * -* Path 5 (M at least N, but not much larger) +* Path 5 (M >= N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 @@ -837,21 +911,24 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work] * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5n (M >= N, JOBZ='N') * Perform bidiagonal SVD, only computing singular values -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 5o (M >= N, JOBZ='O') IU = NWORK - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * * WORK( IU ) is M by N * @@ -859,6 +936,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IU + LDWRKU*N CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), $ LDWRKU ) +* IR is unused; silence compile warnings + IR = -1 ELSE * * WORK( IU ) is N by N @@ -869,53 +948,59 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * WORK(IR) is LDWRKR by N * IR = NWORK - LDWRKR = ( LWORK-N*N-3*N ) / N + LDWRKR = ( LWORK - N*N - 3*N ) / N END IF NWORK = IU + LDWRKU*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), $ IWORK, INFO ) * * Overwrite VT by right singular vectors of A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * +* Path 5o-fast * Overwrite WORK(IU) by left singular vectors of A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + M*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy left singular vectors of A from WORK(IU) to A * CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) ELSE * +* Path 5o-slow * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of * bidiagonal matrix in WORK(IU), storing result in * WORK(IR) and copying to A -* (Workspace: need 2*N*N, prefer N*N+M*N) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + NB*N [R] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N [R] * DO 20 I = 1, M, LDWRKR - CHUNK = MIN( M-I+1, LDWRKR ) + CHUNK = MIN( M - I + 1, LDWRKR ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), LDWRKU, ZERO, $ WORK( IR ), LDWRKR ) @@ -926,10 +1011,11 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * +* Path 5s (M >= N, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -938,20 +1024,22 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 3*N, prefer 2*N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * +* Path 5a (M >= N, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -961,20 +1049,21 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Set the right corner of U to identity matrix * IF( M.GT.N ) THEN - CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ), + CALL DLASET( 'F', M - N, M - N, ZERO, ONE, U(N+1,N+1), $ LDU ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) END IF * END IF @@ -989,17 +1078,18 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* Workspace: need M [tau] + M [work] +* Workspace: prefer M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Zero out above L * @@ -1010,7 +1100,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1018,68 +1109,69 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IE + M * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need M+BDSPAC) +* Workspace: need M [e] + BDSPAC * CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') +* Path 2t (N >> M, JOBZ='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IVT = 1 * -* IVT is M by M +* WORK(IVT) is M by M +* WORK(IL) is M by M; it is later resized to M by chunk for gemm * IL = IVT + M*M - IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN -* -* WORK(IL) is M by N -* + IF( LWORK .GE. M*N + M*M + 3*M + BDSPAC ) THEN LDWRKL = M CHUNK = N ELSE LDWRKL = M - CHUNK = ( LWORK-M*M ) / M + CHUNK = ( LWORK - M*M ) / M END IF ITAU = IL + LDWRKL*M NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing about above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IL+LDWRKL ), LDWRKL ) + CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U, and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), @@ -1087,21 +1179,24 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L -* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), WORK( IVT ), M, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by Q * in A, storing result in WORK(IL) and copying to A -* (Workspace: need 2*M*M, prefer M*M+M*N) +* Workspace: need M*M [VT] + M*M [L] +* Workspace: prefer M*M [VT] + M*N [L] +* At this point, L is resized as M by chunk. * DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) + BLK = MIN( N - I + 1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL ) CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, @@ -1110,7 +1205,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') +* Path 3t (N >> M, JOBZ='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1123,38 +1218,41 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IL+LDWRKL ), LDWRKL ) + CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Bidiagonalize L in WORK(IU). +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -1162,18 +1260,19 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and VT * by right singular vectors of L -* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IL) by * Q in A, storing result in VT -* (Workspace: need M*M) +* Workspace: need M*M [L] * CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, @@ -1181,7 +1280,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') +* Path 4t (N >> M, JOBZ='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1194,17 +1293,19 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M [tau] + N [work] +* Workspace: prefer M*M [VT] + M [tau] + N*NB [work] * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce L in A, zeroing out other entries * @@ -1215,7 +1316,8 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1224,7 +1326,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, @@ -1232,18 +1334,19 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L -* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup]+ M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by * Q in VT, storing result in A -* (Workspace: need M*M) +* Workspace: need M*M [VT] * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, $ VT, LDVT, ZERO, A, LDA ) @@ -1258,7 +1361,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * N .LT. MNTHR * -* Path 5t (N greater than M, but not much larger) +* Path 5t (N > M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 @@ -1267,28 +1370,33 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work] * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5tn (N > M, JOBZ='N') * Perform bidiagonal SVD, only computing singular values -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 5to (N > M, JOBZ='O') LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * * WORK( IVT ) is M by N * CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), $ LDWKVT ) NWORK = IVT + LDWKVT*N +* IL is unused; silence compile warnings + IL = -1 ELSE * * WORK( IVT ) is M by M @@ -1298,52 +1406,58 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK(IL) is M by CHUNK * - CHUNK = ( LWORK-M*M-3*M ) / M + CHUNK = ( LWORK - M*M - 3*M ) / M END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M*M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + BDSPAC * CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, $ WORK( NWORK ), IWORK, INFO ) * * Overwrite U by left singular vectors of A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * +* Path 5to-fast * Overwrite WORK(IVT) by left singular vectors of A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*N [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work] * CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy right singular vectors of A from WORK(IVT) to A * CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) ELSE * +* Path 5to-slow * Generate P**T in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by right singular vectors of * bidiagonal matrix in WORK(IVT), storing result in * WORK(IL) and copying to A -* (Workspace: need 2*M*M, prefer M*M+M*N) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M*NB [L] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N [L] * DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) + BLK = MIN( N - I + 1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), $ LDWKVT, A( 1, I ), LDA, ZERO, $ WORK( IL ), M ) @@ -1353,10 +1467,11 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF ELSE IF( WNTQS ) THEN * +* Path 5ts (N > M, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1365,20 +1480,22 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 3*M, prefer 2*M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * +* Path 5ta (N > M, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1388,20 +1505,21 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Set the right corner of VT to identity matrix * IF( N.GT.M ) THEN - CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ), + CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT(M+1,M+1), $ LDVT ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 2*M+N, prefer 2*M+N*NB) +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) END IF * END IF diff --git a/lapack-netlib/SRC/dgesv.f b/lapack-netlib/SRC/dgesv.f index 8d47f839dc..23999e167f 100644 --- a/lapack-netlib/SRC/dgesv.f +++ b/lapack-netlib/SRC/dgesv.f @@ -2,16 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] *> \endhtmlonly * @@ -19,7 +19,7 @@ * =========== * * SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dgesvd.f b/lapack-netlib/SRC/dgesvd.f index 898570b669..ddf0bd5c2d 100644 --- a/lapack-netlib/SRC/dgesvd.f +++ b/lapack-netlib/SRC/dgesvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,9 +173,9 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code): -*> - PATH 1 (M much larger than N, JOBU='N') +*> - PATH 1 (M much larger than N, JOBU='N') *> - PATH 1t (N much larger than M, JOBVT='N') -*> LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) for the other paths +*> LWORK >= MAX(1,3*MIN(M,N) + MAX(M,N),5*MIN(M,N)) for the other paths *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -198,10 +198,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -211,7 +211,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT, LDVT, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -314,24 +314,24 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, BDSPAC = 5*N * Compute space needed for DGEQRF CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGEQRF=DUM(1) + LWORK_DGEQRF = INT( DUM(1) ) * Compute space needed for DORGQR CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_N=DUM(1) + LWORK_DORGQR_N = INT( DUM(1) ) CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_M=DUM(1) + LWORK_DORGQR_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) + LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) + LWORK_DORGBR_Q = INT( DUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN @@ -339,9 +339,9 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Path 1 (M much larger than N, JOBU='N') * MAXWRK = N + LWORK_DGEQRF - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_P ) + $ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*N, BDSPAC ) ELSE IF( WNTUO .AND. WNTVN ) THEN @@ -349,97 +349,97 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N+LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE * @@ -447,25 +447,25 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*N + LWORK_DGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) + LWORK_DORGBR_Q = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( WNTUA ) THEN CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_Q ) + LWORK_DORGBR_Q = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( .NOT.WNTVN ) THEN - MAXWRK = MAX( MAXWRK, 3*N+LWORK_DORGBR_P ) + MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*N+M, BDSPAC ) + MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE IF( MINMN.GT.0 ) THEN * @@ -475,33 +475,33 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, BDSPAC = 5*M * Compute space needed for DGELQF CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGELQF=DUM(1) + LWORK_DGELQF = INT( DUM(1) ) * Compute space needed for DORGLQ CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_N=DUM(1) + LWORK_DORGLQ_N = INT( DUM(1) ) CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_M=DUM(1) + LWORK_DORGLQ_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) + LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q=DUM(1) + LWORK_DORGBR_Q = INT( DUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * MAXWRK = M + LWORK_DGELQF - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DGEBRD ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DGEBRD ) IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_Q ) + $ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*M, BDSPAC ) ELSE IF( WNTVO .AND. WNTUN ) THEN @@ -509,97 +509,97 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', * JOBVT='O') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M+LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M+LWORK_DORGBR_Q ) + WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) + WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) END IF ELSE * @@ -607,26 +607,26 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD=DUM(1) + LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*M + LWORK_DGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for DORGBR P CALL DORGBR( 'P', M, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) + LWORK_DORGBR_P = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( WNTVA ) THEN CALL DORGBR( 'P', N, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_DORGBR_P=DUM(1) - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_P ) + LWORK_DORGBR_P = INT( DUM(1) ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( .NOT.WNTUN ) THEN - MAXWRK = MAX( MAXWRK, 3*M+LWORK_DORGBR_Q ) + MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*M+N, BDSPAC ) + MINWRK = MAX( 3*M + N, BDSPAC ) END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) @@ -685,21 +685,24 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out below R * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) + END IF IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -708,7 +711,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IF( WNTVO .OR. WNTVAS ) THEN * * If right singular vectors desired, generate P'. -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -739,13 +742,13 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is N by N * @@ -762,7 +765,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -774,7 +777,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -784,14 +787,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -800,7 +803,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, $ WORK( IR ), LDWRKR, DUM, 1, @@ -809,7 +812,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) +* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 10 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) @@ -830,14 +833,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing A -* (Workspace: need 4*N, prefer 3*N+N*NB) +* (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -863,13 +866,13 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -886,7 +889,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -899,7 +902,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT( 2, 1 ), LDVT ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -909,7 +912,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -917,14 +920,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) * * Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT -* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) +* (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -933,7 +936,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) and computing right * singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, $ WORK( IR ), LDWRKR, DUM, 1, @@ -942,7 +945,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) +* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 20 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) @@ -961,7 +964,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -974,7 +977,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT( 2, 1 ), LDVT ) * * Generate Q in A -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -984,21 +987,21 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in A by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1042,7 +1045,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1055,7 +1058,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1065,7 +1068,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1073,7 +1076,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -1082,7 +1085,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, @@ -1103,14 +1106,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1121,18 +1124,20 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), @@ -1167,7 +1172,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -1186,7 +1191,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1199,7 +1204,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1210,7 +1215,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*N*N+4*N, +* (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, @@ -1221,14 +1226,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) +* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, +* (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, @@ -1239,7 +1244,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) +* (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), @@ -1266,14 +1271,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1284,25 +1289,27 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1346,7 +1353,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1359,7 +1366,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1369,7 +1376,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1379,14 +1386,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, +* (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -1396,7 +1403,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, @@ -1417,14 +1424,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1441,7 +1448,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1449,14 +1456,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in U by left bidiagonalizing vectors * in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1503,7 +1510,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1517,7 +1524,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1527,7 +1534,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1535,7 +1542,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -1544,7 +1551,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, @@ -1569,14 +1576,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1587,11 +1594,13 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1599,7 +1608,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in U by left bidiagonalizing vectors * in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), @@ -1634,7 +1643,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * @@ -1653,14 +1662,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) +* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) +* (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1678,7 +1687,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*N*N+4*N, +* (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, @@ -1689,14 +1698,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) +* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, +* (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, @@ -1707,7 +1716,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) +* (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), @@ -1737,14 +1746,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1755,11 +1764,13 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1767,14 +1778,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in U by left bidiagonalizing vectors * in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1818,14 +1829,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1842,7 +1853,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -1852,14 +1863,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) +* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, +* (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -1869,7 +1880,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) +* (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, @@ -1894,14 +1905,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) +* (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) +* (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1918,7 +1929,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -1926,14 +1937,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply Q in U by left bidiagonalizing vectors * in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) +* (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -1967,7 +1978,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -1976,7 +1987,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U -* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) +* (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB) * CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) IF( WNTUS ) @@ -1990,7 +2001,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), @@ -2000,7 +2011,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A -* (Workspace: need 4*N, prefer 3*N+N*NB) +* (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2009,7 +2020,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) +* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2071,7 +2082,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) @@ -2085,7 +2096,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -2093,7 +2104,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IF( WNTUO .OR. WNTUAS ) THEN * * If left singular vectors desired, generate Q -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2126,14 +2137,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * @@ -2152,7 +2163,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2164,7 +2175,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2174,14 +2185,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), @@ -2190,7 +2201,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2199,7 +2210,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M) +* (Workspace: need M*M + 2*M, prefer M*M + M*N + M) * DO 30 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -2220,14 +2231,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2253,14 +2264,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Sufficient workspace for a fast algorithm * IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN + IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN + ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * @@ -2279,7 +2290,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2291,7 +2302,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDU ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2301,7 +2312,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in U, copying result to WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2309,14 +2320,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) * * Generate right vectors bidiagonalizing L in WORK(IR) -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2325,7 +2336,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of L in U, and computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, @@ -2334,7 +2345,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) +* (Workspace: need M*M + 2*M, prefer M*M + M*N + M)) * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -2353,7 +2364,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2365,7 +2376,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDU ) * * Generate Q in A -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2375,21 +2386,21 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in A -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2433,7 +2444,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2446,7 +2457,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2456,7 +2467,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2465,7 +2476,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Generate right vectors bidiagonalizing L in * WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), @@ -2474,7 +2485,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2495,7 +2506,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2505,7 +2516,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2520,14 +2531,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, @@ -2562,7 +2573,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * @@ -2581,7 +2592,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2594,7 +2605,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2605,7 +2616,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*M*M+4*M, +* (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, @@ -2616,7 +2627,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, +* (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -2624,7 +2635,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -2634,7 +2645,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) +* (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), @@ -2661,14 +2672,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2683,21 +2694,21 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors of L in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2741,7 +2752,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2754,7 +2765,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2764,7 +2775,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2774,7 +2785,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M-1, +* (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -2782,7 +2793,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2791,7 +2802,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, @@ -2812,14 +2823,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2835,7 +2846,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2843,14 +2854,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right bidiagonalizing vectors in U by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2877,7 +2888,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * N right singular vectors to be computed in VT and * no left singular vectors to be computed * - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -2897,7 +2908,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2911,7 +2922,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2921,7 +2932,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), @@ -2929,7 +2940,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need M*M+4*M-1, +* (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, @@ -2939,7 +2950,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, @@ -2964,14 +2975,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -2986,7 +2997,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -2994,7 +3005,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right bidiagonalizing vectors in A by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, @@ -3017,7 +3028,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * N right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * - IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.2*M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -3029,7 +3040,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN + ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * @@ -3048,14 +3059,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) +* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) +* (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3073,7 +3084,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) -* (Workspace: need 2*M*M+4*M, +* (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, @@ -3084,7 +3095,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, +* (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, @@ -3092,7 +3103,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) +* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), @@ -3102,7 +3113,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) +* (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), @@ -3132,14 +3143,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3154,7 +3165,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDA ) * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -3162,14 +3173,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right bidiagonalizing vectors in A by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3193,7 +3204,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN + IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * @@ -3213,14 +3224,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) +* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3237,7 +3248,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), @@ -3247,14 +3258,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) +* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3263,7 +3274,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) +* (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, @@ -3288,14 +3299,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) +* (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) +* (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3311,7 +3322,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), @@ -3319,14 +3330,14 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Multiply right bidiagonalizing vectors in U by Q * in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) +* (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3360,7 +3371,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, IWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, @@ -3369,7 +3380,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) +* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), @@ -3379,7 +3390,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) +* (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB) * CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) IF( WNTVA ) @@ -3393,7 +3404,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) +* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) @@ -3402,7 +3413,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) +* (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) diff --git a/lapack-netlib/SRC/dgesvdx.f b/lapack-netlib/SRC/dgesvdx.f index cfa2ff05d3..7da3d099c3 100644 --- a/lapack-netlib/SRC/dgesvdx.f +++ b/lapack-netlib/SRC/dgesvdx.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, -* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, +* SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, +* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, * $ LWORK, IWORK, INFO ) -* +* * * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT, RANGE @@ -33,7 +33,7 @@ * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -43,23 +43,23 @@ *> DGESVDX computes the singular value decomposition (SVD) of a real *> M-by-N matrix A, optionally computing the left and/or right singular *> vectors. The SVD is written -*> +*> *> A = U * SIGMA * transpose(V) -*> +*> *> where SIGMA is an M-by-N matrix which is zero except for its *> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and *> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA *> are the singular values of A; they are real and non-negative, and *> are returned in descending order. The first min(m,n) columns of *> U and V are the left and right singular vectors of A. -*> -*> DGESVDX uses an eigenvalue problem for obtaining the SVD, which -*> allows for the computation of a subset of singular values and +*> +*> DGESVDX uses an eigenvalue problem for obtaining the SVD, which +*> allows for the computation of a subset of singular values and *> vectors. See DBDSVDX for details. -*> +*> *> Note that the routine returns V**T, not V. *> \endverbatim -* +* * Arguments: * ========== * @@ -68,7 +68,7 @@ *> JOBU is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'V': the first min(m,n) columns of U (the left singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array U; *> = 'N': no columns of U (no left singular vectors) are *> computed. @@ -80,7 +80,7 @@ *> Specifies options for computing all or part of the matrix *> V**T: *> = 'V': the first min(m,n) rows of V**T (the right singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array VT; *> = 'N': no rows of V**T (no right singular vectors) are *> computed. @@ -92,7 +92,7 @@ *> = 'A': all singular values will be found. *> = 'V': all singular values in the half-open interval (VL,VU] *> will be found. -*> = 'I': the IL-th through IU-th singular values will be found. +*> = 'I': the IL-th through IU-th singular values will be found. *> \endverbatim *> *> \param[in] M @@ -123,13 +123,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION -*> VL >=0. +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -137,13 +139,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -151,7 +157,7 @@ *> \param[out] NS *> \verbatim *> NS is INTEGER -*> The total number of singular values found, +*> The total number of singular values found, *> 0 <= NS <= min(M,N). *> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1. *> \endverbatim @@ -165,11 +171,11 @@ *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,UCOL) -*> If JOBU = 'V', U contains columns of U (the left singular -*> vectors, stored columnwise) as specified by RANGE; if +*> If JOBU = 'V', U contains columns of U (the left singular +*> vectors, stored columnwise) as specified by RANGE; if *> JOBU = 'N', U is not referenced. -*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', -*> the exact value of NS is not known ILQFin advance and an upper +*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -183,11 +189,11 @@ *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT,N) -*> If JOBVT = 'V', VT contains the rows of V**T (the right singular -*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', +*> If JOBVT = 'V', VT contains the rows of V**T (the right singular +*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', *> VT is not referenced. -*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', -*> the exact value of NS is not known in advance and an upper +*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -208,9 +214,9 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see +*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see *> comments inside the code): -*> - PATH 1 (M much larger than N) +*> - PATH 1 (M much larger than N) *> - PATH 1t (N much larger than M) *> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths. *> For good performance, LWORK should generally be larger. @@ -224,8 +230,8 @@ *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (12*MIN(M,N)) -*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, -*> then IWORK contains the indices of the eigenvectors that failed +*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, +*> then IWORK contains the indices of the eigenvectors that failed *> to converge in DBDSVDX/DSTEVX. *> \endverbatim *> @@ -243,24 +249,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleGEsing * * ===================================================================== - SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, - $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, + SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, + $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT, RANGE @@ -283,7 +289,7 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CHARACTER JOBZ, RNGTGK LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL, - $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, + $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, $ J, MAXWRK, MINMN, MINWRK, MNTHR DOUBLE PRECISION ABSTOL, ANRM, BIGNUM, EPS, SMLNUM * .. @@ -293,13 +299,13 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * .. External Subroutines .. EXTERNAL DBDSVDX, DGEBRD, DGELQF, DGEQRF, DLACPY, $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, - $ DSCAL, XERBLA + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE, DNRM2 + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT @@ -357,8 +363,14 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( INFO.EQ.0 ) THEN IF( WANTU .AND. LDU.LT.M ) THEN INFO = -15 - ELSE IF( WANTVT .AND. LDVT.LT.MINMN ) THEN - INFO = -16 + ELSE IF( WANTVT ) THEN + IF( INDS ) THEN + IF( LDVT.LT.IU-IL+1 ) THEN + INFO = -17 + END IF + ELSE IF( LDVT.LT.MINMN ) THEN + INFO = -17 + END IF END IF END IF END IF @@ -380,18 +392,34 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1 (M much larger than N) * - MAXWRK = N*(N*2+16) + + MAXWRK = N + $ N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, N*(N*2+20) + 2*N* + MAXWRK = MAX( MAXWRK, N*(N+5) + 2*N* $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - MINWRK = N*(N*2+21) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'DORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'DORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = N*(N*3+20) ELSE * * Path 2 (M at least N, but not much larger) * - MAXWRK = N*(N*2+19) + ( M+N )* + MAXWRK = 4*N + ( M+N )* $ ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) - MINWRK = N*(N*2+20) + M + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'DORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'DORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = MAX(N*(N*2+19),4*N+M) END IF ELSE MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) @@ -399,18 +427,34 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1t (N much larger than M) * - MAXWRK = M*(M*2+16) + + MAXWRK = M + $ M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*(M*2+20) + 2*M* + MAXWRK = MAX( MAXWRK, M*(M+5) + 2*M* $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MINWRK = M*(M*2+21) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'DORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'DORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = M*(M*3+20) ELSE * -* Path 2t (N greater than M, but not much larger) +* Path 2t (N at least M, but not much larger) * - MAXWRK = M*(M*2+19) + ( M+N )* + MAXWRK = 4*M + ( M+N )* $ ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) - MINWRK = M*(M*2+20) + N + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'DORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'DORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = MAX(M*(M*2+19),4*M+N) END IF END IF END IF @@ -445,7 +489,7 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, RNGTGK = 'I' ILTGK = IL IUTGK = IU - ELSE + ELSE RNGTGK = 'V' ILTGK = 0 IUTGK = 0 @@ -489,7 +533,7 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAU + N CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) -* +* * Copy R into WORK and bidiagonalize it: * (Workspace: need N*N+5*N, prefer N*N+4*N+2*N*NB) * @@ -498,19 +542,19 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + N ITAUQ = IE + N ITAUP = ITAUQ + N - ITEMP = ITAUP + N + ITEMP = ITAUP + N CALL DLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), N ) - CALL DGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), + CALL DGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 14*N + 2*N*(N+1)) -* +* (Workspace: need 14*N + 2*N*(N+1)) +* ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -522,23 +566,23 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL DLASET( 'A', M-N, N, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) * * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL DORMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL DORMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call DORMQR to compute Q*(QB*UB). * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL DORMQR( 'L', 'N', M, NS, N, A, LDA, + CALL DORMQR( 'L', 'N', M, NS, N, A, LDA, $ WORK( ITAU ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -551,7 +595,7 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call DORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL DORMBR( 'P', 'R', 'T', NS, N, N, WORK( IQRF ), N, + CALL DORMBR( 'P', 'R', 'T', NS, N, N, WORK( IQRF ), N, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) END IF @@ -569,17 +613,17 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + N ITAUQ = IE + N ITAUP = ITAUQ + N - ITEMP = ITAUP + N - CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + ITEMP = ITAUP + N + CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 14*N + 2*N*(N+1)) -* +* (Workspace: need 14*N + 2*N*(N+1)) +* ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -591,16 +635,16 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL DLASET( 'A', M-N, N, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL DLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) * * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) -* - CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), +* + CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -613,11 +657,11 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call DORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL DORMBR( 'P', 'R', 'T', NS, N, N, A, LDA, + CALL DORMBR( 'P', 'R', 'T', NS, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) END IF - END IF + END IF ELSE * * A has more columns than rows. If A has sufficiently more @@ -626,7 +670,7 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M): -* A = L * Q = ( QB * B * PB**T ) * Q +* A = L * Q = ( QB * B * PB**T ) * Q * = ( QB * ( UB * S * VB**T ) * PB**T ) * Q * U = QB * UB ; V**T = VB**T * PB**T * Q * @@ -649,16 +693,16 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAUP + M CALL DLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M ) - CALL DGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), + CALL DGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -674,11 +718,11 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL DORMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL DORMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -687,28 +731,28 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL DLASET( 'A', M, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT ) + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) * * Call DORMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL DORMBR( 'P', 'R', 'T', NS, M, M, WORK( ILQF ), M, + CALL DORMBR( 'P', 'R', 'T', NS, M, M, WORK( ILQF ), M, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call DORMLQ to compute ((VB**T)*(PB**T))*Q. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL DORMLQ( 'R', 'N', NS, N, M, A, LDA, + CALL DORMLQ( 'R', 'N', NS, N, M, A, LDA, $ WORK( ITAU ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF ELSE * * Path 2t (N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T -* U = QB * UB; V**T = VB**T * PB**T +* U = QB * UB; V**T = VB**T * PB**T * * Bidiagonalize A * (Workspace: need 4*M+N, prefer 4*M+(M+N)*NB) @@ -718,19 +762,19 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUQ = IE + M ITAUP = ITAUQ + M ITEMP = ITAUP + M - CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + CALL DGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) -* +* * If needed, compute left singular vectors. * IF( WANTU ) THEN @@ -743,11 +787,11 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call DORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL DORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -756,15 +800,15 @@ SUBROUTINE DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL DCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL DLASET( 'A', M, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT ) + CALL DLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) * * Call DORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL DORMBR( 'P', 'R', 'T', NS, N, M, A, LDA, + CALL DORMBR( 'P', 'R', 'T', NS, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF END IF END IF * diff --git a/lapack-netlib/SRC/dgesvj.f b/lapack-netlib/SRC/dgesvj.f index e89af874e1..2b2599420c 100644 --- a/lapack-netlib/SRC/dgesvj.f +++ b/lapack-netlib/SRC/dgesvj.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * LDV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N * CHARACTER*1 JOBA, JOBU, JOBV @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -103,7 +103,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. +*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. *> \endverbatim *> *> \param[in] N @@ -208,7 +208,7 @@ *> *> \param[in,out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension max(4,M+N). +*> WORK is DOUBLE PRECISION array, dimension MAX(6,M+N). *> On entry : *> If JOBU .EQ. 'C' : *> WORK(1) = CTOL, where CTOL defines the threshold for convergence. @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -337,10 +337,10 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N @@ -1261,7 +1261,7 @@ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*DSQRT( MAX( ZERO, + AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = WORK( p ) / WORK( q ) diff --git a/lapack-netlib/SRC/dgesvx.f b/lapack-netlib/SRC/dgesvx.f index aac2053244..25f0f28278 100644 --- a/lapack-netlib/SRC/dgesvx.f +++ b/lapack-netlib/SRC/dgesvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, * EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -335,10 +335,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -349,7 +349,7 @@ SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dgesvxx.f b/lapack-netlib/SRC/dgesvxx.f index ba2253f7f1..afcd05d8ea 100644 --- a/lapack-netlib/SRC/dgesvxx.f +++ b/lapack-netlib/SRC/dgesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -524,10 +524,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -540,7 +540,7 @@ SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dgetc2.f b/lapack-netlib/SRC/dgetc2.f index 3cd7eeb2ba..d850bc628b 100644 --- a/lapack-netlib/SRC/dgetc2.f +++ b/lapack-netlib/SRC/dgetc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup doubleGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/dgetf2.f b/lapack-netlib/SRC/dgetf2.f index 649d0671de..5458a5f3eb 100644 --- a/lapack-netlib/SRC/dgetf2.f +++ b/lapack-netlib/SRC/dgetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -128,11 +128,11 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - DOUBLE PRECISION SFMIN + DOUBLE PRECISION SFMIN INTEGER I, J, JP * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH + DOUBLE PRECISION DLAMCH INTEGER IDAMAX EXTERNAL DLAMCH, IDAMAX * .. @@ -164,9 +164,9 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') * DO 10 J = 1, MIN( M, N ) * @@ -183,15 +183,15 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * Compute elements J+1:M of J-th column. * - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF * ELSE IF( INFO.EQ.0 ) THEN * diff --git a/lapack-netlib/SRC/dgetrf.f b/lapack-netlib/SRC/dgetrf.f index 0f1f6d470c..9a340b60f3 100644 --- a/lapack-netlib/SRC/dgetrf.f +++ b/lapack-netlib/SRC/dgetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/dgetrf2.f b/lapack-netlib/SRC/dgetrf2.f index b1871b5dd4..77948d2305 100644 --- a/lapack-netlib/SRC/dgetrf2.f +++ b/lapack-netlib/SRC/dgetrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -35,11 +35,11 @@ *> *> This is the recursive version of the algorithm. It divides *> the matrix into four submatrices: -*> +*> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = min(m,n) +*> A = [ -----|----- ] with n1 = min(m,n)/2 *> [ A21 | A22 ] n2 = n-n1 -*> +*> *> [ A11 ] *> The subroutine calls itself to factor [ --- ], *> [ A12 ] @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -239,12 +239,12 @@ RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) * * Solve A12 * - CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, $ A( 1, N1+1 ), LDA ) * * Update A22 * - CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) * * Factor A22 diff --git a/lapack-netlib/SRC/dgetri.f b/lapack-netlib/SRC/dgetri.f index ad5324c07e..9d8cf2ad3e 100644 --- a/lapack-netlib/SRC/dgetri.f +++ b/lapack-netlib/SRC/dgetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/dgetrs.f b/lapack-netlib/SRC/dgetrs.f index 02e9832af7..7ac727776e 100644 --- a/lapack-netlib/SRC/dgetrs.f +++ b/lapack-netlib/SRC/dgetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgetsls.f b/lapack-netlib/SRC/dgetsls.f new file mode 100644 index 0000000000..ca0ef777be --- /dev/null +++ b/lapack-netlib/SRC/dgetsls.f @@ -0,0 +1,494 @@ +* Definition: +* =========== +* +* SUBROUTINE DGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGETSLS solves overdetermined or underdetermined real linear systems +*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ +*> factorization of A. It is assumed that A has full rank. +*> +*> +*> +*> The following options are provided: +*> +*> 1. If TRANS = 'N' and m >= n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A*X ||. +*> +*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of +*> an underdetermined system A * X = B. +*> +*> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of +*> an undetermined system A**T * X = B. +*> +*> 4. If TRANS = 'T' and m < n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A**T * X ||. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'T': the linear system involves A**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> A is overwritten by details of its QR or LQ +*> factorization as returned by DGEQR or DGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the matrix B of right hand side vectors, stored +*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS +*> if TRANS = 'T'. +*> On exit, if INFO = 0, B is overwritten by the solution +*> vectors, stored columnwise: +*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least +*> squares solution vectors. +*> if TRANS = 'N' and m < n, rows 1 to N of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'T' and m < n, rows 1 to M of B contain the +*> least squares solution vectors. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of A is zero, so that A does not have +*> full rank; the least squares solution could not be +*> computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE DGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TRAN + INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, + $ SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2, + $ WSIZEO, WSIZEM, INFO2 + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DGEQR, DGEMQR, DLASCL, DLASET, + $ DTRTRS, XERBLA, DGELQ, DGEMLQ +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, INT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNK = MAX( MINMN, NRHS ) + TRAN = LSAME( TRANS, 'T' ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) + IF( .NOT.( LSAME( TRANS, 'N' ) .OR. + $ LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size and minimum LWORK +* + IF( M.GE.N ) THEN + CALL DGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL DGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL DGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL DGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZM, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + ELSE + CALL DGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL DGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL DGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL DGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + END IF +* + IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN + INFO = -10 + END IF +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETSLS', -INFO ) + WORK( 1 ) = DBLE( WSIZEO ) + RETURN + END IF + IF( LQUERY ) THEN + IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO ) + IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM ) + RETURN + END IF + IF( LWORK.LT.WSIZEO ) THEN + LW1 = TSZM + LW2 = LWM + ELSE + LW1 = TSZO + LW2 = LWO + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + CALL DLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO, + $ B, LDB ) + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL DLASET( 'F', MAXMN, NRHS, ZERO, ZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF ( TRAN ) THEN + BROW = N + END IF + BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +* + IF ( M.GE.N ) THEN +* +* compute QR factorization of A +* + CALL DGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) + IF ( .NOT.TRAN ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) +* + CALL DGEMQR( 'L' , 'T', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL DTRTRS( 'U', 'N', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) + IF( INFO.GT.0 ) THEN + RETURN + END IF + SCLLEN = N + ELSE +* +* Overdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) +* + CALL DTRTRS( 'U', 'T', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(N+1:M,1:NRHS) = ZERO +* + DO 20 J = 1, NRHS + DO 10 I = N + 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) +* + CALL DGEMQR( 'L', 'N', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL DGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TRAN ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL DTRTRS( 'L', 'N', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(M+1:N,1:NRHS) = 0 +* + DO 40 J = 1, NRHS + DO 30 I = M + 1, N + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS) +* + CALL DGEMLQ( 'L', 'T', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = N +* + ELSE +* +* overdetermined system min || A**T * X - B || +* +* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) +* + CALL DGEMLQ( 'L', 'N', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS) +* + CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = M +* + END IF +* + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF +* + 50 CONTINUE + WORK( 1 ) = DBLE( TSZO + LWO ) + RETURN +* +* End of DGETSLS +* + END diff --git a/lapack-netlib/SRC/dggbak.f b/lapack-netlib/SRC/dggbak.f index 9b56e152b1..cd5c26064b 100644 --- a/lapack-netlib/SRC/dggbak.f +++ b/lapack-netlib/SRC/dggbak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, * LDV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -147,10 +147,10 @@ SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/dggbal.f b/lapack-netlib/SRC/dggbal.f index a90e62aa71..5f36aa024b 100644 --- a/lapack-netlib/SRC/dggbal.f +++ b/lapack-netlib/SRC/dggbal.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, * RSCALE, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, LDB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), * $ RSCALE( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -177,10 +177,10 @@ SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/dgges.f b/lapack-netlib/SRC/dgges.f index 76d6d399ad..097ea77275 100644 --- a/lapack-netlib/SRC/dgges.f +++ b/lapack-netlib/SRC/dgges.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, * SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, * LDVSR, WORK, LWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM @@ -36,7 +36,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -270,12 +270,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEeigen * @@ -284,10 +284,10 @@ SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, $ LDVSR, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT diff --git a/lapack-netlib/SRC/dggesx.f b/lapack-netlib/SRC/dggesx.f index 3f8a391ac6..f316c7fc2e 100644 --- a/lapack-netlib/SRC/dggesx.f +++ b/lapack-netlib/SRC/dggesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, * VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, * LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SENSE, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, @@ -40,7 +40,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -332,12 +332,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEeigen * @@ -365,10 +365,10 @@ SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, $ LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT diff --git a/lapack-netlib/SRC/dggev.f b/lapack-netlib/SRC/dggev.f index 1840af2861..fa86828247 100644 --- a/lapack-netlib/SRC/dggev.f +++ b/lapack-netlib/SRC/dggev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -30,7 +30,7 @@ * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,10 +213,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -226,7 +226,7 @@ SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dggevx.f b/lapack-netlib/SRC/dggevx.f index ebf9f2c4c2..1f6962df5d 100644 --- a/lapack-netlib/SRC/dggevx.f +++ b/lapack-netlib/SRC/dggevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, * IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, * RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -36,7 +36,7 @@ * $ RCONDE( * ), RCONDV( * ), RSCALE( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -347,10 +347,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -391,7 +391,7 @@ SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -432,7 +432,7 @@ SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, - $ DTGSNA, XERBLA + $ DTGSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME diff --git a/lapack-netlib/SRC/dggglm.f b/lapack-netlib/SRC/dggglm.f index 91c396554b..2e92912e0d 100644 --- a/lapack-netlib/SRC/dggglm.f +++ b/lapack-netlib/SRC/dggglm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGGLM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGGLM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), * $ X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -185,10 +185,10 @@ SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/dgghd3.f b/lapack-netlib/SRC/dgghd3.f index 812df3f232..034e94389d 100644 --- a/lapack-netlib/SRC/dgghd3.f +++ b/lapack-netlib/SRC/dgghd3.f @@ -230,7 +230,7 @@ SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -277,7 +277,7 @@ SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * INFO = 0 NB = ILAENV( 1, 'DGGHD3', ' ', N, ILO, IHI, -1 ) - LWKOPT = 6*N*NB + LWKOPT = MAX( 6*N*NB, 1 ) WORK( 1 ) = DBLE( LWKOPT ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) diff --git a/lapack-netlib/SRC/dgghrd.f b/lapack-netlib/SRC/dgghrd.f index 3157af846f..3a74899d1c 100644 --- a/lapack-netlib/SRC/dgghrd.f +++ b/lapack-netlib/SRC/dgghrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ * INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -207,10 +207,10 @@ SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ diff --git a/lapack-netlib/SRC/dgglse.f b/lapack-netlib/SRC/dgglse.f index 429c798ef7..5d5cac23b6 100644 --- a/lapack-netlib/SRC/dgglse.f +++ b/lapack-netlib/SRC/dgglse.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGLSE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGLSE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERsolve * @@ -180,10 +180,10 @@ SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/dggqrf.f b/lapack-netlib/SRC/dggqrf.f index ea0c04c589..3ce21d8fd9 100644 --- a/lapack-netlib/SRC/dggqrf.f +++ b/lapack-netlib/SRC/dggqrf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -215,10 +215,10 @@ SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/dggrqf.f b/lapack-netlib/SRC/dggrqf.f index 86267a186d..9c377cc5a6 100644 --- a/lapack-netlib/SRC/dggrqf.f +++ b/lapack-netlib/SRC/dggrqf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -214,10 +214,10 @@ SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/dggsvd3.f b/lapack-netlib/SRC/dggsvd3.f index baad1532e6..f882139dda 100644 --- a/lapack-netlib/SRC/dggsvd3.f +++ b/lapack-netlib/SRC/dggsvd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGSVD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGSVD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -323,14 +323,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * -*> \ingroup doubleOTHERsing +*> \ingroup doubleGEsing * *> \par Contributors: * ================== @@ -349,7 +349,7 @@ SUBROUTINE DGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * August 2015 diff --git a/lapack-netlib/SRC/dggsvp3.f b/lapack-netlib/SRC/dggsvp3.f index 6041e4eaea..0ff113b166 100644 --- a/lapack-netlib/SRC/dggsvp3.f +++ b/lapack-netlib/SRC/dggsvp3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGGSVP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGGSVP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. +*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -245,10 +245,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -272,7 +272,7 @@ SUBROUTINE DGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * August 2015 diff --git a/lapack-netlib/SRC/dgsvj0.f b/lapack-netlib/SRC/dgsvj0.f index 344658cf01..7d242806bc 100644 --- a/lapack-netlib/SRC/dgsvj0.f +++ b/lapack-netlib/SRC/dgsvj0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGSVJ0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP * DOUBLE PRECISION EPS, SFMIN, TOL @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -188,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -218,10 +218,10 @@ SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP @@ -280,7 +280,7 @@ SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, INFO = -5 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN @@ -485,7 +485,7 @@ SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*DSQRT( MAX( ZERO, + AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) * @@ -800,7 +800,7 @@ SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*DSQRT( MAX( ZERO, + AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) diff --git a/lapack-netlib/SRC/dgsvj1.f b/lapack-netlib/SRC/dgsvj1.f index b32ba0fe63..9acab16ba7 100644 --- a/lapack-netlib/SRC/dgsvj1.f +++ b/lapack-netlib/SRC/dgsvj1.f @@ -1,26 +1,26 @@ -*> \brief \b DGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivots. +*> \brief \b DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular pivots. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGSVJ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGSVJ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION EPS, SFMIN, TOL * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -218,12 +218,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * @@ -236,10 +236,10 @@ SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. DOUBLE PRECISION EPS, SFMIN, TOL @@ -300,7 +300,7 @@ SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, INFO = -6 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -9 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( TOL.LE.EPS ) THEN @@ -499,7 +499,7 @@ SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*DSQRT( MAX( ZERO, + AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) APOAQ = D( p ) / D( q ) diff --git a/lapack-netlib/SRC/dgtcon.f b/lapack-netlib/SRC/dgtcon.f index 8dca24fad4..4271823489 100644 --- a/lapack-netlib/SRC/dgtcon.f +++ b/lapack-netlib/SRC/dgtcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTcomputational * @@ -146,10 +146,10 @@ SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dgtrfs.f b/lapack-netlib/SRC/dgtrfs.f index 9c27fb2be0..74889353f2 100644 --- a/lapack-netlib/SRC/dgtrfs.f +++ b/lapack-netlib/SRC/dgtrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTcomputational * @@ -209,10 +209,10 @@ SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgtsv.f b/lapack-netlib/SRC/dgtsv.f index ff344d9fdb..b683eaafb6 100644 --- a/lapack-netlib/SRC/dgtsv.f +++ b/lapack-netlib/SRC/dgtsv.f @@ -1,32 +1,32 @@ -*> \brief DGTSV computes the solution to system of linear equations A * X = B for GT matrices +*> \brief DGTSV computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTsolve * * ===================================================================== SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dgtsvx.f b/lapack-netlib/SRC/dgtsvx.f index 1dd8210781..92bc9eac3c 100644 --- a/lapack-netlib/SRC/dgtsvx.f +++ b/lapack-netlib/SRC/dgtsvx.f @@ -1,19 +1,19 @@ -*> \brief DGTSVX computes the solution to system of linear equations A * X = B for GT matrices +*> \brief DGTSVX computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, * DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,12 +279,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTsolve * @@ -293,10 +293,10 @@ SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT, TRANS diff --git a/lapack-netlib/SRC/dgttrf.f b/lapack-netlib/SRC/dgttrf.f index e742b8874d..3c9808fdb4 100644 --- a/lapack-netlib/SRC/dgttrf.f +++ b/lapack-netlib/SRC/dgttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/dgttrs.f b/lapack-netlib/SRC/dgttrs.f index 4d8fc0469d..3bbeb1d1dd 100644 --- a/lapack-netlib/SRC/dgttrs.f +++ b/lapack-netlib/SRC/dgttrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTcomputational * @@ -138,10 +138,10 @@ SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dgtts2.f b/lapack-netlib/SRC/dgtts2.f index c313a75b10..39e7b0075c 100644 --- a/lapack-netlib/SRC/dgtts2.f +++ b/lapack-netlib/SRC/dgtts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DGTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER ITRANS, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ITRANS, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dhgeqz.f b/lapack-netlib/SRC/dhgeqz.f index bf6e414d72..99557f20eb 100644 --- a/lapack-netlib/SRC/dhgeqz.f +++ b/lapack-netlib/SRC/dhgeqz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DHGEQZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DHGEQZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ, JOB * INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N @@ -31,7 +31,7 @@ * $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,9 +50,9 @@ *> *> If JOB='S', then the Hessenberg-triangular pair (H,T) is *> also reduced to generalized Schur form, -*> +*> *> H = Q*S*Z**T, T = Q*P*Z**T, -*> +*> *> where Q and Z are orthogonal matrices, P is an upper triangular *> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 *> diagonal blocks. @@ -75,7 +75,7 @@ *> generalized Schur factorization of (A,B): *> *> A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. -*> +*> *> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, *> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is *> complex and beta real. @@ -86,7 +86,7 @@ *> alternate form of the GNEP *> mu*A*y = B*y. *> Real eigenvalues can be read directly from the generalized Schur -*> form: +*> form: *> alpha = S(i,i), beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix @@ -101,7 +101,7 @@ *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; -*> = 'S': Compute eigenvalues and the Schur form. +*> = 'S': Compute eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ @@ -211,12 +211,12 @@ *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +*> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in *> the reduction of (A,B) to generalized Hessenberg form. -*> On exit, if COMPZ = 'I', the orthogonal matrix of left Schur -*> vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +*> On exit, if COMPQ = 'I', the orthogonal matrix of left Schur +*> vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix *> of left Schur vectors of (A,B). -*> Not referenced if COMPZ = 'N'. +*> Not referenced if COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ @@ -277,12 +277,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup doubleGEcomputational * @@ -304,10 +304,10 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB @@ -760,7 +760,7 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ S2, WR, WR2, WI ) * IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) ) - $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) + $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) $ - H( ILAST, ILAST ) ) ) THEN TEMP = WR WR = WR2 diff --git a/lapack-netlib/SRC/dhsein.f b/lapack-netlib/SRC/dhsein.f index b8244b8285..e71cdc87e1 100644 --- a/lapack-netlib/SRC/dhsein.f +++ b/lapack-netlib/SRC/dhsein.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DHSEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DHSEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, * VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, * IFAILR, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EIGSRC, INITV, SIDE * INTEGER INFO, LDH, LDVL, LDVR, M, MM, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -263,10 +263,10 @@ SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE diff --git a/lapack-netlib/SRC/dhseqr.f b/lapack-netlib/SRC/dhseqr.f index 3ee16cad34..4444b955f4 100644 --- a/lapack-netlib/SRC/dhseqr.f +++ b/lapack-netlib/SRC/dhseqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DHSEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, * LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * CHARACTER COMPZ, JOB @@ -29,7 +29,7 @@ * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -228,12 +228,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -316,10 +316,10 @@ SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/disnan.f b/lapack-netlib/SRC/disnan.f index 355b827955..da89158fbc 100644 --- a/lapack-netlib/SRC/disnan.f +++ b/lapack-netlib/SRC/disnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DISNAN( DIN ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DIN * .. -* +* * *> \par Purpose: * ============= @@ -47,22 +47,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DISNAN( DIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DIN diff --git a/lapack-netlib/SRC/dla_gbamv.f b/lapack-netlib/SRC/dla_gbamv.f index 4774556d2c..577866cf71 100644 --- a/lapack-netlib/SRC/dla_gbamv.f +++ b/lapack-netlib/SRC/dla_gbamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GBAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GBAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, * INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -185,10 +185,10 @@ SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, $ INCX, BETA, Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/dla_gbrcond.f b/lapack-netlib/SRC/dla_gbrcond.f index 9c524752be..e9713c9ca9 100644 --- a/lapack-netlib/SRC/dla_gbrcond.f +++ b/lapack-netlib/SRC/dla_gbrcond.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GBRCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GBRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, * AFB, LDAFB, IPIV, CMODE, C, * INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE @@ -31,7 +31,7 @@ * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), * $ C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -156,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -170,10 +170,10 @@ DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, $ AFB, LDAFB, IPIV, CMODE, C, $ INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dla_gbrfsx_extended.f b/lapack-netlib/SRC/dla_gbrfsx_extended.f index 38dfef22fa..bab9bbceb6 100644 --- a/lapack-netlib/SRC/dla_gbrfsx_extended.f +++ b/lapack-netlib/SRC/dla_gbrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GBRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GBRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * ERR_BNDS_COMP, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, * $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH @@ -40,14 +40,14 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_GBRFSX_EXTENDED improves the computed solution to a system of *> linear equations by performing extra-precise iterative refinement *> and provides error bounds and backward error estimates for the solution. @@ -396,12 +396,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -414,10 +414,10 @@ SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, diff --git a/lapack-netlib/SRC/dla_gbrpvgrw.f b/lapack-netlib/SRC/dla_gbrpvgrw.f index c446687d74..3d566c2025 100644 --- a/lapack-netlib/SRC/dla_gbrpvgrw.f +++ b/lapack-netlib/SRC/dla_gbrpvgrw.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GBRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GBRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, * LDAB, AFB, LDAFB ) -* +* * .. Scalar Arguments .. * INTEGER N, KL, KU, NCOLS, LDAB, LDAFB * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBcomputational * @@ -117,10 +117,10 @@ DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, $ LDAB, AFB, LDAFB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, KL, KU, NCOLS, LDAB, LDAFB diff --git a/lapack-netlib/SRC/dla_geamv.f b/lapack-netlib/SRC/dla_geamv.f index 1c97dcb256..9a91f6ffc2 100644 --- a/lapack-netlib/SRC/dla_geamv.f +++ b/lapack-netlib/SRC/dla_geamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, * Y, INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDA, M, N, TRANS @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -174,10 +174,10 @@ SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, $ Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/dla_gercond.f b/lapack-netlib/SRC/dla_gercond.f index c8092e067e..aa93ca5a41 100644 --- a/lapack-netlib/SRC/dla_gercond.f +++ b/lapack-netlib/SRC/dla_gercond.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GERCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GERCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, * LDAF, IPIV, CMODE, C, * INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDA, LDAF, INFO, CMODE @@ -31,7 +31,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), * $ C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -152,10 +152,10 @@ DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, $ LDAF, IPIV, CMODE, C, $ INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dla_gerfsx_extended.f b/lapack-netlib/SRC/dla_gerfsx_extended.f index 1c3fd3e5fa..d6af490255 100644 --- a/lapack-netlib/SRC/dla_gerfsx_extended.f +++ b/lapack-netlib/SRC/dla_gerfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -24,7 +24,7 @@ * ERRS_N, ERRS_C, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ TRANS_TYPE, N_NORMS, ITHRESH @@ -38,14 +38,14 @@ * DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), * $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_GERFSX_EXTENDED improves the computed solution to a system of *> linear equations by performing extra-precise iterative refinement *> and provides error bounds and backward error estimates for the solution. @@ -382,12 +382,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -399,10 +399,10 @@ SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, @@ -666,7 +666,7 @@ SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, * op(A) = A, A**T, or A**H depending on TRANS (and type). * CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) - CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, + CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, $ RES, 1 ) DO I = 1, N diff --git a/lapack-netlib/SRC/dla_gerpvgrw.f b/lapack-netlib/SRC/dla_gerpvgrw.f index fe57be348c..88cc7be5f1 100644 --- a/lapack-netlib/SRC/dla_gerpvgrw.f +++ b/lapack-netlib/SRC/dla_gerpvgrw.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_GERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_GERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, * LDAF ) -* +* * .. Scalar Arguments .. * INTEGER N, NCOLS, LDA, LDAF * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_GERPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -100,10 +100,10 @@ DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, $ LDAF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NCOLS, LDA, LDAF diff --git a/lapack-netlib/SRC/dla_lin_berr.f b/lapack-netlib/SRC/dla_lin_berr.f index 7f2e825345..0fec6989be 100644 --- a/lapack-netlib/SRC/dla_lin_berr.f +++ b/lapack-netlib/SRC/dla_lin_berr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_LIN_BERR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_LIN_BERR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) -* +* * .. Scalar Arguments .. * INTEGER N, NZ, NRHS * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) * DOUBLE PRECISION RES( N, NRHS ) * .. -* +* * *> \par Purpose: * ============= @@ -79,7 +79,7 @@ *> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B *> are from iterative refinement (see dla_gerfsx_extended.f). *> \endverbatim -*> +*> *> \param[out] BERR *> \verbatim *> BERR is DOUBLE PRECISION array, dimension (NRHS) @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NZ, NRHS diff --git a/lapack-netlib/SRC/dla_porcond.f b/lapack-netlib/SRC/dla_porcond.f index 08e755f717..498e707e33 100644 --- a/lapack-netlib/SRC/dla_porcond.f +++ b/lapack-netlib/SRC/dla_porcond.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_PORCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_PORCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, * CMODE, C, INFO, WORK, * IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO, CMODE @@ -31,7 +31,7 @@ * .. Array Arguments .. * INTEGER IWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePOcomputational * @@ -142,10 +142,10 @@ DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, $ CMODE, C, INFO, WORK, $ IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -169,8 +169,7 @@ DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, * .. * .. External Functions .. LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL LSAME, IDAMAX + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLACN2, DPOTRS, XERBLA diff --git a/lapack-netlib/SRC/dla_porfsx_extended.f b/lapack-netlib/SRC/dla_porfsx_extended.f index e35b619337..0e21f0b13b 100644 --- a/lapack-netlib/SRC/dla_porfsx_extended.f +++ b/lapack-netlib/SRC/dla_porfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_PORFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_PORFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -372,12 +372,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePOcomputational * @@ -390,10 +390,10 @@ SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/dla_porpvgrw.f b/lapack-netlib/SRC/dla_porpvgrw.f index 3aee98d85a..4fe1a19223 100644 --- a/lapack-netlib/SRC/dla_porpvgrw.f +++ b/lapack-netlib/SRC/dla_porpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_PORPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_PORPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, +* DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, * LDAF, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER NCOLS, LDA, LDAF @@ -28,14 +28,14 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_PORPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -93,23 +93,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, + DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, $ LDAF, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -130,7 +130,7 @@ DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, INTRINSIC ABS, MAX, MIN * .. * .. External Functions .. - EXTERNAL LSAME, DLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/dla_syamv.f b/lapack-netlib/SRC/dla_syamv.f index f1ee81aeb3..1f948a2d77 100644 --- a/lapack-netlib/SRC/dla_syamv.f +++ b/lapack-netlib/SRC/dla_syamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_SYAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_SYAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDA, N, UPLO @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -177,10 +177,10 @@ SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/dla_syrcond.f b/lapack-netlib/SRC/dla_syrcond.f index 03e075a1d9..91d5571456 100644 --- a/lapack-netlib/SRC/dla_syrcond.f +++ b/lapack-netlib/SRC/dla_syrcond.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_SYRCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_SYRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, +* DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, * IPIV, CMODE, C, INFO, WORK, * IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO, CMODE @@ -30,7 +30,7 @@ * INTEGER IWORK( * ), IPIV( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,24 +134,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, + DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, $ IPIV, CMODE, C, INFO, WORK, $ IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -175,12 +175,11 @@ DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, * .. * .. External Functions .. LOGICAL LSAME - INTEGER IDAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IDAMAX, DLAMCH + EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS + EXTERNAL DLACN2, XERBLA, DSYTRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX diff --git a/lapack-netlib/SRC/dla_syrfsx_extended.f b/lapack-netlib/SRC/dla_syrfsx_extended.f index 83bd5af6f8..66661f7e2e 100644 --- a/lapack-netlib/SRC/dla_syrfsx_extended.f +++ b/lapack-netlib/SRC/dla_syrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_SYRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_SYRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,14 +41,14 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_SYRFSX_EXTENDED improves the computed solution to a system of *> linear equations by performing extra-precise iterative refinement *> and provides error bounds and backward error estimates for the solution. @@ -381,12 +381,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -399,10 +399,10 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, @@ -545,7 +545,7 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, CALL BLAS_DSYMV2_X(UPLO2, N, -1.0D+0, A, LDA, $ Y(1, J), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE) END IF - + ! XXX: RES is no longer needed. CALL DCOPY( N, RES, 1, DY, 1 ) CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, DY, N, INFO ) @@ -557,11 +557,11 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, NORMDX = 0.0D+0 DZ_Z = 0.0D+0 YMIN = HUGEVAL - + DO I = 1, N YK = ABS( Y( I, J ) ) DYK = ABS( DY( I ) ) - + IF ( YK .NE. 0.0D+0 ) THEN DZ_Z = MAX( DZ_Z, DYK / YK ) ELSE IF ( DYK .NE. 0.0D+0 ) THEN @@ -660,7 +660,7 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, ELSE CALL DLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) END IF - + END DO * Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. 666 CONTINUE @@ -689,9 +689,9 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, * Compute residual RES = B_s - op(A_s) * Y, * op(A) = A, A**T, or A**H depending on TRANS (and type). CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) - CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, $ 1 ) - + DO I = 1, N AYB( I ) = ABS( B( I, J ) ) END DO @@ -700,7 +700,7 @@ SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, * CALL DLA_SYAMV( UPLO2, N, 1.0D+0, $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) - + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) * * End of loop for each RHS. diff --git a/lapack-netlib/SRC/dla_syrpvgrw.f b/lapack-netlib/SRC/dla_syrpvgrw.f index 45cfb443f9..c2e5cb018d 100644 --- a/lapack-netlib/SRC/dla_syrpvgrw.f +++ b/lapack-netlib/SRC/dla_syrpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_SYRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_SYRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, * LDAF, IPIV, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -29,14 +29,14 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> DLA_SYRPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -122,10 +122,10 @@ DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, $ LDAF, IPIV, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -147,7 +147,7 @@ DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, INTRINSIC ABS, MAX, MIN * .. * .. External Functions .. - EXTERNAL LSAME, DLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/dla_wwaddw.f b/lapack-netlib/SRC/dla_wwaddw.f index 6b7509556b..99a86c5535 100644 --- a/lapack-netlib/SRC/dla_wwaddw.f +++ b/lapack-netlib/SRC/dla_wwaddw.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLA_WWADDW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLA_WWADDW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLA_WWADDW( N, X, Y, W ) -* +* * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ), Y( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -69,22 +69,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLA_WWADDW( N, X, Y, W ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/SRC/dlabad.f b/lapack-netlib/SRC/dlabad.f index 9eda3c91db..01b8158f66 100644 --- a/lapack-netlib/SRC/dlabad.f +++ b/lapack-netlib/SRC/dlabad.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLABAD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABAD( SMALL, LARGE ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION LARGE, SMALL * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL diff --git a/lapack-netlib/SRC/dlabrd.f b/lapack-netlib/SRC/dlabrd.f index 72d148119a..36c2e85bc1 100644 --- a/lapack-netlib/SRC/dlabrd.f +++ b/lapack-netlib/SRC/dlabrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -210,10 +210,10 @@ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB diff --git a/lapack-netlib/SRC/dlacn2.f b/lapack-netlib/SRC/dlacn2.f index 9dd3c85ea2..952854043a 100644 --- a/lapack-netlib/SRC/dlacn2.f +++ b/lapack-netlib/SRC/dlacn2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST @@ -28,7 +28,7 @@ * INTEGER ISGN( * ), ISAVE( 3 ) * DOUBLE PRECISION V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to DLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/dlacon.f b/lapack-netlib/SRC/dlacon.f index fa98ac5c79..0077f7c8a3 100644 --- a/lapack-netlib/SRC/dlacon.f +++ b/lapack-netlib/SRC/dlacon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLACON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLACON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST @@ -28,7 +28,7 @@ * INTEGER ISGN( * ) * DOUBLE PRECISION V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and JUMP = 3, EST should be *> unchanged from the previous call to DLACON. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -115,10 +115,10 @@ * ===================================================================== SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/dlacpy.f b/lapack-netlib/SRC/dlacpy.f index a9a23c9454..d1c396724a 100644 --- a/lapack-netlib/SRC/dlacpy.f +++ b/lapack-netlib/SRC/dlacpy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dladiv.f b/lapack-netlib/SRC/dladiv.f index 5df667d641..dd8110adf2 100644 --- a/lapack-netlib/SRC/dladiv.f +++ b/lapack-netlib/SRC/dladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, D, P, Q * .. -* +* * *> \par Purpose: * ============= @@ -79,19 +79,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date January 2013 * -*> \ingroup auxOTHERauxiliary +*> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 @@ -132,12 +132,12 @@ SUBROUTINE DLADIV( A, B, C, D, P, Q ) AB = MAX( ABS(A), ABS(B) ) CD = MAX( ABS(C), ABS(D) ) S = 1.0D0 - + OV = DLAMCH( 'Overflow threshold' ) UN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Epsilon' ) BE = BS / (EPS*EPS) - + IF( AB >= HALF*OV ) THEN AA = HALF * AA BB = HALF * BB @@ -173,11 +173,12 @@ SUBROUTINE DLADIV( A, B, C, D, P, Q ) * END - +*> \ingroup doubleOTHERauxiliary + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 @@ -213,9 +214,11 @@ SUBROUTINE DLADIV1( A, B, C, D, P, Q ) * END +*> \ingroup doubleOTHERauxiliary + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 diff --git a/lapack-netlib/SRC/dlae2.f b/lapack-netlib/SRC/dlae2.f index 302eeaa1f7..ed77ff6dfe 100644 --- a/lapack-netlib/SRC/dlae2.f +++ b/lapack-netlib/SRC/dlae2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAE2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAE2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, RT1, RT2 * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -102,10 +102,10 @@ * ===================================================================== SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 diff --git a/lapack-netlib/SRC/dlaebz.f b/lapack-netlib/SRC/dlaebz.f index 64ced89e18..f36a82c59f 100644 --- a/lapack-netlib/SRC/dlaebz.f +++ b/lapack-netlib/SRC/dlaebz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEBZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, * RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, * NAB, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX * DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL @@ -31,7 +31,7 @@ * DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -268,14 +268,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -319,10 +319,10 @@ SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX diff --git a/lapack-netlib/SRC/dlaed0.f b/lapack-netlib/SRC/dlaed0.f index d8d7f53e1d..4e92da98ea 100644 --- a/lapack-netlib/SRC/dlaed0.f +++ b/lapack-netlib/SRC/dlaed0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -172,10 +172,10 @@ SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ diff --git a/lapack-netlib/SRC/dlaed1.f b/lapack-netlib/SRC/dlaed1.f index c37c1d2100..30e71fa241 100644 --- a/lapack-netlib/SRC/dlaed1.f +++ b/lapack-netlib/SRC/dlaed1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, INFO, LDQ, N * DOUBLE PRECISION RHO @@ -29,7 +29,7 @@ * INTEGER INDXQ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -54,7 +54,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLAED2. *> @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, INFO, LDQ, N diff --git a/lapack-netlib/SRC/dlaed2.f b/lapack-netlib/SRC/dlaed2.f index a75d72a737..fbcc87a880 100644 --- a/lapack-netlib/SRC/dlaed2.f +++ b/lapack-netlib/SRC/dlaed2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * DOUBLE PRECISION RHO @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -212,10 +212,10 @@ SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 @@ -520,10 +520,10 @@ SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * into the last N - K slots of D and Q respectively. * IF( K.LT.N ) THEN - CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, + CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, $ Q( 1, K+1 ), LDQ ) CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) - END IF + END IF * * Copy CTOT into COLTYP for referencing in DLAED3. * diff --git a/lapack-netlib/SRC/dlaed3.f b/lapack-netlib/SRC/dlaed3.f index 411d0f890f..4e62b31439 100644 --- a/lapack-netlib/SRC/dlaed3.f +++ b/lapack-netlib/SRC/dlaed3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, * CTOT, W, S, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * DOUBLE PRECISION RHO @@ -30,7 +30,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ S( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -185,10 +185,10 @@ SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 diff --git a/lapack-netlib/SRC/dlaed4.f b/lapack-netlib/SRC/dlaed4.f index c898b5b618..e7dc839df5 100644 --- a/lapack-netlib/SRC/dlaed4.f +++ b/lapack-netlib/SRC/dlaed4.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER I, INFO, N * DOUBLE PRECISION DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N diff --git a/lapack-netlib/SRC/dlaed5.f b/lapack-netlib/SRC/dlaed5.f index 3ac9aa19a8..3ea9e401cf 100644 --- a/lapack-netlib/SRC/dlaed5.f +++ b/lapack-netlib/SRC/dlaed5.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* +* * .. Scalar Arguments .. * INTEGER I * DOUBLE PRECISION DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -108,10 +108,10 @@ * ===================================================================== SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I diff --git a/lapack-netlib/SRC/dlaed6.f b/lapack-netlib/SRC/dlaed6.f index e1573f3178..daa8db39e4 100644 --- a/lapack-netlib/SRC/dlaed6.f +++ b/lapack-netlib/SRC/dlaed6.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL ORGATI * INTEGER INFO, KNITER @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( 3 ), Z( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL ORGATI @@ -175,7 +175,7 @@ SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) INTEGER I, ITER, NITER DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, - $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, $ LBD, UBD * .. * .. Intrinsic Functions .. @@ -195,7 +195,7 @@ SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) IF( FINIT .LT. ZERO )THEN LBD = ZERO ELSE - UBD = ZERO + UBD = ZERO END IF * NITER = 1 @@ -363,7 +363,7 @@ SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * TAU = TAU + ETA IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD + UBD )/TWO + $ TAU = ( LBD + UBD )/TWO * FC = ZERO ERRETM = ZERO diff --git a/lapack-netlib/SRC/dlaed7.f b/lapack-netlib/SRC/dlaed7.f index 658ece9a08..9c528added 100644 --- a/lapack-netlib/SRC/dlaed7.f +++ b/lapack-netlib/SRC/dlaed7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, * PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, * $ QSIZ, TLVLS @@ -34,7 +34,7 @@ * DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), * $ QSTORE( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLAED8. *> @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -260,10 +260,10 @@ SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, diff --git a/lapack-netlib/SRC/dlaed8.f b/lapack-netlib/SRC/dlaed8.f index 42b4ea1577..c053347b10 100644 --- a/lapack-netlib/SRC/dlaed8.f +++ b/lapack-netlib/SRC/dlaed8.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, * CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, * GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, * $ QSIZ @@ -33,7 +33,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), * $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -243,10 +243,10 @@ SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, @@ -308,8 +308,8 @@ SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, END IF * * Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 diff --git a/lapack-netlib/SRC/dlaed9.f b/lapack-netlib/SRC/dlaed9.f index 8aa0687573..d3be22502a 100644 --- a/lapack-netlib/SRC/dlaed9.f +++ b/lapack-netlib/SRC/dlaed9.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAED9 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAED9 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, * S, LDS, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N * DOUBLE PRECISION RHO @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), * $ W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -156,10 +156,10 @@ SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N diff --git a/lapack-netlib/SRC/dlaeda.f b/lapack-netlib/SRC/dlaeda.f index 749a7c365a..4ca08a0879 100644 --- a/lapack-netlib/SRC/dlaeda.f +++ b/lapack-netlib/SRC/dlaeda.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, * GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, INFO, N, TLVLS * .. @@ -29,7 +29,7 @@ * $ PRMPTR( * ), QPTR( * ) * DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -166,10 +166,10 @@ SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, INFO, N, TLVLS diff --git a/lapack-netlib/SRC/dlaein.f b/lapack-netlib/SRC/dlaein.f index d4be36c987..d35e186a1b 100644 --- a/lapack-netlib/SRC/dlaein.f +++ b/lapack-netlib/SRC/dlaein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, * LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL NOINIT, RIGHTV * INTEGER INFO, LDB, LDH, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -172,10 +172,10 @@ SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL NOINIT, RIGHTV diff --git a/lapack-netlib/SRC/dlaev2.f b/lapack-netlib/SRC/dlaev2.f index 2e333ddf2c..4906f1a20c 100644 --- a/lapack-netlib/SRC/dlaev2.f +++ b/lapack-netlib/SRC/dlaev2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -89,14 +89,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -120,10 +120,10 @@ * ===================================================================== SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 diff --git a/lapack-netlib/SRC/dlaexc.f b/lapack-netlib/SRC/dlaexc.f index ef2d66e034..fc4f4a732c 100644 --- a/lapack-netlib/SRC/dlaexc.f +++ b/lapack-netlib/SRC/dlaexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, * INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ * INTEGER INFO, J1, LDQ, LDT, N, N1, N2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -138,10 +138,10 @@ SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ diff --git a/lapack-netlib/SRC/dlag2.f b/lapack-netlib/SRC/dlag2.f index a941b940b0..7f123b2761 100644 --- a/lapack-netlib/SRC/dlag2.f +++ b/lapack-netlib/SRC/dlag2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAG2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAG2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, * WR2, WI ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB * DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,7 +99,7 @@ *> will always be positive. If the eigenvalues are real, then *> the first (real) eigenvalue is WR1 / SCALE1 , but this may *> overflow or underflow, and in fact, SCALE1 may be zero or -*> less than the underflow threshhold if the exact eigenvalue +*> less than the underflow threshold if the exact eigenvalue *> is sufficiently large. *> \endverbatim *> @@ -112,7 +112,7 @@ *> eigenvalues are real, then the second (real) eigenvalue is *> WR2 / SCALE2 , but this may overflow or underflow, and in *> fact, SCALE2 may be zero or less than the underflow -*> threshhold if the exact eigenvalue is sufficiently large. +*> threshold if the exact eigenvalue is sufficiently large. *> \endverbatim *> *> \param[out] WR1 @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleOTHERauxiliary * @@ -156,10 +156,10 @@ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB @@ -266,8 +266,8 @@ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, * Note: the test of R in the following IF is to cover the case when * DISCR is small and negative and is flushed to zero during * the calculation of R. On machines which have a consistent -* flush-to-zero threshhold and handle numbers above that -* threshhold correctly, it would not be necessary. +* flush-to-zero threshold and handle numbers above that +* threshold correctly, it would not be necessary. * IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN SUM = PP + SIGN( R, PP ) diff --git a/lapack-netlib/SRC/dlag2s.f b/lapack-netlib/SRC/dlag2s.f index 3cf27db2c1..09e2ac7718 100644 --- a/lapack-netlib/SRC/dlag2s.f +++ b/lapack-netlib/SRC/dlag2s.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAG2S + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAG2S + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. @@ -27,7 +27,7 @@ * REAL SA( LDSA, * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -39,7 +39,7 @@ *> *> RMAX is the overflow for the SINGLE PRECISION arithmetic *> DLAG2S checks that all the entries of A are between -RMAX and -*> RMAX. If not the convertion is aborted and a flag is raised. +*> RMAX. If not the conversion is aborted and a flag is raised. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDSA, M, N diff --git a/lapack-netlib/SRC/dlags2.f b/lapack-netlib/SRC/dlags2.f index 0f7cc85e28..62a8334617 100644 --- a/lapack-netlib/SRC/dlags2.f +++ b/lapack-netlib/SRC/dlags2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, * SNV, CSQ, SNQ ) -* +* * .. Scalar Arguments .. * LOGICAL UPPER * DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, * $ SNU, SNV * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -152,10 +152,10 @@ SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL UPPER diff --git a/lapack-netlib/SRC/dlagtf.f b/lapack-netlib/SRC/dlagtf.f index ba7b229689..4b257c64f3 100644 --- a/lapack-netlib/SRC/dlagtf.f +++ b/lapack-netlib/SRC/dlagtf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAGTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAGTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION LAMBDA, TOL @@ -28,7 +28,7 @@ * INTEGER IN( * ) * DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,22 +144,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/dlagtm.f b/lapack-netlib/SRC/dlagtm.f index 0908f1f2b8..bb330e8582 100644 --- a/lapack-netlib/SRC/dlagtm.f +++ b/lapack-netlib/SRC/dlagtm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAGTM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAGTM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -145,10 +145,10 @@ SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dlagts.f b/lapack-netlib/SRC/dlagts.f index 8eb28ff0d8..926075827b 100644 --- a/lapack-netlib/SRC/dlagts.f +++ b/lapack-netlib/SRC/dlagts.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAGTS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAGTS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, JOB, N * DOUBLE PRECISION TOL @@ -28,7 +28,7 @@ * INTEGER IN( * ) * DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,22 +149,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, JOB, N diff --git a/lapack-netlib/SRC/dlagv2.f b/lapack-netlib/SRC/dlagv2.f index f52801fff0..16c608204a 100644 --- a/lapack-netlib/SRC/dlagv2.f +++ b/lapack-netlib/SRC/dlagv2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAGV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAGV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, * CSR, SNR ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB * DOUBLE PRECISION CSL, CSR, SNL, SNR @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), * $ B( LDB, * ), BETA( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -157,10 +157,10 @@ SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB diff --git a/lapack-netlib/SRC/dlahqr.f b/lapack-netlib/SRC/dlahqr.f index 48033d84bc..f7365d21ee 100644 --- a/lapack-netlib/SRC/dlahqr.f +++ b/lapack-netlib/SRC/dlahqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAHQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -178,12 +178,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -207,10 +207,10 @@ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N @@ -292,7 +292,7 @@ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * * ITMAX is the total number of QR iterations allowed. * - ITMAX = 30 * MAX( 10, NH ) + ITMAX = 30 * MAX( 10, NH ) * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works diff --git a/lapack-netlib/SRC/dlahr2.f b/lapack-netlib/SRC/dlahr2.f index 9d15979c0e..beb9795bea 100644 --- a/lapack-netlib/SRC/dlahr2.f +++ b/lapack-netlib/SRC/dlahr2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAHR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -198,7 +198,7 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Parameters .. DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, + PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. @@ -240,31 +240,31 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * w := V1**T * b1 * CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL DTRMV( 'Lower', 'Transpose', 'UNIT', + CALL DTRMV( 'Lower', 'Transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**T * b2 * - CALL DGEMV( 'Transpose', N-K-I+1, I-1, + CALL DGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**T * w * - CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', + CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * - CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * - CALL DTRMV( 'Lower', 'NO TRANSPOSE', + CALL DTRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) @@ -282,13 +282,13 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Compute Y(K+1:N,I) * - CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-K-I+1, I-1, + CALL DGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) @@ -296,7 +296,7 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute T(1:I,I) * CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) @@ -307,15 +307,15 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute Y(1:K,1:NB) * CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) - $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) - CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * diff --git a/lapack-netlib/SRC/dlaic1.f b/lapack-netlib/SRC/dlaic1.f index e5841c3b30..e9dc0835ef 100644 --- a/lapack-netlib/SRC/dlaic1.f +++ b/lapack-netlib/SRC/dlaic1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAIC1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAIC1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) -* +* * .. Scalar Arguments .. * INTEGER J, JOB * DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION W( J ), X( J ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER J, JOB diff --git a/lapack-netlib/SRC/dlaisnan.f b/lapack-netlib/SRC/dlaisnan.f index 58595c5c33..4b5ebb4f54 100644 --- a/lapack-netlib/SRC/dlaisnan.f +++ b/lapack-netlib/SRC/dlaisnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION DIN1, DIN2 * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION DIN1, DIN2 diff --git a/lapack-netlib/SRC/dlaln2.f b/lapack-netlib/SRC/dlaln2.f index 23629b7f19..a094b737bd 100644 --- a/lapack-netlib/SRC/dlaln2.f +++ b/lapack-netlib/SRC/dlaln2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLALN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLALN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, * LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LTRANS * INTEGER INFO, LDA, LDB, LDX, NA, NW @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,7 +127,7 @@ *> \param[in] D2 *> \verbatim *> D2 is DOUBLE PRECISION -*> The 2,2 element in the diagonal matrix D. Not used if NW=1. +*> The 2,2 element in the diagonal matrix D. Not used if NA=1. *> \endverbatim *> *> \param[in] B @@ -205,12 +205,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -218,10 +218,10 @@ SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL LTRANS diff --git a/lapack-netlib/SRC/dlals0.f b/lapack-netlib/SRC/dlals0.f index e743b90ccf..d4cff166d6 100644 --- a/lapack-netlib/SRC/dlals0.f +++ b/lapack-netlib/SRC/dlals0.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLALS0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, * $ LDGNUM, NL, NR, NRHS, SQRE @@ -33,7 +33,7 @@ * $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), * $ POLES( LDGNUM, * ), WORK( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -247,12 +247,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -268,10 +268,10 @@ SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, diff --git a/lapack-netlib/SRC/dlalsa.f b/lapack-netlib/SRC/dlalsa.f index 10de07d2f1..4aef66c95c 100644 --- a/lapack-netlib/SRC/dlalsa.f +++ b/lapack-netlib/SRC/dlalsa.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLALSA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, * GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, * $ SMLSIZ @@ -36,7 +36,7 @@ * $ U( LDU, * ), VT( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -247,12 +247,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -269,10 +269,10 @@ SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, diff --git a/lapack-netlib/SRC/dlalsd.f b/lapack-netlib/SRC/dlalsd.f index 50b4d74fc4..510e0455a6 100644 --- a/lapack-netlib/SRC/dlalsd.f +++ b/lapack-netlib/SRC/dlalsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLALSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, * RANK, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlamrg.f b/lapack-netlib/SRC/dlamrg.f index 7126053e8a..de19508e45 100644 --- a/lapack-netlib/SRC/dlamrg.f +++ b/lapack-netlib/SRC/dlamrg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAMRG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAMRG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* +* * .. Scalar Arguments .. * INTEGER DTRD1, DTRD2, N1, N2 * .. @@ -27,7 +27,7 @@ * INTEGER INDEX( * ) * DOUBLE PRECISION A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> \param[in] N2 *> \verbatim *> N2 is INTEGER -*> These arguements contain the respective lengths of the two +*> These arguments contain the respective lengths of the two *> sorted lists to be merged. *> \endverbatim *> @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER DTRD1, DTRD2, N1, N2 diff --git a/lapack-netlib/SRC/dlamswlq.f b/lapack-netlib/SRC/dlamswlq.f new file mode 100644 index 0000000000..8dc6df8a56 --- /dev/null +++ b/lapack-netlib/SRC/dlamswlq.f @@ -0,0 +1,416 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMQRTS overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product of blocked +*> elementary reflectors computed by short wide LQ +*> factorization (DLASWLQ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> M >= K >= 0; +*> +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > M. +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the blocked +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DLASWLQ in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension +*> ( M * Number of blocks(CEIL(N-K/NB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,NB) * MB; +*> if SIDE = 'R', LWORK >= max(1,M) * MB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, CTR, LW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL DTPMLQT, DGEMLQT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * MB + ELSE + LW = M * MB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, MB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAMSWLQ', -INFO ) + WORK(1) = LW + RETURN + ELSE IF (LQUERY) THEN + WORK(1) = LW + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN + CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(NB-K)) + CTR = (M-K)/(NB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL DTPMLQT('L','T',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+NB) +* + CTR = CTR - 1 + CALL DTPMLQT('L','T',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1, CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:NB) +* + CALL DGEMLQT('L','T',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(NB-K)) + II=M-KK+1 + CTR = 1 + CALL DGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (I:I+NB,1:N) +* + CALL DTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(NB-K)) + CTR = (N-K)/(NB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL DTPMLQT('R','N',M , KK, K, 0, MB, A(1, II), LDA, + $ T(1,CTR *K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL DTPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL DGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(NB-K)) + CTR = 1 + II=N-KK+1 + CALL DGEMLQT('R','T',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL DTPMLQT('R','T',M , NB-K, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMLQT('R','T',M , KK, K, 0,MB, A(1,II), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of DLAMSWLQ +* + END diff --git a/lapack-netlib/SRC/dlamtsqr.f b/lapack-netlib/SRC/dlamtsqr.f new file mode 100644 index 0000000000..9ba45901b0 --- /dev/null +++ b/lapack-netlib/SRC/dlamtsqr.f @@ -0,0 +1,415 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMTSQR overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (DLATSQR) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> N >= K >= 0; +*> +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > N. (must be the same as DLATSQR) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> blockedelementary reflector H(i), for i = 1,2,...,k, as +*> returned by DLATSQR in the first k columns of +*> its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension +*> ( N * Number of blocks(CEIL(M-K/MB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If SIDE = 'L', LWORK >= max(1,N)*NB; +*> if SIDE = 'R', LWORK >= max(1,MB)*NB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL DGEMQRT, DTPMQRT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * NB + ELSE + LW = MB * NB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, NB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* +* Determine the block size if it is tall skinny or short and wide +* + IF( INFO.EQ.0) THEN + WORK(1) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAMTSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN + CALL DGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(MB-K)) + CTR = (M-K)/(MB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL DTPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA, + $ T(1,CTR*K+1),LDT , C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CTR = CTR - 1 + CALL DTPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:MB,1:N) +* + CALL DGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(MB-K)) + II=M-KK+1 + CTR = 1 + CALL DGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CALL DTPMQRT('L','T',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA, + $ T(1,CTR * K + 1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(MB-K)) + CTR = (N-K)/(MB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL DTPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL DTPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL DGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(MB-K)) + II=N-KK+1 + CTR = 1 + CALL DGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL DTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL DTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of DLAMTSQR +* + END diff --git a/lapack-netlib/SRC/dlaneg.f b/lapack-netlib/SRC/dlaneg.f index bfeb97674c..3d13d316bb 100644 --- a/lapack-netlib/SRC/dlaneg.f +++ b/lapack-netlib/SRC/dlaneg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANEG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANEG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) -* +* * .. Scalar Arguments .. * INTEGER N, R * DOUBLE PRECISION PIVMIN, SIGMA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), LLD( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,14 +99,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -118,10 +118,10 @@ * ===================================================================== INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, R diff --git a/lapack-netlib/SRC/dlangb.f b/lapack-netlib/SRC/dlangb.f index 87116ee392..078573b87a 100644 --- a/lapack-netlib/SRC/dlangb.f +++ b/lapack-netlib/SRC/dlangb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER KL, KU, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBauxiliary * @@ -124,10 +124,10 @@ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dlange.f b/lapack-netlib/SRC/dlange.f index bec815d1ef..9dbf45e818 100644 --- a/lapack-netlib/SRC/dlange.f +++ b/lapack-netlib/SRC/dlange.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dlangt.f b/lapack-netlib/SRC/dlangt.f index fb89baf8dd..c9576c0c3d 100644 --- a/lapack-netlib/SRC/dlangt.f +++ b/lapack-netlib/SRC/dlangt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANGT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANGT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -149,11 +149,11 @@ DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 - IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) + IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) $ ANORM = ABS(DL(I)) - IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) + IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) $ ANORM = ABS(D(I)) - IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) + IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) $ ANORM = ABS(DU(I)) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN @@ -164,7 +164,7 @@ DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) - TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) + TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP DO 20 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) diff --git a/lapack-netlib/SRC/dlanhs.f b/lapack-netlib/SRC/dlanhs.f index 35c0637adc..691dbc21ec 100644 --- a/lapack-netlib/SRC/dlanhs.f +++ b/lapack-netlib/SRC/dlanhs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANHS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANHS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dlansb.f b/lapack-netlib/SRC/dlansb.f index a5417f50ae..4ccf5f27e1 100644 --- a/lapack-netlib/SRC/dlansb.f +++ b/lapack-netlib/SRC/dlansb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -129,10 +129,10 @@ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/dlansf.f b/lapack-netlib/SRC/dlansf.f index cac7b02d00..d9b6c5b361 100644 --- a/lapack-netlib/SRC/dlansf.f +++ b/lapack-netlib/SRC/dlansf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANSF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANSF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, TRANSR, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), WORK( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -209,10 +209,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, TRANSR, UPLO @@ -299,7 +299,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, K - 1 DO I = 0, N - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -308,7 +308,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, N - 1 DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -320,7 +320,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, K - 1 DO I = 0, N TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -329,7 +329,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, N DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -379,7 +379,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -421,7 +421,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF @@ -459,7 +459,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -497,7 +497,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF @@ -563,7 +563,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -628,7 +628,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF @@ -701,7 +701,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -774,7 +774,7 @@ DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF diff --git a/lapack-netlib/SRC/dlansp.f b/lapack-netlib/SRC/dlansp.f index 60ed215a52..a1829db75c 100644 --- a/lapack-netlib/SRC/dlansp.f +++ b/lapack-netlib/SRC/dlansp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/dlanst.f b/lapack-netlib/SRC/dlanst.f index 213b06ada0..e952e2dd21 100644 --- a/lapack-netlib/SRC/dlanst.f +++ b/lapack-netlib/SRC/dlanst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,22 +88,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/dlansy.f b/lapack-netlib/SRC/dlansy.f index 47dae46c97..2372fce0a8 100644 --- a/lapack-netlib/SRC/dlansy.f +++ b/lapack-netlib/SRC/dlansy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/dlantb.f b/lapack-netlib/SRC/dlantb.f index 28ca46a39d..3d2bfe7e4b 100644 --- a/lapack-netlib/SRC/dlantb.f +++ b/lapack-netlib/SRC/dlantb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANTB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANTB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, * LDAB, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER K, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -140,10 +140,10 @@ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dlantp.f b/lapack-netlib/SRC/dlantp.f index ae4a669b8e..f84a9e9d7d 100644 --- a/lapack-netlib/SRC/dlantp.f +++ b/lapack-netlib/SRC/dlantp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dlantr.f b/lapack-netlib/SRC/dlantr.f index 6088e8cc9b..8585b2f689 100644 --- a/lapack-netlib/SRC/dlantr.f +++ b/lapack-netlib/SRC/dlantr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -141,10 +141,10 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dlanv2.f b/lapack-netlib/SRC/dlanv2.f index 26c6b11ec3..91fa14ff22 100644 --- a/lapack-netlib/SRC/dlanv2.f +++ b/lapack-netlib/SRC/dlanv2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLANV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLANV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN diff --git a/lapack-netlib/SRC/dlapll.f b/lapack-netlib/SRC/dlapll.f index 6c5cbed6d5..e8fb73385a 100644 --- a/lapack-netlib/SRC/dlapll.f +++ b/lapack-netlib/SRC/dlapll.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPLL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPLL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * DOUBLE PRECISION SSMIN @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/dlapmr.f b/lapack-netlib/SRC/dlapmr.f index f228c3e5d8..257eb61c76 100644 --- a/lapack-netlib/SRC/dlapmr.f +++ b/lapack-netlib/SRC/dlapmr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * DOUBLE PRECISION X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/dlapmt.f b/lapack-netlib/SRC/dlapmt.f index 9c01fbcbb6..b322e7ac52 100644 --- a/lapack-netlib/SRC/dlapmt.f +++ b/lapack-netlib/SRC/dlapmt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPMT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPMT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * DOUBLE PRECISION X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/dlapy2.f b/lapack-netlib/SRC/dlapy2.f index d43b0d5d14..3861b1d0a4 100644 --- a/lapack-netlib/SRC/dlapy2.f +++ b/lapack-netlib/SRC/dlapy2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION X, Y * .. -* +* * *> \par Purpose: * ============= @@ -51,22 +51,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y diff --git a/lapack-netlib/SRC/dlapy3.f b/lapack-netlib/SRC/dlapy3.f index 23feecc447..3bbba88875 100644 --- a/lapack-netlib/SRC/dlapy3.f +++ b/lapack-netlib/SRC/dlapy3.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAPY3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION X, Y, Z * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z diff --git a/lapack-netlib/SRC/dlaqgb.f b/lapack-netlib/SRC/dlaqgb.f index d5c2f473a1..3c9fac0d3f 100644 --- a/lapack-netlib/SRC/dlaqgb.f +++ b/lapack-netlib/SRC/dlaqgb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER KL, KU, LDAB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGBauxiliary * @@ -159,10 +159,10 @@ SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/dlaqge.f b/lapack-netlib/SRC/dlaqge.f index 6e4f039b50..a9852541a3 100644 --- a/lapack-netlib/SRC/dlaqge.f +++ b/lapack-netlib/SRC/dlaqge.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER LDA, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleGEauxiliary * @@ -142,10 +142,10 @@ SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/dlaqp2.f b/lapack-netlib/SRC/dlaqp2.f index e138aeee11..b6351e04c9 100644 --- a/lapack-netlib/SRC/dlaqp2.f +++ b/lapack-netlib/SRC/dlaqp2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -67,7 +67,7 @@ *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. -*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is *> the triangular factor obtained; the elements in block *> A(OFFSET+1:M,1:N) below the diagonal, together with the *> array TAU, represent the orthogonal matrix Q as a product of @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -142,17 +142,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET diff --git a/lapack-netlib/SRC/dlaqps.f b/lapack-netlib/SRC/dlaqps.f index 2521bf6df3..395d8e0b1a 100644 --- a/lapack-netlib/SRC/dlaqps.f +++ b/lapack-netlib/SRC/dlaqps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, * VN2, AUXV, F, LDF ) -* +* * .. Scalar Arguments .. * INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), * $ VN1( * ), VN2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -170,17 +170,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET @@ -342,9 +342,9 @@ SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * -* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) +* SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP diff --git a/lapack-netlib/SRC/dlaqr0.f b/lapack-netlib/SRC/dlaqr0.f index 2a3b1db9e3..247d4ef302 100644 --- a/lapack-netlib/SRC/dlaqr0.f +++ b/lapack-netlib/SRC/dlaqr0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -29,7 +29,7 @@ * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -243,12 +243,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -256,10 +256,10 @@ SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/dlaqr1.f b/lapack-netlib/SRC/dlaqr1.f index df4fb68b3f..acaefdeba0 100644 --- a/lapack-netlib/SRC/dlaqr1.f +++ b/lapack-netlib/SRC/dlaqr1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION SI1, SI2, SR1, SR2 * INTEGER LDH, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION SI1, SI2, SR1, SR2 diff --git a/lapack-netlib/SRC/dlaqr2.f b/lapack-netlib/SRC/dlaqr2.f index 21c2d3af87..910fdda68d 100644 --- a/lapack-netlib/SRC/dlaqr2.f +++ b/lapack-netlib/SRC/dlaqr2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -32,7 +32,7 @@ * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,7 +141,7 @@ *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -258,12 +258,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -278,10 +278,10 @@ SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/dlaqr3.f b/lapack-netlib/SRC/dlaqr3.f index aac01a49fa..8a668bc650 100644 --- a/lapack-netlib/SRC/dlaqr3.f +++ b/lapack-netlib/SRC/dlaqr3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -32,7 +32,7 @@ * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,7 +138,7 @@ *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleOTHERauxiliary * @@ -275,10 +275,10 @@ SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/dlaqr4.f b/lapack-netlib/SRC/dlaqr4.f index 6898dfafe9..89b9b7f209 100644 --- a/lapack-netlib/SRC/dlaqr4.f +++ b/lapack-netlib/SRC/dlaqr4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -29,7 +29,7 @@ * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -232,12 +232,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -263,10 +263,10 @@ SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/dlaqr5.f b/lapack-netlib/SRC/dlaqr5.f index 37ce6f6b02..8b536c08ca 100644 --- a/lapack-netlib/SRC/dlaqr5.f +++ b/lapack-netlib/SRC/dlaqr5.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQR5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, * LDU, NV, WV, LDWV, NH, WH, LDWH ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, * $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV @@ -32,7 +32,7 @@ * $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,10 +150,10 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is DOUBLE PRECISION array of size (LDZ,IHI) +*> Z is DOUBLE PRECISION array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep orthogonal *> similarity transformation is accumulated into -*> Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -231,12 +231,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleOTHERauxiliary * @@ -259,10 +259,10 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, $ LDU, NV, WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, diff --git a/lapack-netlib/SRC/dlaqsb.f b/lapack-netlib/SRC/dlaqsb.f index b15ea6bec7..3a6ef70aa3 100644 --- a/lapack-netlib/SRC/dlaqsb.f +++ b/lapack-netlib/SRC/dlaqsb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,22 +128,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/dlaqsp.f b/lapack-netlib/SRC/dlaqsp.f index 67ceb4610f..5f25d1e303 100644 --- a/lapack-netlib/SRC/dlaqsp.f +++ b/lapack-netlib/SRC/dlaqsp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,22 +113,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/dlaqsy.f b/lapack-netlib/SRC/dlaqsy.f index 83ecf8c3d0..a3ed114678 100644 --- a/lapack-netlib/SRC/dlaqsy.f +++ b/lapack-netlib/SRC/dlaqsy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,22 +121,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/dlaqtr.f b/lapack-netlib/SRC/dlaqtr.f index 189f5f87a7..71c441fa3b 100644 --- a/lapack-netlib/SRC/dlaqtr.f +++ b/lapack-netlib/SRC/dlaqtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAQTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAQTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, * INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LREAL, LTRAN * INTEGER INFO, LDT, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -165,10 +165,10 @@ SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL LREAL, LTRAN diff --git a/lapack-netlib/SRC/dlar1v.f b/lapack-netlib/SRC/dlar1v.f index 1234328b11..3fa7178cf1 100644 --- a/lapack-netlib/SRC/dlar1v.f +++ b/lapack-netlib/SRC/dlar1v.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAR1V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAR1V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, * PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, * R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) -* +* * .. Scalar Arguments .. * LOGICAL WANTNC * INTEGER B1, BN, N, NEGCNT, R @@ -34,7 +34,7 @@ * $ WORK( * ) * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -207,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -230,10 +230,10 @@ SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTNC diff --git a/lapack-netlib/SRC/dlar2v.f b/lapack-netlib/SRC/dlar2v.f index a6766baaa8..32c77bf70e 100644 --- a/lapack-netlib/SRC/dlar2v.f +++ b/lapack-netlib/SRC/dlar2v.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAR2V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAR2V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, N diff --git a/lapack-netlib/SRC/dlarf.f b/lapack-netlib/SRC/dlarf.f index 80dca69af7..e99d0bb2a9 100644 --- a/lapack-netlib/SRC/dlarf.f +++ b/lapack-netlib/SRC/dlarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/dlarfb.f b/lapack-netlib/SRC/dlarfb.f index 18ec9bfd76..5b2cc2ba80 100644 --- a/lapack-netlib/SRC/dlarfb.f +++ b/lapack-netlib/SRC/dlarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, * T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,10 +154,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date June 2013 * @@ -195,7 +195,7 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * June 2013 diff --git a/lapack-netlib/SRC/dlarfg.f b/lapack-netlib/SRC/dlarfg.f index ce91d33c1a..cb177a5703 100644 --- a/lapack-netlib/SRC/dlarfg.f +++ b/lapack-netlib/SRC/dlarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/dlarfgp.f b/lapack-netlib/SRC/dlarfgp.f index 0f5f49a8e3..c05f837ea2 100644 --- a/lapack-netlib/SRC/dlarfgp.f +++ b/lapack-netlib/SRC/dlarfgp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N @@ -203,7 +203,7 @@ SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) IF ( ABS(TAU).LE.SMLNUM ) THEN * * In the case where the computed TAU ends up being a denormalized number, -* it loses relative accuracy. This is a BIG problem. Solution: flush TAU +* it loses relative accuracy. This is a BIG problem. Solution: flush TAU * to ZERO. This explains the next IF statement. * * (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) @@ -219,7 +219,7 @@ SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) BETA = -SAVEALPHA END IF * - ELSE + ELSE * * This is the general case. * diff --git a/lapack-netlib/SRC/dlarft.f b/lapack-netlib/SRC/dlarft.f index bc1b53b2ce..e69a6b792e 100644 --- a/lapack-netlib/SRC/dlarft.f +++ b/lapack-netlib/SRC/dlarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -221,13 +221,13 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) * - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, + CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, $ T( 1, I ), 1 ) ELSE * Skip any trailing zeros. @@ -236,7 +236,7 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T @@ -280,7 +280,7 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) @@ -295,7 +295,7 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T diff --git a/lapack-netlib/SRC/dlarfx.f b/lapack-netlib/SRC/dlarfx.f index 47491dc6be..260d367d48 100644 --- a/lapack-netlib/SRC/dlarfx.f +++ b/lapack-netlib/SRC/dlarfx.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/dlarfy.f b/lapack-netlib/SRC/dlarfy.f new file mode 100644 index 0000000000..a0b0ebb31b --- /dev/null +++ b/lapack-netlib/SRC/dlarfy.f @@ -0,0 +1,161 @@ +*> \brief \b DLARFY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFY applies an elementary reflector, or Householder matrix, H, +*> to an n x n symmetric matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER INCV, LDC, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSYMV, DSYR2 +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV ) + CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of DLARFY +* + END diff --git a/lapack-netlib/SRC/dlargv.f b/lapack-netlib/SRC/dlargv.f index 9ef68f244c..f28bcecd3f 100644 --- a/lapack-netlib/SRC/dlargv.f +++ b/lapack-netlib/SRC/dlargv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/dlarnv.f b/lapack-netlib/SRC/dlarnv.f index 04af112aea..02e62bc6ff 100644 --- a/lapack-netlib/SRC/dlarnv.f +++ b/lapack-netlib/SRC/dlarnv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARNV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARNV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARNV( IDIST, ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,14 +74,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -97,10 +97,10 @@ * ===================================================================== SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, N diff --git a/lapack-netlib/SRC/dlarra.f b/lapack-netlib/SRC/dlarra.f index c78e8d01fd..31a0bfbbc6 100644 --- a/lapack-netlib/SRC/dlarra.f +++ b/lapack-netlib/SRC/dlarra.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, * NSPLIT, ISPLIT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N, NSPLIT * DOUBLE PRECISION SPLTOL, TNRM @@ -29,7 +29,7 @@ * INTEGER ISPLIT( * ) * DOUBLE PRECISION D( * ), E( * ), E2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,14 +114,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -136,10 +136,10 @@ SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, $ NSPLIT, ISPLIT, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N, NSPLIT diff --git a/lapack-netlib/SRC/dlarrb.f b/lapack-netlib/SRC/dlarrb.f index f02c6d1d13..2733922f08 100644 --- a/lapack-netlib/SRC/dlarrb.f +++ b/lapack-netlib/SRC/dlarrb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, * RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, * PIVMIN, SPDIAM, TWIST, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST * DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), LLD( * ), W( * ), * $ WERR( * ), WGAP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are -*> estimates of the eigenvalues of L D L^T indexed IFIRST throug +*> estimates of the eigenvalues of L D L^T indexed IFIRST through *> ILAST. *> On output, these estimates are refined. *> \endverbatim @@ -173,14 +173,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -196,10 +196,10 @@ SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, TWIST, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST diff --git a/lapack-netlib/SRC/dlarrc.f b/lapack-netlib/SRC/dlarrc.f index f093563e9f..9635e41225 100644 --- a/lapack-netlib/SRC/dlarrc.f +++ b/lapack-netlib/SRC/dlarrc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, * EIGCNT, LCNT, RCNT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBT * INTEGER EIGCNT, INFO, LCNT, N, RCNT @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,12 +60,13 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> The lower bound for the eigenvalues. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> The lower and upper bounds for the eigenvalues. +*> The upper bound for the eigenvalues. *> \endverbatim *> *> \param[in] D @@ -114,14 +115,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -136,10 +137,10 @@ SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, $ EIGCNT, LCNT, RCNT, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBT diff --git a/lapack-netlib/SRC/dlarrd.f b/lapack-netlib/SRC/dlarrd.f index 65cdbe96e4..57abf74365 100644 --- a/lapack-netlib/SRC/dlarrd.f +++ b/lapack-netlib/SRC/dlarrd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, * M, W, WERR, WL, WU, IBLOCK, INDEXW, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -34,7 +34,7 @@ * DOUBLE PRECISION D( * ), E( * ), E2( * ), * $ GERS( * ), W( * ), WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,16 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. @@ -106,13 +110,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -306,14 +314,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, @@ -321,10 +329,10 @@ SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, $ M, W, WERR, WL, WU, IBLOCK, INDEXW, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE diff --git a/lapack-netlib/SRC/dlarre.f b/lapack-netlib/SRC/dlarre.f index e7eea10c6e..f01b25f166 100644 --- a/lapack-netlib/SRC/dlarre.f +++ b/lapack-netlib/SRC/dlarre.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, * W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -34,7 +34,7 @@ * DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), * $ W( * ),WERR( * ), WGAP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,17 @@ *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound for the eigenvalues. +*> Eigenvalues less than or equal to VL, or greater than VU, +*> will not be returned. VL < VU. +*> If RANGE='I' or ='A', DLARRE computes bounds on the desired +*> part of the spectrum. *> \endverbatim *> *> \param[in,out] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds for the eigenvalues. +*> If RANGE='V', the upper bound for the eigenvalues. *> Eigenvalues less than or equal to VL, or greater than VU, *> will not be returned. VL < VU. *> If RANGE='I' or ='A', DLARRE computes bounds on the desired @@ -93,13 +98,16 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N. *> \endverbatim *> @@ -244,7 +252,7 @@ *> \verbatim *> INFO is INTEGER *> = 0: successful exit -*> > 0: A problem occured in DLARRE. +*> > 0: A problem occurred in DLARRE. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -263,14 +271,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -297,10 +305,10 @@ SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER RANGE diff --git a/lapack-netlib/SRC/dlarrf.f b/lapack-netlib/SRC/dlarrf.f index f054caa8c9..5ad4337ad1 100644 --- a/lapack-netlib/SRC/dlarrf.f +++ b/lapack-netlib/SRC/dlarrf.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * W, WGAP, WERR, * SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, * DPLUS, LPLUS, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CLSTRT, CLEND, INFO, N * DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), * $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -51,7 +51,7 @@ *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix (subblock, if the matrix splitted). +*> The order of the matrix (subblock, if the matrix split). *> \endverbatim *> *> \param[in] D @@ -169,14 +169,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -193,10 +193,10 @@ SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, $ DPLUS, LPLUS, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER CLSTRT, CLEND, INFO, N diff --git a/lapack-netlib/SRC/dlarrj.f b/lapack-netlib/SRC/dlarrj.f index 7fb5cbf413..ecd136f42b 100644 --- a/lapack-netlib/SRC/dlarrj.f +++ b/lapack-netlib/SRC/dlarrj.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, * RTOL, OFFSET, W, WERR, WORK, IWORK, * PIVMIN, SPDIAM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET * DOUBLE PRECISION PIVMIN, RTOL, SPDIAM @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), E2( * ), W( * ), * $ WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,14 +145,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -168,10 +168,10 @@ SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, $ RTOL, OFFSET, W, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET diff --git a/lapack-netlib/SRC/dlarrk.f b/lapack-netlib/SRC/dlarrk.f index c649cc95ac..8b307a4933 100644 --- a/lapack-netlib/SRC/dlarrk.f +++ b/lapack-netlib/SRC/dlarrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRK( N, IW, GL, GU, * D, E2, PIVMIN, RELTOL, W, WERR, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, IW, N * DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,23 +132,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARRK( N, IW, GL, GU, $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, IW, N diff --git a/lapack-netlib/SRC/dlarrr.f b/lapack-netlib/SRC/dlarrr.f index add58e6025..c12b605854 100644 --- a/lapack-netlib/SRC/dlarrr.f +++ b/lapack-netlib/SRC/dlarrr.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRR( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER N, INFO * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -94,10 +94,10 @@ * ===================================================================== SUBROUTINE DLARRR( N, D, E, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, INFO diff --git a/lapack-netlib/SRC/dlarrv.f b/lapack-netlib/SRC/dlarrv.f index 828661f2c0..edda67d7db 100644 --- a/lapack-netlib/SRC/dlarrv.f +++ b/lapack-netlib/SRC/dlarrv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARRV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARRV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RTOL1, RTOL2, W, WERR, WGAP, * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER DOL, DOU, INFO, LDZ, M, N * DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU @@ -35,7 +35,7 @@ * $ WGAP( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,12 +59,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> Lower bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> Lower and upper bounds of the interval that contains the desired +*> Upper bound of the interval that contains the desired *> eigenvalues. VL < VU. Needed to compute gaps on the left or right *> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim @@ -81,7 +84,7 @@ *> L is DOUBLE PRECISION array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the unit *> bidiagonal matrix L are in elements 1 to N-1 of L -*> (if the matrix is not splitted.) At the end of each block +*> (if the matrix is not split.) At the end of each block *> is stored the corresponding shift as given by DLARRE. *> On exit, L is overwritten. *> \endverbatim @@ -236,7 +239,7 @@ *> INFO is INTEGER *> = 0: successful exit *> -*> > 0: A problem occured in DLARRV. +*> > 0: A problem occurred in DLARRV. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -258,12 +261,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHERauxiliary * @@ -283,10 +286,10 @@ SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER DOL, DOU, INFO, LDZ, M, N diff --git a/lapack-netlib/SRC/dlarscl2.f b/lapack-netlib/SRC/dlarscl2.f index 81f5aa8139..1b5ea53841 100644 --- a/lapack-netlib/SRC/dlarscl2.f +++ b/lapack-netlib/SRC/dlarscl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARSCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARSCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,28 +72,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/dlartg.f b/lapack-netlib/SRC/dlartg.f index bf74c4365c..1c7c46f638 100644 --- a/lapack-netlib/SRC/dlartg.f +++ b/lapack-netlib/SRC/dlartg.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN diff --git a/lapack-netlib/SRC/dlartgp.f b/lapack-netlib/SRC/dlartgp.f index 3f947a84a6..0cb0d2d13f 100644 --- a/lapack-netlib/SRC/dlartgp.f +++ b/lapack-netlib/SRC/dlartgp.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARTGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARTGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTGP( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTGP( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN diff --git a/lapack-netlib/SRC/dlartgs.f b/lapack-netlib/SRC/dlartgs.f index 5a821a2559..a83e74d377 100644 --- a/lapack-netlib/SRC/dlartgs.f +++ b/lapack-netlib/SRC/dlartgs.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARTGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARTGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS, SIGMA, SN, X, Y * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, SIGMA, SN, X, Y diff --git a/lapack-netlib/SRC/dlartv.f b/lapack-netlib/SRC/dlartv.f index f9aa2ae1e9..dca1cb7dcc 100644 --- a/lapack-netlib/SRC/dlartv.f +++ b/lapack-netlib/SRC/dlartv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARTV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARTV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/dlaruv.f b/lapack-netlib/SRC/dlaruv.f index d9012c6509..a903c186cb 100644 --- a/lapack-netlib/SRC/dlaruv.f +++ b/lapack-netlib/SRC/dlaruv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARUV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARUV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARUV( ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( N ) * .. -* +* * *> \par Purpose: * ============= @@ -67,14 +67,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -95,10 +95,10 @@ * ===================================================================== SUBROUTINE DLARUV( ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N @@ -392,7 +392,7 @@ SUBROUTINE DLARUV( ISEED, N, X ) I4 = ISEED( 4 ) * DO 10 I = 1, MIN( N, LV ) -* +* 20 CONTINUE * * Multiply the seed by i-th power of the multiplier modulo 2**48 @@ -419,11 +419,11 @@ SUBROUTINE DLARUV( ISEED, N, X ) * If a real number has n bits of precision, and the first * n bits of the 48-bit integer above happen to be all 1 (which * will occur about once every 2**n calls), then X( I ) will -* be rounded to exactly 1.0. +* be rounded to exactly 1.0. * Since X( I ) is not supposed to return exactly 0.0 or 1.0, * the statistically correct thing to do in this situation is * simply to iterate again. -* N.B. the case X( I ) = 0.0 should not be possible. +* N.B. the case X( I ) = 0.0 should not be possible. I1 = I1 + 2 I2 = I2 + 2 I3 = I3 + 2 diff --git a/lapack-netlib/SRC/dlarz.f b/lapack-netlib/SRC/dlarz.f index 08a57ecc7d..73dc3f50df 100644 --- a/lapack-netlib/SRC/dlarz.f +++ b/lapack-netlib/SRC/dlarz.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, L, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/dlarzb.f b/lapack-netlib/SRC/dlarzb.f index 93c1bd182c..e34eef937f 100644 --- a/lapack-netlib/SRC/dlarzb.f +++ b/lapack-netlib/SRC/dlarzb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARZB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARZB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * LDV, T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -183,10 +183,10 @@ SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff --git a/lapack-netlib/SRC/dlarzt.f b/lapack-netlib/SRC/dlarzt.f index f76c593f3f..5925569108 100644 --- a/lapack-netlib/SRC/dlarzt.f +++ b/lapack-netlib/SRC/dlarzt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARZT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARZT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff --git a/lapack-netlib/SRC/dlas2.f b/lapack-netlib/SRC/dlas2.f index 81077f940d..83873bc612 100644 --- a/lapack-netlib/SRC/dlas2.f +++ b/lapack-netlib/SRC/dlas2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION F, G, H, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -107,10 +107,10 @@ * ===================================================================== SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN diff --git a/lapack-netlib/SRC/dlascl.f b/lapack-netlib/SRC/dlascl.f index 9b9b33c0c1..03e1000a87 100644 --- a/lapack-netlib/SRC/dlascl.f +++ b/lapack-netlib/SRC/dlascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lapack-netlib/SRC/dlascl2.f b/lapack-netlib/SRC/dlascl2.f index 8cd9dd72c8..ae88075305 100644 --- a/lapack-netlib/SRC/dlascl2.f +++ b/lapack-netlib/SRC/dlascl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,28 +72,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/dlasd0.f b/lapack-netlib/SRC/dlasd0.f index 7d7a681019..ca0b3b98c6 100644 --- a/lapack-netlib/SRC/dlasd0.f +++ b/lapack-netlib/SRC/dlasd0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, * WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,7 +72,7 @@ *> On exit D, if INFO = 0, contains its singular values. *> \endverbatim *> -*> \param[in] E +*> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (M-1) *> Contains the subdiagonal entries of the bidiagonal matrix. @@ -133,14 +133,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -152,10 +152,10 @@ SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, $ WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE diff --git a/lapack-netlib/SRC/dlasd1.f b/lapack-netlib/SRC/dlasd1.f index 7b66d90b22..fe8aad9597 100644 --- a/lapack-netlib/SRC/dlasd1.f +++ b/lapack-netlib/SRC/dlasd1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, * IDXQ, IWORK, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, NL, NR, SQRE * DOUBLE PRECISION ALPHA, BETA @@ -29,7 +29,7 @@ * INTEGER IDXQ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or when there are zeros in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLASD2. *> @@ -156,7 +156,7 @@ *> The leading dimension of the array VT. LDVT >= max( 1, M ). *> \endverbatim *> -*> \param[out] IDXQ +*> \param[in,out] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension(N) *> This contains the permutation which will reintegrate the @@ -185,14 +185,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -204,10 +204,10 @@ SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, $ IDXQ, IWORK, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, NL, NR, SQRE diff --git a/lapack-netlib/SRC/dlasd2.f b/lapack-netlib/SRC/dlasd2.f index 074449c3d1..a7ced418f7 100644 --- a/lapack-netlib/SRC/dlasd2.f +++ b/lapack-netlib/SRC/dlasd2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, * LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, * IDXC, IDXQ, COLTYP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE * DOUBLE PRECISION ALPHA, BETA @@ -33,7 +33,7 @@ * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -249,14 +249,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -269,10 +269,10 @@ SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE diff --git a/lapack-netlib/SRC/dlasd3.f b/lapack-netlib/SRC/dlasd3.f index 89aae6bbb0..57d0abd4cd 100644 --- a/lapack-netlib/SRC/dlasd3.f +++ b/lapack-netlib/SRC/dlasd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, * LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, * $ SQRE @@ -32,7 +32,7 @@ * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -205,14 +205,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -225,10 +225,10 @@ SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, diff --git a/lapack-netlib/SRC/dlasd4.f b/lapack-netlib/SRC/dlasd4.f index 71b6f7925a..8b4a8762c8 100644 --- a/lapack-netlib/SRC/dlasd4.f +++ b/lapack-netlib/SRC/dlasd4.f @@ -140,9 +140,9 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N @@ -331,7 +331,7 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -400,7 +400,7 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -470,7 +470,7 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -622,8 +622,8 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = W + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * * Test for convergence @@ -703,7 +703,7 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * IF( INFO.NE.0 ) THEN * -* If INFO is not 0, i.e., DLAED6 failed, switch back +* If INFO is not 0, i.e., DLAED6 failed, switch back * to 2 pole interpolation. * SWTCH3 = .FALSE. @@ -803,8 +803,8 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * SWTCH = .FALSE. @@ -922,7 +922,7 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * IF( INFO.NE.0 ) THEN * -* If INFO is not 0, i.e., DLAED6 failed, switch +* If INFO is not 0, i.e., DLAED6 failed, switch * back to two pole interpolation * SWTCH3 = .FALSE. @@ -1038,8 +1038,8 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) diff --git a/lapack-netlib/SRC/dlasd5.f b/lapack-netlib/SRC/dlasd5.f index a1b4cd1f08..4896ba6b97 100644 --- a/lapack-netlib/SRC/dlasd5.f +++ b/lapack-netlib/SRC/dlasd5.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) -* +* * .. Scalar Arguments .. * INTEGER I * DOUBLE PRECISION DSIGMA, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -98,14 +98,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -116,10 +116,10 @@ * ===================================================================== SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I diff --git a/lapack-netlib/SRC/dlasd6.f b/lapack-netlib/SRC/dlasd6.f index a5238b919c..5cab78a070 100644 --- a/lapack-netlib/SRC/dlasd6.f +++ b/lapack-netlib/SRC/dlasd6.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, * LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE @@ -35,7 +35,7 @@ * $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), * $ VF( * ), VL( * ), WORK( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,7 +74,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or if there is a zero -*> in the Z vector. For each such occurence the dimension of the +*> in the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLASD7. *> @@ -232,14 +232,13 @@ *> \param[out] DIFR *> \verbatim *> DIFR is DOUBLE PRECISION array, -*> dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and -*> dimension ( N ) if ICOMPQ = 0. -*> On exit, DIFR(I, 1) is the distance between I-th updated -*> (undeflated) singular value and the I+1-th (undeflated) old -*> singular value. +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. *> -*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the -*> normalizing factors for the right singular vector matrix. +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. *> *> See DLASD8 for details on DIFL and DIFR. *> \endverbatim @@ -293,14 +292,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -314,10 +313,10 @@ SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, diff --git a/lapack-netlib/SRC/dlasd7.f b/lapack-netlib/SRC/dlasd7.f index bca613d2fb..e0ddedeb57 100644 --- a/lapack-netlib/SRC/dlasd7.f +++ b/lapack-netlib/SRC/dlasd7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * C, S, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE @@ -35,7 +35,7 @@ * $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), * $ ZW( * ) * .. -* +* * *> \par Purpose: * ============= @@ -259,14 +259,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -280,10 +280,10 @@ SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ C, S, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, diff --git a/lapack-netlib/SRC/dlasd8.f b/lapack-netlib/SRC/dlasd8.f index 2b7143f779..245e814a15 100644 --- a/lapack-netlib/SRC/dlasd8.f +++ b/lapack-netlib/SRC/dlasd8.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASD8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASD8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, * DSIGMA, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, K, LDDIFR * .. @@ -29,7 +29,7 @@ * $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,14 +147,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -166,10 +166,10 @@ SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, $ DSIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, K, LDDIFR diff --git a/lapack-netlib/SRC/dlasda.f b/lapack-netlib/SRC/dlasda.f index bb67904935..20ceedd0be 100644 --- a/lapack-netlib/SRC/dlasda.f +++ b/lapack-netlib/SRC/dlasda.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, * DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, * PERM, GIVNUM, C, S, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE * .. @@ -33,7 +33,7 @@ * $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -254,14 +254,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -274,10 +274,10 @@ SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE diff --git a/lapack-netlib/SRC/dlasdq.f b/lapack-netlib/SRC/dlasdq.f index 6beef32ac6..e7d3575a98 100644 --- a/lapack-netlib/SRC/dlasdq.f +++ b/lapack-netlib/SRC/dlasdq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASDQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASDQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, * U, LDU, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the input bidiagonal matrix -*> is upper or lower bidiagonal, and wether it is square are +*> is upper or lower bidiagonal, and whether it is square are *> not. *> UPLO = 'U' or 'u' B is upper bidiagonal. *> UPLO = 'L' or 'l' B is lower bidiagonal. @@ -192,14 +192,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -211,10 +211,10 @@ SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, $ U, LDU, C, LDC, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlasdt.f b/lapack-netlib/SRC/dlasdt.f index 988b3ad501..37da2d035e 100644 --- a/lapack-netlib/SRC/dlasdt.f +++ b/lapack-netlib/SRC/dlasdt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASDT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASDT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) -* +* * .. Scalar Arguments .. * INTEGER LVL, MSUB, N, ND * .. * .. Array Arguments .. * INTEGER INODE( * ), NDIML( * ), NDIMR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,14 +87,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -105,10 +105,10 @@ * ===================================================================== SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LVL, MSUB, N, ND diff --git a/lapack-netlib/SRC/dlaset.f b/lapack-netlib/SRC/dlaset.f index d3bb9456e7..3a0c469a3c 100644 --- a/lapack-netlib/SRC/dlaset.f +++ b/lapack-netlib/SRC/dlaset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlasq1.f b/lapack-netlib/SRC/dlasq1.f index 0bbc221ec0..468676eebd 100644 --- a/lapack-netlib/SRC/dlasq1.f +++ b/lapack-netlib/SRC/dlasq1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,29 +89,29 @@ *> represent a matrix with the same singular values *> which the calling subroutine could use to finish the *> computation, or even feed back into DLASQ1 -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -189,7 +189,7 @@ SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, $ IINFO ) -* +* * Compute the q's and e's. * DO 30 I = 1, 2*N - 1 diff --git a/lapack-netlib/SRC/dlasq2.f b/lapack-netlib/SRC/dlasq2.f index df1690d020..68d9228704 100644 --- a/lapack-netlib/SRC/dlasq2.f +++ b/lapack-netlib/SRC/dlasq2.f @@ -2,38 +2,38 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ2( N, Z, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DLASQ2 computes all the eigenvalues of the symmetric positive +*> DLASQ2 computes all the eigenvalues of the symmetric positive *> definite tridiagonal matrix associated with the qd array Z to high *> relative accuracy are computed to high relative accuracy, in the *> absence of denormalization, underflow and overflow. @@ -83,19 +83,19 @@ *> = 2, current block of Z not diagonalized after 100*N *> iterations (in inner while loop). On exit Z holds *> a qd array with the same eigenvalues as the given Z. -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -112,10 +112,10 @@ * ===================================================================== SUBROUTINE DLASQ2( N, Z, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -136,7 +136,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, - $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, + $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, $ TTYPE DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, @@ -155,7 +155,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. -* +* * Test the input arguments. * (in case DLASQ2 is not called by DLASQ1) * @@ -195,7 +195,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) END IF Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN - T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) + T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) S = Z( 3 )*( Z( 2 ) / T ) IF( S.LE.T ) THEN S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) @@ -264,19 +264,19 @@ SUBROUTINE DLASQ2( N, Z, INFO ) Z( 2*N-1 ) = ZERO RETURN END IF -* +* * Check whether the machine is IEEE conformable. -* +* IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. - $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 -* + $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) + Z( 2*K ) = ZERO + Z( 2*K-1 ) = Z( K ) + Z( 2*K-2 ) = ZERO + Z( 2*K-3 ) = Z( K-1 ) 30 CONTINUE * I0 = 1 @@ -333,7 +333,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) END IF EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE + 60 CONTINUE Z( 4*N0-PP-2 ) = D * * Now find qmax. @@ -364,14 +364,14 @@ SUBROUTINE DLASQ2( N, Z, INFO ) NDIV = 2*( N0-I0 ) * DO 160 IWHILA = 1, N + 1 - IF( N0.LT.1 ) + IF( N0.LT.1 ) $ GO TO 170 * -* While array unfinished do +* While array unfinished do * * E(N0) holds the value of SIGMA when submatrix in I0:N0 * splits from the rest of the array, but is negated. -* +* DESIG = ZERO IF( N0.EQ.N ) THEN SIGMA = ZERO @@ -386,7 +386,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * Find last unreduced submatrix's top index I0, find QMAX and * EMIN. Find Gershgorin-type bound if Q's much greater than E's. * - EMAX = ZERO + EMAX = ZERO IF( N0.GT.I0 ) THEN EMIN = ABS( Z( 4*N0-5 ) ) ELSE @@ -404,7 +404,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) EMIN = MIN( EMIN, Z( I4-5 ) ) 90 CONTINUE - I4 = 4 + I4 = 4 * 100 CONTINUE I0 = I4 / 4 @@ -421,7 +421,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) KMIN = ( I4+3 )/4 END IF 110 CONTINUE - IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN IPN4 = 4*( I0+N0 ) PP = 2 @@ -446,15 +446,15 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * -* Now I0:N0 is unreduced. +* Now I0:N0 is unreduced. * PP = 0 for ping, PP = 1 for pong. * PP = 2 indicates that flipping was applied to the Z array and -* and that the tests for deflation upon entry in DLASQ3 +* and that the tests for deflation upon entry in DLASQ3 * should not be performed. * NBIG = 100*( N0-I0+1 ) DO 140 IWHILB = 1, NBIG - IF( I0.GT.N0 ) + IF( I0.GT.N0 ) $ GO TO 150 * * While submatrix unfinished take a good dqds step. @@ -497,8 +497,8 @@ SUBROUTINE DLASQ2( N, Z, INFO ) 140 CONTINUE * INFO = 2 -* -* Maximum number of iterations exceeded, restore the shift +* +* Maximum number of iterations exceeded, restore the shift * SIGMA and place the new d's and e's in a qd array. * This might need to be done for several blocks * @@ -549,16 +549,16 @@ SUBROUTINE DLASQ2( N, Z, INFO ) INFO = 3 RETURN * -* end IWHILA +* end IWHILA * 170 CONTINUE -* +* * Move q's to the front. -* +* DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) 180 CONTINUE -* +* * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) @@ -570,7 +570,7 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * * Store trace, sum(eigenvalues) and information on performance. * - Z( 2*N+1 ) = TRACE + Z( 2*N+1 ) = TRACE Z( 2*N+2 ) = E Z( 2*N+3 ) = DBLE( ITER ) Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) diff --git a/lapack-netlib/SRC/dlasq3.f b/lapack-netlib/SRC/dlasq3.f index 4506e19f21..c095bdbbb5 100644 --- a/lapack-netlib/SRC/dlasq3.f +++ b/lapack-netlib/SRC/dlasq3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, * DN2, G, TAU ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, ITER, N0, NDIV, NFAIL, PP @@ -31,7 +31,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -68,8 +68,8 @@ *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. -*> PP=2 indicates that flipping was applied to the Z array -*> and that the initial tests for deflation should not be +*> PP=2 indicates that flipping was applied to the Z array +*> and that the initial tests for deflation should not be *> performed. *> \endverbatim *> @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, G, TAU ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. LOGICAL IEEE @@ -286,7 +286,7 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, GO TO 10 * 50 CONTINUE - IF( PP.EQ.2 ) + IF( PP.EQ.2 ) $ PP = 0 * * Reverse the qd-array, if warranted. @@ -345,7 +345,7 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * GO TO 90 * - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. $ ABS( DN ).LT.TOL*SIGMA ) THEN * @@ -389,7 +389,7 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, GO TO 70 END IF ELSE -* +* * Possible underflow. Play it safe. * GO TO 80 diff --git a/lapack-netlib/SRC/dlasq4.f b/lapack-netlib/SRC/dlasq4.f index 97d9bdeba3..cb7a714cc6 100644 --- a/lapack-netlib/SRC/dlasq4.f +++ b/lapack-netlib/SRC/dlasq4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * DN1, DN2, TAU, TTYPE, G ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, N0IN, PP, TTYPE * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,7 +56,7 @@ *> *> \param[in] Z *> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) +*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -122,7 +122,7 @@ *> *> \param[in,out] G *> \verbatim -*> G is REAL +*> G is DOUBLE PRECISION *> G is passed as an argument in order to save its value between *> calls to DLASQ4. *> \endverbatim @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -151,10 +151,10 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE, G ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE @@ -192,7 +192,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, TTYPE = -1 RETURN END IF -* +* NN = 4*N0 + PP IF( N0IN.EQ.N0 ) THEN * @@ -262,7 +262,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 20 10 CONTINUE 20 CONTINUE @@ -303,7 +303,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 40 30 CONTINUE 40 CONTINUE @@ -331,7 +331,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. * - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN * * Cases 7 and 8. * @@ -349,7 +349,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) $ GO TO 60 50 CONTINUE 60 CONTINUE @@ -358,7 +358,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, GAP2 = HALF*DMIN2 - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) TTYPE = -8 END IF @@ -378,7 +378,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * Cases 10 and 11. * - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN TTYPE = -10 S = THIRD*DMIN2 IF( Z( NN-5 ).GT.Z( NN-7 ) ) @@ -402,7 +402,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) END IF ELSE @@ -413,7 +413,7 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * Case 12, more than two eigenvalues deflated. No information. * - S = ZERO + S = ZERO TTYPE = -12 END IF * diff --git a/lapack-netlib/SRC/dlasq5.f b/lapack-netlib/SRC/dlasq5.f index cdd8cf1ae3..99d4f678eb 100644 --- a/lapack-netlib/SRC/dlasq5.f +++ b/lapack-netlib/SRC/dlasq5.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2, IEEE, EPS ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, N0, PP @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -144,10 +144,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, $ DN, DNM1, DNM2, IEEE, EPS ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL IEEE @@ -181,7 +181,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO IF( TAU.NE.ZERO ) THEN J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) @@ -192,7 +192,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -201,7 +201,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -210,7 +210,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN @@ -235,10 +235,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, * IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF @@ -247,10 +247,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF @@ -259,7 +259,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 40 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN @@ -290,17 +290,17 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, ELSE * This is the version that sets d's to zero if they are small enough J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) IF( IEEE ) THEN -* +* * Code for IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 50 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO @@ -310,7 +310,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 50 CONTINUE ELSE DO 60 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO @@ -319,9 +319,9 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( Z( J4-1 ), EMIN ) 60 CONTINUE END IF -* -* Unroll last two steps. -* +* +* Unroll last two steps. +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -330,7 +330,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -338,17 +338,17 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) -* +* ELSE -* +* * Code for non IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 70 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF @@ -358,10 +358,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 70 CONTINUE ELSE DO 80 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF @@ -370,9 +370,9 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( EMIN, Z( J4-1 ) ) 80 CONTINUE END IF -* -* Unroll last two steps. -* +* +* Unroll last two steps. +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -385,7 +385,7 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -397,10 +397,10 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) -* +* END IF END IF -* +* Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN diff --git a/lapack-netlib/SRC/dlasq6.f b/lapack-netlib/SRC/dlasq6.f index 3c8661bbba..d871386bdb 100644 --- a/lapack-netlib/SRC/dlasq6.f +++ b/lapack-netlib/SRC/dlasq6.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASQ6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASQ6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2 ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, PP * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -119,10 +119,10 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I0, N0, PP @@ -156,13 +156,13 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * SAFMIN = DLAMCH( 'Safe minimum' ) J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) DMIN = D * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO D = Z( J4+1 ) @@ -173,7 +173,7 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, TEMP = Z( J4+1 ) / Z( J4-2 ) Z( J4 ) = Z( J4-1 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) END IF @@ -182,7 +182,7 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( Z( J4-3 ).EQ.ZERO ) THEN Z( J4-1 ) = ZERO D = Z( J4+2 ) @@ -193,7 +193,7 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, TEMP = Z( J4+2 ) / Z( J4-3 ) Z( J4-1 ) = Z( J4 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) END IF @@ -202,7 +202,7 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN diff --git a/lapack-netlib/SRC/dlasr.f b/lapack-netlib/SRC/dlasr.f index 645d03b3d8..6059c6293a 100644 --- a/lapack-netlib/SRC/dlasr.f +++ b/lapack-netlib/SRC/dlasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,35 +36,35 @@ *> *> DLASR applies a sequence of plane rotations to a real matrix A, *> from either the left or the right. -*> +*> *> When SIDE = 'L', the transformation takes the form -*> +*> *> A := P*A -*> +*> *> and when SIDE = 'R', the transformation takes the form -*> +*> *> A := A*P**T -*> +*> *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -73,13 +73,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -88,12 +88,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -102,7 +102,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -187,22 +187,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lapack-netlib/SRC/dlasrt.f b/lapack-netlib/SRC/dlasrt.f index f5d0e6cd1a..4705311d78 100644 --- a/lapack-netlib/SRC/dlasrt.f +++ b/lapack-netlib/SRC/dlasrt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASRT( ID, N, D, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -76,22 +76,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASRT( ID, N, D, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER ID @@ -123,7 +123,7 @@ SUBROUTINE DLASRT( ID, N, D, INFO ) * .. * .. Executable Statements .. * -* Test the input paramters. +* Test the input parameters. * INFO = 0 DIR = -1 diff --git a/lapack-netlib/SRC/dlassq.f b/lapack-netlib/SRC/dlassq.f index c7c4087e80..885395e3c9 100644 --- a/lapack-netlib/SRC/dlassq.f +++ b/lapack-netlib/SRC/dlassq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/dlasv2.f b/lapack-netlib/SRC/dlasv2.f index 96aaa1e45c..9371d6d3b2 100644 --- a/lapack-netlib/SRC/dlasv2.f +++ b/lapack-netlib/SRC/dlasv2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -102,14 +102,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN diff --git a/lapack-netlib/SRC/dlaswlq.f b/lapack-netlib/SRC/dlaswlq.f new file mode 100644 index 0000000000..2830711a68 --- /dev/null +++ b/lapack-netlib/SRC/dlaswlq.f @@ -0,0 +1,258 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASWLQ computes a blocked Short-Wide LQ factorization of a +*> M-by-N matrix A, where N >= M: +*> A = L * Q +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and bleow the diagonal +*> of the array contain the N-by-N lower triangular matrix L; +*> the elements above the diagonal represent Q by the rows +*> of blocked V (see Further Details). +*> +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((N-M)/(NB-M)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= MB*M. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, + $ INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), T( LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGELQT, DTPLQT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.LT.M ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN + INFO = -3 + ELSE IF( NB.LE.M ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -8 + ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = MB*M + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASWLQ', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN + CALL DGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((N-M),(NB-M)) + II=N-KK+1 +* +* Compute the LQ factorization of the first block A(1:M,1:NB) +* + CALL DGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO) + CTR = 1 +* + DO I = NB+1, II-NB+M , (NB-M) +* +* Compute the QR factorization of the current block A(1:M,I:I+NB-M) +* + CALL DTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ), + $ LDA, T(1, CTR * M + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(1:M,II:N) +* + IF (II.LE.N) THEN + CALL DTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ), + $ LDA, T(1, CTR * M + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = M * MB + RETURN +* +* End of DLASWLQ +* + END diff --git a/lapack-netlib/SRC/dlaswp.f b/lapack-netlib/SRC/dlaswp.f index 937e12b2f0..2c526ffad1 100644 --- a/lapack-netlib/SRC/dlaswp.f +++ b/lapack-netlib/SRC/dlaswp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,15 +71,15 @@ *> \param[in] K2 *> \verbatim *> K2 is INTEGER -*> The last element of IPIV for which a row interchange will -*> be done. +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*INCX of IPIV are accessed. *> IPIV(K) = L implies rows K and L are to be interchanged. *> \endverbatim *> @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -143,7 +143,7 @@ SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX + IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 diff --git a/lapack-netlib/SRC/dlasy2.f b/lapack-netlib/SRC/dlasy2.f index a4b103053d..2afad2be08 100644 --- a/lapack-netlib/SRC/dlasy2.f +++ b/lapack-netlib/SRC/dlasy2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, * LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LTRANL, LTRANR * INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 @@ -30,7 +30,7 @@ * DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleSYauxiliary * @@ -174,10 +174,10 @@ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR @@ -438,8 +438,10 @@ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, 80 CONTINUE 90 CONTINUE 100 CONTINUE - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) THEN + INFO = 1 + T16( 4, 4 ) = SMIN + END IF SCALE = ONE IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. diff --git a/lapack-netlib/SRC/dlasyf_aa.f b/lapack-netlib/SRC/dlasyf_aa.f new file mode 100644 index 0000000000..0bd2d6defa --- /dev/null +++ b/lapack-netlib/SRC/dlasyf_aa.f @@ -0,0 +1,506 @@ +*> \brief \b DLASYF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AA factorizes a panel of a real symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by DSYTRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + DOUBLE PRECISION PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from DSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL DAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL DAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL DSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL DCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL DSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL DLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from DSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL DAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL DAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL DSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL DCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL DSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL DLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of DLASYF_AA +* + END diff --git a/lapack-netlib/SRC/dlasyf_rk.f b/lapack-netlib/SRC/dlasyf_rk.f new file mode 100644 index 0000000000..209b4c89d1 --- /dev/null +++ b/lapack-netlib/SRC/dlasyf_rk.f @@ -0,0 +1,965 @@ +*> \brief \b DLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DLASYF_RK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLASYF_RK is an auxiliary routine called by DSYTRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, + $ KP, KSTEP, P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ DTEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = ABS( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = ZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), + $ LDW, ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = ABS( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = ZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF +* + RETURN +* +* End of DLASYF_RK +* + END diff --git a/lapack-netlib/SRC/dlat2s.f b/lapack-netlib/SRC/dlat2s.f index 63f106add3..fa6cc5d57b 100644 --- a/lapack-netlib/SRC/dlat2s.f +++ b/lapack-netlib/SRC/dlat2s.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAT2S + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAT2S + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDSA, N @@ -28,7 +28,7 @@ * REAL SA( LDSA, * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,7 +40,7 @@ *> *> RMAX is the overflow for the SINGLE PRECISION arithmetic *> DLAS2S checks that all the entries of A are between -RMAX and -*> RMAX. If not the convertion is aborted and a flag is raised. +*> RMAX. If not the conversion is aborted and a flag is raised. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlatbs.f b/lapack-netlib/SRC/dlatbs.f index 8238298a33..1489d53d06 100644 --- a/lapack-netlib/SRC/dlatbs.f +++ b/lapack-netlib/SRC/dlatbs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATBS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATBS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, * SCALE, CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, KD, LDAB, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -157,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -242,10 +242,10 @@ SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/dlatdf.f b/lapack-netlib/SRC/dlatdf.f index be70313bb3..fd05059b39 100644 --- a/lapack-netlib/SRC/dlatdf.f +++ b/lapack-netlib/SRC/dlatdf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATDF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATDF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * DOUBLE PRECISION RDSCAL, RDSUM @@ -29,7 +29,7 @@ * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION RHS( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> Zx = +-e - f with the sign giving the greater value *> of 2-norm(x). About 5 times as expensive as Default. *> IJOB .ne. 2: Local look ahead strategy where all entries of -*> the r.h.s. b is choosen as either +1 or -1 (Default). +*> the r.h.s. b is chosen as either +1 or -1 (Default). *> \endverbatim *> *> \param[in] N @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleOTHERauxiliary * @@ -171,10 +171,10 @@ SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IJOB, LDZ, N diff --git a/lapack-netlib/SRC/dlatps.f b/lapack-netlib/SRC/dlatps.f index 3898a453f5..c340578f74 100644 --- a/lapack-netlib/SRC/dlatps.f +++ b/lapack-netlib/SRC/dlatps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -229,10 +229,10 @@ SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/dlatrd.f b/lapack-netlib/SRC/dlatrd.f index 69ec0018be..a1df43e48a 100644 --- a/lapack-netlib/SRC/dlatrd.f +++ b/lapack-netlib/SRC/dlatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlatrs.f b/lapack-netlib/SRC/dlatrs.f index b34795eb15..5ad5f66c55 100644 --- a/lapack-netlib/SRC/dlatrs.f +++ b/lapack-netlib/SRC/dlatrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -238,10 +238,10 @@ SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/dlatrz.f b/lapack-netlib/SRC/dlatrz.f index 6748db2691..8fbe87585c 100644 --- a/lapack-netlib/SRC/dlatrz.f +++ b/lapack-netlib/SRC/dlatrz.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLATRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLATRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) -* +* * .. Scalar Arguments .. * INTEGER L, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER L, LDA, M, N diff --git a/lapack-netlib/SRC/dlatsqr.f b/lapack-netlib/SRC/dlatsqr.f new file mode 100644 index 0000000000..1ce7c4de07 --- /dev/null +++ b/lapack-netlib/SRC/dlatsqr.f @@ -0,0 +1,256 @@ +* +* Definition: +* =========== +* +* SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATSQR computes a blocked Tall-Skinny QR factorization of +*> an M-by-N matrix A, where M >= N: +*> A = Q * R . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> MB > N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal +*> of the array contain the N-by-N upper triangular matrix R; +*> the elements below the diagonal represent Q by the columns +*> of blocked V (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((M-N)/(MB-N)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= NB*N. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, + $ LWORK, INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ), T(LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGEQRT, DTPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. M.LT.N ) THEN + INFO = -2 + ELSE IF( MB.LE.N ) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -8 + ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = NB*N + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLATSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF ((MB.LE.N).OR.(MB.GE.M)) THEN + CALL DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((M-N),(MB-N)) + II=M-KK+1 +* +* Compute the QR factorization of the first block A(1:MB,1:N) +* + CALL DGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO ) +* + CTR = 1 + DO I = MB+1, II-MB+N , (MB-N) +* +* Compute the QR factorization of the current block A(I:I+MB-N,1:N) +* + CALL DTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA, + $ T(1, CTR * N + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(II:M,1:N) +* + IF (II.LE.M) THEN + CALL DTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA, + $ T(1, CTR * N + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = N*NB + RETURN +* +* End of DLATSQR +* + END diff --git a/lapack-netlib/SRC/dlauu2.f b/lapack-netlib/SRC/dlauu2.f index c77ab60a00..59cff25614 100644 --- a/lapack-netlib/SRC/dlauu2.f +++ b/lapack-netlib/SRC/dlauu2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAUU2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAUU2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dlauum.f b/lapack-netlib/SRC/dlauum.f index 1157057c78..31b1ddd06f 100644 --- a/lapack-netlib/SRC/dlauum.f +++ b/lapack-netlib/SRC/dlauum.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLAUUM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLAUUM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dopgtr.f b/lapack-netlib/SRC/dopgtr.f index d908de3df9..0e061b219f 100644 --- a/lapack-netlib/SRC/dopgtr.f +++ b/lapack-netlib/SRC/dopgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DOPGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DOPGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDQ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dopmtr.f b/lapack-netlib/SRC/dopmtr.f index 07486c7554..dd9286b351 100644 --- a/lapack-netlib/SRC/dopmtr.f +++ b/lapack-netlib/SRC/dopmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DOPMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DOPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -150,10 +150,10 @@ SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/dorbdb.f b/lapack-netlib/SRC/dorbdb.f index 011eb5c5e7..d616579945 100644 --- a/lapack-netlib/SRC/dorbdb.f +++ b/lapack-netlib/SRC/dorbdb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORBDB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, * TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIGNS, TRANS * INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, @@ -33,7 +33,7 @@ * $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), * $ X21( LDX21, * ), X22( LDX22, * ) * .. -* +* * *> \par Purpose: * ============= @@ -250,12 +250,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -287,10 +287,10 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -393,7 +393,7 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * IF( COLMAJOR ) THEN * -* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 * DO I = 1, Q * @@ -618,12 +618,12 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X11(I+1,I) = ONE END IF IF ( M-Q .GT. I ) THEN - CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, $ TAUQ2(I) ) ELSE - CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, $ TAUQ2(I) ) - END IF + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -649,7 +649,7 @@ SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * - IF ( P .GT. I ) THEN + IF ( P .GT. I ) THEN CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) END IF diff --git a/lapack-netlib/SRC/dorbdb1.f b/lapack-netlib/SRC/dorbdb1.f index b5675f71d4..db3b14db22 100644 --- a/lapack-netlib/SRC/dorbdb1.f +++ b/lapack-netlib/SRC/dorbdb1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB1 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -151,7 +151,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -169,10 +169,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -203,7 +203,7 @@ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -304,9 +304,8 @@ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I+1,I+1), LDX11, WORK(ILARF) ) CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK(ILARF) ) - C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), - $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), - $ 1 )**2 ) + C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, diff --git a/lapack-netlib/SRC/dorbdb2.f b/lapack-netlib/SRC/dorbdb2.f index 3cf82cf400..cec60da75a 100644 --- a/lapack-netlib/SRC/dorbdb2.f +++ b/lapack-netlib/SRC/dorbdb2.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB2 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -168,10 +168,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -202,7 +202,7 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -281,7 +281,7 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., P of X11 and X21 * DO I = 1, P -* +* IF( I .GT. 1 ) THEN CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) END IF @@ -292,8 +292,8 @@ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I+1,I), LDX11, WORK(ILARF) ) CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), $ X21(I,I), LDX21, WORK(ILARF) ) - S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + DNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, diff --git a/lapack-netlib/SRC/dorbdb3.f b/lapack-netlib/SRC/dorbdb3.f index 03be504fa2..7149796ca3 100644 --- a/lapack-netlib/SRC/dorbdb3.f +++ b/lapack-netlib/SRC/dorbdb3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB3 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -167,10 +167,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -201,7 +201,7 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -280,7 +280,7 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., M-P of X11 and X21 * DO I = 1, M-P -* +* IF( I .GT. 1 ) THEN CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) END IF @@ -292,8 +292,8 @@ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I,I), LDX11, WORK(ILARF) ) CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) - C = SQRT( DNRM2( P-I+1, X11(I,I), 1, X11(I,I), - $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + C = SQRT( DNRM2( P-I+1, X11(I,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, diff --git a/lapack-netlib/SRC/dorbdb4.f b/lapack-netlib/SRC/dorbdb4.f index 8c72360540..606d7083bc 100644 --- a/lapack-netlib/SRC/dorbdb4.f +++ b/lapack-netlib/SRC/dorbdb4.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB4 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -30,8 +30,8 @@ * DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), * $ WORK(*), X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -161,7 +161,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -178,10 +178,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -213,7 +213,7 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -341,9 +341,8 @@ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) IF( I .LT. M-Q ) THEN - S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), - $ 1 )**2 ) + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) PHI(I) = ATAN2( S, C ) END IF * diff --git a/lapack-netlib/SRC/dorbdb5.f b/lapack-netlib/SRC/dorbdb5.f index 8fd8e6e37c..de01f5a445 100644 --- a/lapack-netlib/SRC/dorbdb5.f +++ b/lapack-netlib/SRC/dorbdb5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB5 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -156,7 +156,7 @@ SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -269,6 +269,6 @@ SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, RETURN * * End of DORBDB5 -* +* END diff --git a/lapack-netlib/SRC/dorbdb6.f b/lapack-netlib/SRC/dorbdb6.f index 59fd863bfc..6056d0301a 100644 --- a/lapack-netlib/SRC/dorbdb6.f +++ b/lapack-netlib/SRC/dorbdb6.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB6 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -141,10 +141,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -154,7 +154,7 @@ SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -260,7 +260,7 @@ SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, IF( NORMSQ2 .EQ. ZERO ) THEN RETURN END IF -* +* NORMSQ1 = NORMSQ2 * DO I = 1, N @@ -305,7 +305,7 @@ SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, END IF * RETURN -* +* * End of DORBDB6 * END diff --git a/lapack-netlib/SRC/dorcsd.f b/lapack-netlib/SRC/dorcsd.f index d5d48eb9e5..340e16a5d6 100644 --- a/lapack-netlib/SRC/dorcsd.f +++ b/lapack-netlib/SRC/dorcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * LDX12, X21, LDX21, X22, LDX22, THETA, * U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, * LDV2T, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, @@ -37,7 +37,7 @@ * $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, * $ * ) * .. -* +* * *> \par Purpose: * ============= @@ -284,12 +284,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -300,10 +300,10 @@ RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -340,7 +340,7 @@ RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ WANTV1T, WANTV2T * .. * .. External Subroutines .. - EXTERNAL DBBCSD, DLACPY, DLAPMR, DLAPMT, DLASCL, DLASET, + EXTERNAL DBBCSD, DLACPY, DLAPMR, DLAPMT, $ DORBDB, DORGLQ, DORGQR, XERBLA * .. * .. External Functions .. @@ -464,7 +464,7 @@ RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1, $ CHILDINFO ) @@ -579,7 +579,7 @@ RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, * Permute rows and columns to place identity submatrices in top- * left corner of (1,1)-block and/or bottom-right corner of (1,2)- * block and/or bottom-right corner of (2,1)-block and/or top-left -* corner of (2,2)-block +* corner of (2,2)-block * IF( Q .GT. 0 .AND. WANTU2 ) THEN DO I = 1, Q diff --git a/lapack-netlib/SRC/dorcsd2by1.f b/lapack-netlib/SRC/dorcsd2by1.f index 19dedbe8d9..8542a2ed35 100644 --- a/lapack-netlib/SRC/dorcsd2by1.f +++ b/lapack-netlib/SRC/dorcsd2by1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORCSD2BY1 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, * X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, * LDV1T, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T * INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, @@ -33,31 +33,30 @@ * $ X11(LDX11,*), X21(LDX21,*) * INTEGER IWORK(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> *>\verbatim -*> Purpose: -*> ======== *> *> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with *> orthonormal columns that has been partitioned into a 2-by-1 block *> structure: *> -*> [ I 0 0 ] +*> [ I1 0 0 ] *> [ 0 C 0 ] *> [ X11 ] [ U1 | ] [ 0 0 0 ] *> X = [-----] = [---------] [----------] V1**T . *> [ X21 ] [ | U2 ] [ 0 0 0 ] *> [ 0 S 0 ] -*> [ 0 0 I ] -*> +*> [ 0 0 I2] +*> *> X11 is P-by-Q. The orthogonal matrices U1, U2, and V1 are P-by-P, *> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R *> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which -*> R = MIN(P,M-P,Q,M-Q). +*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a +*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). *> \endverbatim * * Arguments: @@ -220,10 +219,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -250,7 +249,7 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ X11(LDX11,*), X21(LDX21,*) INTEGER IWORK(*) * .. -* +* * ===================================================================== * * .. Parameters .. @@ -266,6 +265,9 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LWORKMIN, LWORKOPT, R LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T * .. +* .. Local Arrays .. + DOUBLE PRECISION DUM1(1), DUM2(1,1) +* .. * .. External Subroutines .. EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1, $ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR, @@ -298,11 +300,11 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, INFO = -8 ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -10 - ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN INFO = -13 - ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN INFO = -15 - ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN INFO = -17 END IF * @@ -344,99 +346,125 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, IORBDB = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ1 + MAX( 1, Q ) IORGLQ = ITAUQ1 + MAX( 1, Q ) + LORGQRMIN = 1 + LORGQROPT = 1 + LORGLQMIN = 1 + LORGLQOPT = 1 IF( R .EQ. Q ) THEN - CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK, -1, CHILDINFO ) + CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, WORK, + $ -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, - $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + ENDIF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q-1, Q-1, Q-1, V1T, LDV1T, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q-1 ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL DORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, - $ 0, WORK(1), -1, CHILDINFO ) - LORGLQMIN = MAX( 1, Q-1 ) - LORGLQOPT = INT( WORK(1) ) CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, - $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + $ DUM1, U1, LDU1, U2, LDU2, V1T, LDV1T, + $ DUM2, 1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) LBBCSD = INT( WORK(1) ) ELSE IF( R .EQ. P ) THEN - CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P-1 .GE. M-P ) THEN - CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, DUM1, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), $ -1, CHILDINFO ) - LORGQRMIN = MAX( 1, P-1 ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, - $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + $ DUM1, V1T, LDV1T, DUM2, 1, U1, LDU1, + $ U2, LDU2, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) LBBCSD = INT( WORK(1) ) ELSE IF( R .EQ. M-P ) THEN - CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P-1 ) THEN - CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, - $ WORK(1), -1, CHILDINFO ) - LORGQRMIN = MAX( 1, M-P-1 ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, - $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM1, DUM2, 1, V1T, LDV1T, U2, + $ LDU2, U1, LDU1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) LBBCSD = INT( WORK(1) ) ELSE - CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) LORBDB = M + INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL DORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DORGQR( P, P, M-Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DORGLQ( Q, Q, Q, V1T, LDV1T, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL DORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, - $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM1, U2, LDU2, U1, LDU1, DUM2, + $ 1, V1T, LDV1T, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, + $ DUM1, WORK(1), -1, CHILDINFO ) LBBCSD = INT( WORK(1) ) END IF LWORKMIN = MAX( IORBDB+LORBDB-1, @@ -497,16 +525,16 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, - $ WORK(IB11D), WORK(IB11E), WORK(IB12D), - $ WORK(IB12E), WORK(IB21D), WORK(IB21E), - $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, + $ DUM2, 1, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place zero submatrices in * preferred positions * @@ -551,16 +579,16 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, - $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IPHI), V1T, LDV1T, DUM2, 1, U1, LDU1, U2, + $ LDU2, WORK(IB11D), WORK(IB11E), WORK(IB12D), $ WORK(IB12E), WORK(IB21D), WORK(IB21E), $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -606,16 +634,16 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1, - $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D), - $ WORK(IB12E), WORK(IB21D), WORK(IB21E), - $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ THETA, WORK(IPHI), DUM2, 1, V1T, LDV1T, U2, + $ LDU2, U1, LDU1, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -675,16 +703,16 @@ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, - $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D), - $ WORK(IB12E), WORK(IB21D), WORK(IB21E), - $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, DUM2, + $ 1, V1T, LDV1T, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place identity submatrices in * preferred positions * diff --git a/lapack-netlib/SRC/dorg2l.f b/lapack-netlib/SRC/dorg2l.f index b95fa50fc5..36ff4e5d4b 100644 --- a/lapack-netlib/SRC/dorg2l.f +++ b/lapack-netlib/SRC/dorg2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/dorg2r.f b/lapack-netlib/SRC/dorg2r.f index 86df6dddc7..4b71011a9f 100644 --- a/lapack-netlib/SRC/dorg2r.f +++ b/lapack-netlib/SRC/dorg2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/dorgbr.f b/lapack-netlib/SRC/dorgbr.f index ddfa7262a0..cfebda5abd 100644 --- a/lapack-netlib/SRC/dorgbr.f +++ b/lapack-netlib/SRC/dorgbr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,10 +145,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ * ===================================================================== SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -182,8 +182,7 @@ SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DORGLQ, DORGQR, XERBLA diff --git a/lapack-netlib/SRC/dorghr.f b/lapack-netlib/SRC/dorghr.f index 48f504ea71..7f60c68540 100644 --- a/lapack-netlib/SRC/dorghr.f +++ b/lapack-netlib/SRC/dorghr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/dorgl2.f b/lapack-netlib/SRC/dorgl2.f index 3e8398b73f..5d8985d758 100644 --- a/lapack-netlib/SRC/dorgl2.f +++ b/lapack-netlib/SRC/dorgl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/dorglq.f b/lapack-netlib/SRC/dorglq.f index 88aec15005..912b5de84e 100644 --- a/lapack-netlib/SRC/dorglq.f +++ b/lapack-netlib/SRC/dorglq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dorgql.f b/lapack-netlib/SRC/dorgql.f index ca4698d799..ea12be91b1 100644 --- a/lapack-netlib/SRC/dorgql.f +++ b/lapack-netlib/SRC/dorgql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dorgqr.f b/lapack-netlib/SRC/dorgqr.f index 404ab184e6..628eeacba7 100644 --- a/lapack-netlib/SRC/dorgqr.f +++ b/lapack-netlib/SRC/dorgqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dorgr2.f b/lapack-netlib/SRC/dorgr2.f index 3cd6200139..7c5dce1d7a 100644 --- a/lapack-netlib/SRC/dorgr2.f +++ b/lapack-netlib/SRC/dorgr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/dorgrq.f b/lapack-netlib/SRC/dorgrq.f index 0263eeb65f..b76fb37ed7 100644 --- a/lapack-netlib/SRC/dorgrq.f +++ b/lapack-netlib/SRC/dorgrq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/dorgtr.f b/lapack-netlib/SRC/dorgtr.f index 06a7b6cc1c..72623eac06 100644 --- a/lapack-netlib/SRC/dorgtr.f +++ b/lapack-netlib/SRC/dorgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dorm2l.f b/lapack-netlib/SRC/dorm2l.f index 3ff25869a7..1014cb2378 100644 --- a/lapack-netlib/SRC/dorm2l.f +++ b/lapack-netlib/SRC/dorm2l.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dorm2r.f b/lapack-netlib/SRC/dorm2r.f index b13f12d53c..632b70e740 100644 --- a/lapack-netlib/SRC/dorm2r.f +++ b/lapack-netlib/SRC/dorm2r.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormbr.f b/lapack-netlib/SRC/dormbr.f index 7a0d9b9038..f035d0ae66 100644 --- a/lapack-netlib/SRC/dormbr.f +++ b/lapack-netlib/SRC/dormbr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -195,10 +195,10 @@ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT diff --git a/lapack-netlib/SRC/dormhr.f b/lapack-netlib/SRC/dormhr.f index 85bfc41b68..d1e214e0f2 100644 --- a/lapack-netlib/SRC/dormhr.f +++ b/lapack-netlib/SRC/dormhr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dorml2.f b/lapack-netlib/SRC/dorml2.f index 9ae2396e12..2c55c7f1fd 100644 --- a/lapack-netlib/SRC/dorml2.f +++ b/lapack-netlib/SRC/dorml2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormlq.f b/lapack-netlib/SRC/dormlq.f index 236cfd111b..bb5469d273 100644 --- a/lapack-netlib/SRC/dormlq.f +++ b/lapack-netlib/SRC/dormlq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormql.f b/lapack-netlib/SRC/dormql.f index e7d268ee63..7d2b5d6c32 100644 --- a/lapack-netlib/SRC/dormql.f +++ b/lapack-netlib/SRC/dormql.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormqr.f b/lapack-netlib/SRC/dormqr.f index 7a21c2cd59..7f2ebb9ace 100644 --- a/lapack-netlib/SRC/dormqr.f +++ b/lapack-netlib/SRC/dormqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormr2.f b/lapack-netlib/SRC/dormr2.f index e6bcf04d81..129ee1b494 100644 --- a/lapack-netlib/SRC/dormr2.f +++ b/lapack-netlib/SRC/dormr2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormr3.f b/lapack-netlib/SRC/dormr3.f index c98b16dc99..5f20db724c 100644 --- a/lapack-netlib/SRC/dormr3.f +++ b/lapack-netlib/SRC/dormr3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormrq.f b/lapack-netlib/SRC/dormrq.f index 1e3ca95308..421bd104bf 100644 --- a/lapack-netlib/SRC/dormrq.f +++ b/lapack-netlib/SRC/dormrq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/dormrz.f b/lapack-netlib/SRC/dormrz.f index 5e74c8aaac..8e1bd56ccc 100644 --- a/lapack-netlib/SRC/dormrz.f +++ b/lapack-netlib/SRC/dormrz.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -187,10 +187,10 @@ SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -266,7 +266,7 @@ SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements -* +* IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE diff --git a/lapack-netlib/SRC/dormtr.f b/lapack-netlib/SRC/dormtr.f index 00fff4dda2..d2443c1dac 100644 --- a/lapack-netlib/SRC/dormtr.f +++ b/lapack-netlib/SRC/dormtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DORMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DORMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/dpbcon.f b/lapack-netlib/SRC/dpbcon.f index 18fdba80ad..41d43dc492 100644 --- a/lapack-netlib/SRC/dpbcon.f +++ b/lapack-netlib/SRC/dpbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -132,10 +132,10 @@ SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbequ.f b/lapack-netlib/SRC/dpbequ.f index d7fba5201c..ec5d4eb766 100644 --- a/lapack-netlib/SRC/dpbequ.f +++ b/lapack-netlib/SRC/dpbequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,22 +117,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbrfs.f b/lapack-netlib/SRC/dpbrfs.f index 2f9ec7ab46..6bc522fa8d 100644 --- a/lapack-netlib/SRC/dpbrfs.f +++ b/lapack-netlib/SRC/dpbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbstf.f b/lapack-netlib/SRC/dpbstf.f index 78dd2c1c73..c104ddbeab 100644 --- a/lapack-netlib/SRC/dpbstf.f +++ b/lapack-netlib/SRC/dpbstf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBSTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBSTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -152,10 +152,10 @@ * ===================================================================== SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbsv.f b/lapack-netlib/SRC/dpbsv.f index 837c651ae0..535a2d40ec 100644 --- a/lapack-netlib/SRC/dpbsv.f +++ b/lapack-netlib/SRC/dpbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERsolve * @@ -164,10 +164,10 @@ * ===================================================================== SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbsvx.f b/lapack-netlib/SRC/dpbsvx.f index 158f2835cb..b194d26a45 100644 --- a/lapack-netlib/SRC/dpbsvx.f +++ b/lapack-netlib/SRC/dpbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, * EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -297,10 +297,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -343,7 +343,7 @@ SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dpbtf2.f b/lapack-netlib/SRC/dpbtf2.f index 6cc3e42d52..fd385322b1 100644 --- a/lapack-netlib/SRC/dpbtf2.f +++ b/lapack-netlib/SRC/dpbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbtrf.f b/lapack-netlib/SRC/dpbtrf.f index d50d0330c2..269e973628 100644 --- a/lapack-netlib/SRC/dpbtrf.f +++ b/lapack-netlib/SRC/dpbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpbtrs.f b/lapack-netlib/SRC/dpbtrs.f index b8e3791f73..08e437399c 100644 --- a/lapack-netlib/SRC/dpbtrs.f +++ b/lapack-netlib/SRC/dpbtrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpftrf.f b/lapack-netlib/SRC/dpftrf.f index 647136739e..b460f2a5da 100644 --- a/lapack-netlib/SRC/dpftrf.f +++ b/lapack-netlib/SRC/dpftrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPFTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPFTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER N, INFO * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) -* +* * *> \par Purpose: * ============= @@ -99,12 +99,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dpftri.f b/lapack-netlib/SRC/dpftri.f index 04ca4f3498..adbbfa8ad5 100644 --- a/lapack-netlib/SRC/dpftri.f +++ b/lapack-netlib/SRC/dpftri.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dpftrs.f b/lapack-netlib/SRC/dpftrs.f index d111dbc47c..9c325064ea 100644 --- a/lapack-netlib/SRC/dpftrs.f +++ b/lapack-netlib/SRC/dpftrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPFTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPFTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -199,10 +199,10 @@ * ===================================================================== SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dpocon.f b/lapack-netlib/SRC/dpocon.f index a8b0066933..20e9aff6a0 100644 --- a/lapack-netlib/SRC/dpocon.f +++ b/lapack-netlib/SRC/dpocon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * @@ -121,10 +121,10 @@ SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpoequ.f b/lapack-netlib/SRC/dpoequ.f index 070c54114b..eb150713dc 100644 --- a/lapack-netlib/SRC/dpoequ.f +++ b/lapack-netlib/SRC/dpoequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/dpoequb.f b/lapack-netlib/SRC/dpoequb.f index 09ee542c2a..fbcc6fe3e4 100644 --- a/lapack-netlib/SRC/dpoequb.f +++ b/lapack-netlib/SRC/dpoequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -27,14 +27,14 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DPOEQU computes row and column scalings intended to equilibrate a +*> DPOEQUB computes row and column scalings intended to equilibrate a *> symmetric positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with @@ -42,6 +42,12 @@ *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. +*> +*> This routine differs from DPOEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled diagonal entries are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: @@ -100,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/dporfs.f b/lapack-netlib/SRC/dporfs.f index 08db3c3801..8fc74fde14 100644 --- a/lapack-netlib/SRC/dporfs.f +++ b/lapack-netlib/SRC/dporfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPORFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPORFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * @@ -183,10 +183,10 @@ SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dporfsx.f b/lapack-netlib/SRC/dporfsx.f index 96462e4467..53724925eb 100644 --- a/lapack-netlib/SRC/dporfsx.f +++ b/lapack-netlib/SRC/dporfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPORFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPORFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -379,10 +379,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -394,7 +394,7 @@ SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -455,12 +455,11 @@ SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, DLANSY, DLA_PORCOND DOUBLE PRECISION DLAMCH, DLANSY, DLA_PORCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/dposv.f b/lapack-netlib/SRC/dposv.f index 0bcf476426..ab8f00775c 100644 --- a/lapack-netlib/SRC/dposv.f +++ b/lapack-netlib/SRC/dposv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOsolve * * ===================================================================== SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dposvx.f b/lapack-netlib/SRC/dposvx.f index 4150a5d6cc..cf33c96a31 100644 --- a/lapack-netlib/SRC/dposvx.f +++ b/lapack-netlib/SRC/dposvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, * S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -293,10 +293,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -307,7 +307,7 @@ SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dposvxx.f b/lapack-netlib/SRC/dposvxx.f index a7d0acfad7..488e0b15af 100644 --- a/lapack-netlib/SRC/dposvxx.f +++ b/lapack-netlib/SRC/dposvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -479,10 +479,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -494,7 +494,7 @@ SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dpotf2.f b/lapack-netlib/SRC/dpotf2.f index 6003e19b05..1fb60a903b 100644 --- a/lapack-netlib/SRC/dpotf2.f +++ b/lapack-netlib/SRC/dpotf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpotrf.f b/lapack-netlib/SRC/dpotrf.f index 5250ca0eb3..1fa75a4654 100644 --- a/lapack-netlib/SRC/dpotrf.f +++ b/lapack-netlib/SRC/dpotrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpotrf2.f b/lapack-netlib/SRC/dpotrf2.f index 751ff762c9..0d419c4f00 100644 --- a/lapack-netlib/SRC/dpotrf2.f +++ b/lapack-netlib/SRC/dpotrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,7 +41,7 @@ *> *> The subroutine calls itself to factor A11. Update and scale A21 *> or A12, update A22 then calls itself to factor A22. -*> +*> *> \endverbatim * * Arguments: @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -126,7 +126,7 @@ RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - LOGICAL UPPER + LOGICAL UPPER INTEGER N1, N2, IINFO * .. * .. External Functions .. @@ -189,7 +189,7 @@ RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO RETURN - END IF + END IF * * Compute the Cholesky factorization A = U**T*U * @@ -198,10 +198,10 @@ RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) * Update and scale A12 * CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, - $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) + $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) * * Update and factor A22 -* +* CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) @@ -216,7 +216,7 @@ RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) * * Update and scale A21 * - CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, + CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) * * Update and factor A22 diff --git a/lapack-netlib/SRC/dpotri.f b/lapack-netlib/SRC/dpotri.f index af1572f6b9..4d2dcb43ba 100644 --- a/lapack-netlib/SRC/dpotri.f +++ b/lapack-netlib/SRC/dpotri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpotrs.f b/lapack-netlib/SRC/dpotrs.f index 71f19a3f90..4cc5e74f3d 100644 --- a/lapack-netlib/SRC/dpotrs.f +++ b/lapack-netlib/SRC/dpotrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPOTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dppcon.f b/lapack-netlib/SRC/dppcon.f index 6c55be154d..0e6ab922e1 100644 --- a/lapack-netlib/SRC/dppcon.f +++ b/lapack-netlib/SRC/dppcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dppequ.f b/lapack-netlib/SRC/dppequ.f index 4af3638f45..3563b59d10 100644 --- a/lapack-netlib/SRC/dppequ.f +++ b/lapack-netlib/SRC/dppequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpprfs.f b/lapack-netlib/SRC/dpprfs.f index 45fa1d8161..1c068e21c2 100644 --- a/lapack-netlib/SRC/dpprfs.f +++ b/lapack-netlib/SRC/dpprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, * BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dppsv.f b/lapack-netlib/SRC/dppsv.f index ac7c127c58..cb70bab434 100644 --- a/lapack-netlib/SRC/dppsv.f +++ b/lapack-netlib/SRC/dppsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERsolve * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dppsvx.f b/lapack-netlib/SRC/dppsvx.f index 3d61d38315..df949896e2 100644 --- a/lapack-netlib/SRC/dppsvx.f +++ b/lapack-netlib/SRC/dppsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, * X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,10 +279,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -312,7 +312,7 @@ SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dpptrf.f b/lapack-netlib/SRC/dpptrf.f index bb06a8d779..c7f0c35b0f 100644 --- a/lapack-netlib/SRC/dpptrf.f +++ b/lapack-netlib/SRC/dpptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpptri.f b/lapack-netlib/SRC/dpptri.f index 34b12fd578..8f16de01e2 100644 --- a/lapack-netlib/SRC/dpptri.f +++ b/lapack-netlib/SRC/dpptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpptrs.f b/lapack-netlib/SRC/dpptrs.f index 97f2172971..b4410a5128 100644 --- a/lapack-netlib/SRC/dpptrs.f +++ b/lapack-netlib/SRC/dpptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dpstf2.f b/lapack-netlib/SRC/dpstf2.f index 3e05c645d4..53c4d3409a 100644 --- a/lapack-netlib/SRC/dpstf2.f +++ b/lapack-netlib/SRC/dpstf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPSTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPSTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL diff --git a/lapack-netlib/SRC/dpstrf.f b/lapack-netlib/SRC/dpstrf.f index 3d3f6ef031..940f46dd75 100644 --- a/lapack-netlib/SRC/dpstrf.f +++ b/lapack-netlib/SRC/dpstrf.f @@ -3,24 +3,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPSTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPSTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -130,22 +130,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL diff --git a/lapack-netlib/SRC/dptcon.f b/lapack-netlib/SRC/dptcon.f index 78d81dceb3..84c4ed785f 100644 --- a/lapack-netlib/SRC/dptcon.f +++ b/lapack-netlib/SRC/dptcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * @@ -118,10 +118,10 @@ * ===================================================================== SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/dpteqr.f b/lapack-netlib/SRC/dpteqr.f index 4a98b99ee3..ecfc7755db 100644 --- a/lapack-netlib/SRC/dpteqr.f +++ b/lapack-netlib/SRC/dpteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,22 +133,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/dptrfs.f b/lapack-netlib/SRC/dptrfs.f index 30b6fccdf5..ca038a8df2 100644 --- a/lapack-netlib/SRC/dptrfs.f +++ b/lapack-netlib/SRC/dptrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, * BERR, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, LDX, N, NRHS * .. @@ -29,7 +29,7 @@ * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * @@ -163,10 +163,10 @@ SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, $ BERR, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, LDX, N, NRHS diff --git a/lapack-netlib/SRC/dptsv.f b/lapack-netlib/SRC/dptsv.f index ffc79b3cf2..019ed4fbae 100644 --- a/lapack-netlib/SRC/dptsv.f +++ b/lapack-netlib/SRC/dptsv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTsolve * * ===================================================================== SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dptsvx.f b/lapack-netlib/SRC/dptsvx.f index 6f2357a855..59f344579e 100644 --- a/lapack-netlib/SRC/dptsvx.f +++ b/lapack-netlib/SRC/dptsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTsolve * @@ -228,10 +228,10 @@ SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT diff --git a/lapack-netlib/SRC/dpttrf.f b/lapack-netlib/SRC/dpttrf.f index e21327c059..33a67adfa5 100644 --- a/lapack-netlib/SRC/dpttrf.f +++ b/lapack-netlib/SRC/dpttrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTRF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTRF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/dpttrs.f b/lapack-netlib/SRC/dpttrs.f index ae34683413..34cbe9b902 100644 --- a/lapack-netlib/SRC/dpttrs.f +++ b/lapack-netlib/SRC/dpttrs.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/dptts2.f b/lapack-netlib/SRC/dptts2.f index 59aa6b806f..99e212d60b 100644 --- a/lapack-netlib/SRC/dptts2.f +++ b/lapack-netlib/SRC/dptts2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DPTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DPTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS diff --git a/lapack-netlib/SRC/drscl.f b/lapack-netlib/SRC/drscl.f index 21ba19c11a..9251143680 100644 --- a/lapack-netlib/SRC/drscl.f +++ b/lapack-netlib/SRC/drscl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DRSCL( N, SA, SX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION SX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/dsb2st_kernels.f b/lapack-netlib/SRC/dsb2st_kernels.f new file mode 100644 index 0000000000..afed5265fc --- /dev/null +++ b/lapack-netlib/SRC/dsb2st_kernels.f @@ -0,0 +1,335 @@ +*> \brief \b DSB2ST_KERNELS +* +* @generated from zhb2st_kernels.f, fortran z -> d, Wed Dec 7 08:22:39 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSB2ST_KERNELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, +* ST, ED, SWEEP, N, NB, IB, +* A, LDA, V, TAU, LDVT, WORK) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* LOGICAL WANTZ +* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), V( * ), +* TAU( * ), WORK( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSB2ST_KERNELS is an internal routine used by the DSYTRD_SB2ST +*> subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> @param[in] n +*> The order of the matrix A. +*> +*> @param[in] nb +*> The size of the band. +*> +*> @param[in, out] A +*> A pointer to the matrix A. +*> +*> @param[in] lda +*> The leading dimension of the matrix A. +*> +*> @param[out] V +*> DOUBLE PRECISION array, dimension 2*n if eigenvalues only are +*> requested or to be queried for vectors. +*> +*> @param[out] TAU +*> DOUBLE PRECISION array, dimension (2*n). +*> The scalar factors of the Householder reflectors are stored +*> in this array. +*> +*> @param[in] st +*> internal parameter for indices. +*> +*> @param[in] ed +*> internal parameter for indices. +*> +*> @param[in] sweep +*> internal parameter for indices. +*> +*> @param[in] Vblksiz +*> internal parameter for indices. +*> +*> @param[in] wantz +*> logical which indicate if Eigenvalue are requested or both +*> Eigenvalue/Eigenvectors. +*> +*> @param[in] work +*> Workspace of size nb. +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, + $ ST, ED, SWEEP, N, NB, IB, + $ A, LDA, V, TAU, LDVT, WORK) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + LOGICAL WANTZ + INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), V( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, + $ DPOS, OFDPOS, AJETER + DOUBLE PRECISION CTMP +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DLARFX, DLARFY +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. +* .. Executable Statements .. +* + AJETER = IB + LDVT + UPPER = LSAME( UPLO, 'U' ) + + IF( UPPER ) THEN + DPOS = 2 * NB + 1 + OFDPOS = 2 * NB + ELSE + DPOS = 1 + OFDPOS = 2 + ENDIF + +* +* Upper case +* + IF( UPPER ) THEN +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 10 I = 1, LM-1 + V( VPOS+I ) = ( A( OFDPOS-I, ST+I ) ) + A( OFDPOS-I, ST+I ) = ZERO + 10 CONTINUE + CTMP = ( A( OFDPOS, ST ) ) + CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) + A( OFDPOS, ST ) = CTMP +* + LM = ED - ST + 1 + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.3 ) THEN +* + LM = ED - ST + 1 + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 + IF( LM.GT.0) THEN + CALL DLARFX( 'Left', LN, LM, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS-NB, J1 ), LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 30 I = 1, LM-1 + V( VPOS+I ) = + $ ( A( DPOS-NB-I, J1+I ) ) + A( DPOS-NB-I, J1+I ) = ZERO + 30 CONTINUE + CTMP = ( A( DPOS-NB, J1 ) ) + CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) + A( DPOS-NB, J1 ) = CTMP +* + CALL DLARFX( 'Right', LN-1, LM, V( VPOS ), + $ TAU( TAUPOS ), + $ A( DPOS-NB+1, J1 ), LDA-1, WORK) + ENDIF + ENDIF +* +* Lower case +* + ELSE +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 20 I = 1, LM-1 + V( VPOS+I ) = A( OFDPOS+I, ST-1 ) + A( OFDPOS+I, ST-1 ) = ZERO + 20 CONTINUE + CALL DLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + LM = ED - ST + 1 +* + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.3 ) THEN + LM = ED - ST + 1 +* + CALL DLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 +* + IF( LM.GT.0) THEN + CALL DLARFX( 'Right', LM, LN, V( VPOS ), + $ TAU( TAUPOS ), A( DPOS+NB, ST ), + $ LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 40 I = 1, LM-1 + V( VPOS+I ) = A( DPOS+NB+I, ST ) + A( DPOS+NB+I, ST ) = ZERO + 40 CONTINUE + CALL DLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + CALL DLARFX( 'Left', LM, LN-1, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) + + ENDIF + ENDIF + ENDIF +* + RETURN +* +* END OF DSB2ST_KERNELS +* + END diff --git a/lapack-netlib/SRC/dsbev.f b/lapack-netlib/SRC/dsbev.f index fadf43e915..416ae221e7 100644 --- a/lapack-netlib/SRC/dsbev.f +++ b/lapack-netlib/SRC/dsbev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -146,10 +146,10 @@ SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsbev_2stage.f b/lapack-netlib/SRC/dsbev_2stage.f new file mode 100644 index 0000000000..c66b40491d --- /dev/null +++ b/lapack-netlib/SRC/dsbev_2stage.f @@ -0,0 +1,377 @@ +*> \brief DSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ, LQUERY + INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DSCAL, DSTEQR, DSTERF, XERBLA, + $ DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -11 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = AB( 1, 1 ) + ELSE + W( 1 ) = AB( KD+1, 1 ) + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSBEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsbevd.f b/lapack-netlib/SRC/dsbevd.f index 0ae815b9e5..0fa15c0519 100644 --- a/lapack-netlib/SRC/dsbevd.f +++ b/lapack-netlib/SRC/dsbevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -180,12 +180,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -193,10 +193,10 @@ SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsbevd_2stage.f b/lapack-netlib/SRC/dsbevd_2stage.f new file mode 100644 index 0000000000..1968f2b780 --- /dev/null +++ b/lapack-netlib/SRC/dsbevd_2stage.f @@ -0,0 +1,412 @@ +*> \brief DSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses +*> a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ LLWRK2 + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASCL, DSCAL, DSTEDC, + $ DSTERF, XERBLA, DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 5*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = MAX( 2*N, N+LHTRD+LWTRD ) + END IF + END IF + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = AB( 1, 1 ) + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce band symmetric matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, + $ ZERO, WORK( INDWK2 ), N ) + CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSBEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsbevx.f b/lapack-netlib/SRC/dsbevx.f index 39517fb935..5e6d6423f9 100644 --- a/lapack-netlib/SRC/dsbevx.f +++ b/lapack-netlib/SRC/dsbevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -139,13 +142,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -244,12 +251,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -258,10 +265,10 @@ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dsbevx_2stage.f b/lapack-netlib/SRC/dsbevx_2stage.f new file mode 100644 index 0000000000..9e120e5e5a --- /dev/null +++ b/lapack-netlib/SRC/dsbevx_2stage.f @@ -0,0 +1,633 @@ +*> \brief DSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSBEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, +* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, +* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N orthogonal matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 7*N, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + 2*N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, + $ LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, + $ LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, + $ LQUERY + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSB + EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSCAL, + $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, + $ DSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'DSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -20 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBEVX_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + TMP1 = AB( 1, 1 ) + ELSE + TMP1 = AB( KD+1, 1 ) + END IF + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = TMP1 + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or SSTEQR. If this fails for some +* eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + DO 20 J = 1, M + CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSBEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsbgst.f b/lapack-netlib/SRC/dsbgst.f index dce9b4865f..3adfeb919c 100644 --- a/lapack-netlib/SRC/dsbgst.f +++ b/lapack-netlib/SRC/dsbgst.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, * LDX, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/dsbgv.f b/lapack-netlib/SRC/dsbgv.f index 717e7a9742..d82cdae93c 100644 --- a/lapack-netlib/SRC/dsbgv.f +++ b/lapack-netlib/SRC/dsbgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, * LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -164,12 +164,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -177,10 +177,10 @@ SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsbgvd.f b/lapack-netlib/SRC/dsbgvd.f index fe8d628734..2a215fbf0e 100644 --- a/lapack-netlib/SRC/dsbgvd.f +++ b/lapack-netlib/SRC/dsbgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, * Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,7 +161,7 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK >= 1. -*> If JOBZ = 'N' and N > 1, LWORK >= 3*N. +*> If JOBZ = 'N' and N > 1, LWORK >= 2*N. *> If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -209,12 +209,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -227,10 +227,10 @@ SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -338,7 +338,7 @@ SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, INDWK2 = INDWRK + N*N LLWRK2 = LWORK - INDWK2 + 1 CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, - $ WORK( INDWRK ), IINFO ) + $ WORK, IINFO ) * * Reduce to tridiagonal form. * diff --git a/lapack-netlib/SRC/dsbgvx.f b/lapack-netlib/SRC/dsbgvx.f index fc06677da5..eab5ebcbb1 100644 --- a/lapack-netlib/SRC/dsbgvx.f +++ b/lapack-netlib/SRC/dsbgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, * LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, * LDZ, WORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, @@ -33,7 +33,7 @@ * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), * $ W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,13 +152,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -166,14 +170,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -266,12 +275,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -285,10 +294,10 @@ SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dsbtrd.f b/lapack-netlib/SRC/dsbtrd.f index 528a3aad43..9ea0c22082 100644 --- a/lapack-netlib/SRC/dsbtrd.f +++ b/lapack-netlib/SRC/dsbtrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSBTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSBTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KD, LDAB, LDQ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/dsfrk.f b/lapack-netlib/SRC/dsfrk.f index 960330c468..1fd1763e72 100644 --- a/lapack-netlib/SRC/dsfrk.f +++ b/lapack-netlib/SRC/dsfrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSFRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSFRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, * C ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER K, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -166,10 +166,10 @@ SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, $ C ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/dsgesv.f b/lapack-netlib/SRC/dsgesv.f index 64e2c1686b..e867b974d1 100644 --- a/lapack-netlib/SRC/dsgesv.f +++ b/lapack-netlib/SRC/dsgesv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, * SWORK, ITER, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS * .. @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -164,7 +164,7 @@ *> -3 : failure of SGETRF *> -31: stop the iterative refinement after the 30th *> iterations -*> > 0: iterative refinement has been sucessfully used. +*> > 0: iterative refinement has been successfully used. *> Returns the number of iterations *> \endverbatim *> @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleGEsolve * @@ -195,10 +195,10 @@ SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, $ SWORK, ITER, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS diff --git a/lapack-netlib/SRC/dspcon.f b/lapack-netlib/SRC/dspcon.f index e0dac84f04..b422f844c1 100644 --- a/lapack-netlib/SRC/dspcon.f +++ b/lapack-netlib/SRC/dspcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -125,10 +125,10 @@ SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dspev.f b/lapack-netlib/SRC/dspev.f index 3ddb0166e1..f3142791ef 100644 --- a/lapack-netlib/SRC/dspev.f +++ b/lapack-netlib/SRC/dspev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dspevd.f b/lapack-netlib/SRC/dspevd.f index 8b6b8dae56..234d03fed8 100644 --- a/lapack-netlib/SRC/dspevd.f +++ b/lapack-netlib/SRC/dspevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -179,10 +179,10 @@ SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dspevx.f b/lapack-netlib/SRC/dspevx.f index 35a96b2b8c..d66dc18efb 100644 --- a/lapack-netlib/SRC/dspevx.f +++ b/lapack-netlib/SRC/dspevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDZ, M, N @@ -31,7 +31,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -109,13 +112,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -213,12 +220,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -227,10 +234,10 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dspgst.f b/lapack-netlib/SRC/dspgst.f index 4be928d409..59cda68b43 100644 --- a/lapack-netlib/SRC/dspgst.f +++ b/lapack-netlib/SRC/dspgst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), BP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dspgv.f b/lapack-netlib/SRC/dspgv.f index 9f15c09964..085e96fe1f 100644 --- a/lapack-netlib/SRC/dspgv.f +++ b/lapack-netlib/SRC/dspgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -161,10 +161,10 @@ SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dspgvd.f b/lapack-netlib/SRC/dspgvd.f index f3e5457e2e..71b290b9c4 100644 --- a/lapack-netlib/SRC/dspgvd.f +++ b/lapack-netlib/SRC/dspgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -210,10 +210,10 @@ SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dspgvx.f b/lapack-netlib/SRC/dspgvx.f index 9eb91f7a1a..8619ef739f 100644 --- a/lapack-netlib/SRC/dspgvx.f +++ b/lapack-netlib/SRC/dspgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, * IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDZ, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,13 +118,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,14 +136,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -244,12 +253,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -263,10 +272,10 @@ SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dsposv.f b/lapack-netlib/SRC/dsposv.f index bb72199ba1..0f9eff8b0d 100644 --- a/lapack-netlib/SRC/dsposv.f +++ b/lapack-netlib/SRC/dsposv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, * SWORK, ITER, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,7 +168,7 @@ *> -3 : failure of SPOTRF *> -31: stop the iterative refinement after the 30th *> iterations -*> > 0: iterative refinement has been sucessfully used. +*> > 0: iterative refinement has been successfully used. *> Returns the number of iterations *> \endverbatim *> @@ -186,12 +186,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doublePOsolve * @@ -199,10 +199,10 @@ SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, $ SWORK, ITER, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsprfs.f b/lapack-netlib/SRC/dsprfs.f index ea158ee575..9ad5a80b5d 100644 --- a/lapack-netlib/SRC/dsprfs.f +++ b/lapack-netlib/SRC/dsprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dspsv.f b/lapack-netlib/SRC/dspsv.f index 79664bb962..e96943925c 100644 --- a/lapack-netlib/SRC/dspsv.f +++ b/lapack-netlib/SRC/dspsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dspsvx.f b/lapack-netlib/SRC/dspsvx.f index d787cc30fa..b95c610ba8 100644 --- a/lapack-netlib/SRC/dspsvx.f +++ b/lapack-netlib/SRC/dspsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dsptrd.f b/lapack-netlib/SRC/dsptrd.f index 5ee076a030..082f814098 100644 --- a/lapack-netlib/SRC/dsptrd.f +++ b/lapack-netlib/SRC/dsptrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -150,10 +150,10 @@ * ===================================================================== SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsptrf.f b/lapack-netlib/SRC/dsptrf.f index b45649342d..9158ff1f38 100644 --- a/lapack-netlib/SRC/dsptrf.f +++ b/lapack-netlib/SRC/dsptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -159,10 +159,10 @@ * ===================================================================== SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsptri.f b/lapack-netlib/SRC/dsptri.f index e914ffffca..e68efface8 100644 --- a/lapack-netlib/SRC/dsptri.f +++ b/lapack-netlib/SRC/dsptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsptrs.f b/lapack-netlib/SRC/dsptrs.f index 48c82acbff..17f8c6a5f4 100644 --- a/lapack-netlib/SRC/dsptrs.f +++ b/lapack-netlib/SRC/dsptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dstebz.f b/lapack-netlib/SRC/dstebz.f index 01bea27c39..e41279e542 100644 --- a/lapack-netlib/SRC/dstebz.f +++ b/lapack-netlib/SRC/dstebz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEBZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, * M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -31,7 +31,7 @@ * INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,13 +87,18 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. @@ -102,14 +107,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,12 +259,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -263,10 +273,10 @@ SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE diff --git a/lapack-netlib/SRC/dstedc.f b/lapack-netlib/SRC/dstedc.f index 3ae63d9f98..d7f953729c 100644 --- a/lapack-netlib/SRC/dstedc.f +++ b/lapack-netlib/SRC/dstedc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/dstegr.f b/lapack-netlib/SRC/dstegr.f index 298e1c766d..f32860322e 100644 --- a/lapack-netlib/SRC/dstegr.f +++ b/lapack-netlib/SRC/dstegr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEGR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEGR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,7 +48,7 @@ *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> -*> DSTEGR is a compatability wrapper around the improved DSTEMR routine. +*> DSTEGR is a compatibility wrapper around the improved DSTEMR routine. *> See DSTEMR for further details. *> *> One important change is that the ABSTOL parameter no longer provides any @@ -105,13 +105,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -119,14 +123,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -235,12 +244,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * @@ -256,10 +265,10 @@ SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/dstein.f b/lapack-netlib/SRC/dstein.f index 0658fd42e6..fb1e8b9fd5 100644 --- a/lapack-netlib/SRC/dstein.f +++ b/lapack-netlib/SRC/dstein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDZ, M, N * .. @@ -29,7 +29,7 @@ * $ IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -174,10 +174,10 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N @@ -209,8 +209,8 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * .. * .. External Functions .. INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2 - EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2 + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, diff --git a/lapack-netlib/SRC/dstemr.f b/lapack-netlib/SRC/dstemr.f index 8967c18fc6..924d738d04 100644 --- a/lapack-netlib/SRC/dstemr.f +++ b/lapack-netlib/SRC/dstemr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * LOGICAL TRYRAC @@ -33,7 +33,7 @@ * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,13 +136,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -150,14 +154,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -289,12 +298,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * @@ -312,10 +321,10 @@ SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -717,9 +726,9 @@ SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( SCALE.NE.ONE ) THEN CALL DSCAL( M, ONE / SCALE, W, 1 ) END IF - + END IF - + * * If eigenvalues are not in increasing order, then sort them, * possibly along with eigenvectors. diff --git a/lapack-netlib/SRC/dsteqr.f b/lapack-netlib/SRC/dsteqr.f index 9e165bb6bb..c34a548984 100644 --- a/lapack-netlib/SRC/dsteqr.f +++ b/lapack-netlib/SRC/dsteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,22 +119,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/dsterf.f b/lapack-netlib/SRC/dsterf.f index b93cc13dd6..3401894819 100644 --- a/lapack-netlib/SRC/dsterf.f +++ b/lapack-netlib/SRC/dsterf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTERF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTERF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTERF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,22 +74,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTERF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -190,7 +190,7 @@ SUBROUTINE DSTERF( N, D, E, INFO ) ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) - $ GO TO 10 + $ GO TO 10 IF( (ANORM.GT.SSFMAX) ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, diff --git a/lapack-netlib/SRC/dstev.f b/lapack-netlib/SRC/dstev.f index aeca438295..c59eaf3444 100644 --- a/lapack-netlib/SRC/dstev.f +++ b/lapack-netlib/SRC/dstev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ diff --git a/lapack-netlib/SRC/dstevd.f b/lapack-netlib/SRC/dstevd.f index 42648a0ad4..6a07b249ed 100644 --- a/lapack-netlib/SRC/dstevd.f +++ b/lapack-netlib/SRC/dstevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHEReigen * @@ -163,10 +163,10 @@ SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ diff --git a/lapack-netlib/SRC/dstevr.f b/lapack-netlib/SRC/dstevr.f index 941ec97f35..10f1b77201 100644 --- a/lapack-netlib/SRC/dstevr.f +++ b/lapack-netlib/SRC/dstevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -141,13 +144,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -275,12 +282,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -297,10 +304,10 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/dstevx.f b/lapack-netlib/SRC/dstevx.f index cda9de16c9..7acbdaa632 100644 --- a/lapack-netlib/SRC/dstevx.f +++ b/lapack-netlib/SRC/dstevx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSTEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSTEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, M, N @@ -30,7 +30,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,12 +89,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -102,13 +105,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -207,12 +214,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHEReigen * @@ -220,10 +227,10 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/dsycon.f b/lapack-netlib/SRC/dsycon.f index 6e39484caa..66e453659c 100644 --- a/lapack-netlib/SRC/dsycon.f +++ b/lapack-netlib/SRC/dsycon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -130,10 +130,10 @@ SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsycon_3.f b/lapack-netlib/SRC/dsycon_3.f new file mode 100644 index 0000000000..5802aa83f4 --- /dev/null +++ b/lapack-netlib/SRC/dsycon_3.f @@ -0,0 +1,285 @@ +*> \brief \b DSYCON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYCON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric matrix A using the factorization +*> computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver DSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS_3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL DSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DSYCON_3 +* + END diff --git a/lapack-netlib/SRC/dsycon_rook.f b/lapack-netlib/SRC/dsycon_rook.f index 2b8b6f9013..4022adf7e5 100644 --- a/lapack-netlib/SRC/dsycon_rook.f +++ b/lapack-netlib/SRC/dsycon_rook.f @@ -1,26 +1,26 @@ -*> \brief \b DSYCON_ROOK +*> \brief DSYCON_ROOK * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYCON_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,10 +117,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -144,7 +144,7 @@ SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dsyconv.f b/lapack-netlib/SRC/dsyconv.f index 5680876e62..f582bce651 100644 --- a/lapack-netlib/SRC/dsyconv.f +++ b/lapack-netlib/SRC/dsyconv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYCONV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, WAY * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,7 +36,7 @@ *> \verbatim *> *> DSYCONV convert A given by TRF into L and D and vice-versa. -*> Get Non-diag elements of D (returned in workspace) and +*> Get Non-diag elements of D (returned in workspace) and *> apply or reverse permutation done in TRF. *> \endverbatim * @@ -55,7 +55,7 @@ *> \param[in] WAY *> \verbatim *> WAY is CHARACTER*1 -*> = 'C': Convert +*> = 'C': Convert *> = 'R': Revert *> \endverbatim *> @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, WAY @@ -194,7 +194,7 @@ SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) END DO * * Convert PERMUTATIONS -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0) THEN @@ -226,7 +226,7 @@ SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * * * Revert PERMUTATIONS -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/dsyconvf.f b/lapack-netlib/SRC/dsyconvf.f new file mode 100644 index 0000000000..673360fdc1 --- /dev/null +++ b/lapack-netlib/SRC/dsyconvf.f @@ -0,0 +1,559 @@ +*> \brief \b DSYCONVF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCONVF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> DSYCONVF converts the factorization output format used in +*> DSYTRF provided on entry in parameter A into the factorization +*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored +*> on exit in parameters A and E. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in DSYTRF into +*> the format used in DSYTRF_RK (or DSYTRF_BK). +*> +*> If parameter WAY = 'R': +*> DSYCONVF performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in DSYTRF_RK +*> (or DSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in DSYTRF that is stored +*> on exit in parameter A. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in DSYTRF_RK +*> (or DSYTRF_BK) into the format used in DSYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> +*> 1) If WAY ='C': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in DSYTRF. +*> On exit, details of the interchanges and the block +*> structure of D in the format used in DSYTRF_RK +*> ( or DSYTRF_BK). +*> +*> 1) If WAY ='R': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in DSYTRF_RK +*> ( or DSYTRF_BK). +*> On exit, details of the interchanges and the block +*> structure of D in the format used in DSYTRF. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCONVF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i-1 and IPIV(i-1), +* so this should be recorded in two consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I-1 ) +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where k increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i+1 and IPIV(i+1), +* so this should be recorded in consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I+1 ) +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of DSYCONVF +* + END diff --git a/lapack-netlib/SRC/dsyconvf_rook.f b/lapack-netlib/SRC/dsyconvf_rook.f new file mode 100644 index 0000000000..2d163703a4 --- /dev/null +++ b/lapack-netlib/SRC/dsyconvf_rook.f @@ -0,0 +1,544 @@ +*> \brief \b DSYCONVF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCONVF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> DSYCONVF_ROOK converts the factorization output format used in +*> DSYTRF_ROOK provided on entry in parameter A into the factorization +*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored +*> on exit in parameters A and E. IPIV format for DSYTRF_ROOK and +*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. +*> +*> If parameter WAY = 'R': +*> DSYCONVF_ROOK performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in DSYTRF_RK +*> (or DSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in DSYTRF_ROOK that is stored +*> on exit in parameter A. IPIV format for DSYTRF_ROOK and +*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> DSYTRF_RK or DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> DSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On entry, details of the interchanges and the block +*> structure of D as determined: +*> 1) by DSYTRF_ROOK, if WAY ='C'; +*> 2) by DSYTRF_RK (or DSYTRF_BK), if WAY ='R'. +*> The IPIV format is the same for all these routines. +*> +*> On exit, is not changed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, IP2 +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCONVF_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) +* in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + IF( IP2.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP2, I+1 ), LDA ) + END IF + END IF + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) +* in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP2.NE.(I-1) ) THEN + CALL DSWAP( N-I, A( IP2, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL DSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) +* in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + IF( IP2.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP2, 1 ), LDA ) + END IF + END IF + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) +* in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP2.NE.(I+1) ) THEN + CALL DSWAP( I-1, A( IP2, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL DSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of DSYCONVF_ROOK +* + END diff --git a/lapack-netlib/SRC/dsyequb.f b/lapack-netlib/SRC/dsyequb.f index 865acef4c1..dd1dc80bb5 100644 --- a/lapack-netlib/SRC/dsyequb.f +++ b/lapack-netlib/SRC/dsyequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,12 +36,11 @@ *> \verbatim *> *> DSYEQUB computes row and column scalings intended to equilibrate a -*> symmetric matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> symmetric matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -51,30 +50,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> Specifies whether the details of the factorization are stored -*> as an upper or lower triangular matrix. -*> = 'U': Upper triangular, form is A = U*D*U**T; -*> = 'L': Lower triangular, form is A = L*D*L**T. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The N-by-N symmetric matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N symmetric matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -87,21 +83,21 @@ *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -115,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -130,15 +126,15 @@ *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n *> DOI 10.1023/B:NUMA.0000016606.32820.69 \n -*> Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 *> * ===================================================================== SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -153,7 +149,7 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * .. Parameters .. DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) INTEGER MAX_ITER PARAMETER ( MAX_ITER = 100 ) * .. @@ -176,19 +172,19 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. * .. Executable Statements .. * -* Test input parameters. +* Test the input parameters. * INFO = 0 IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'DSYEQUB', -INFO ) - RETURN + CALL XERBLA( 'DSYEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -197,12 +193,12 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -211,7 +207,7 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) DO I = 1, J-1 S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) - AMAX = MAX( AMAX, ABS( A(I, J) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) END DO S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) AMAX = MAX( AMAX, ABS( A( J, J ) ) ) @@ -228,99 +224,95 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) END DO END IF DO J = 1, N - S( J ) = 1.0D+0 / S( J ) + S( J ) = 1.0D0 / S( J ) END DO - TOL = ONE / SQRT(2.0D0 * N) + TOL = ONE / SQRT( 2.0D0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0D+0 - SUMSQ = 0.0D+0 -* BETA = |A|S - DO I = 1, N - WORK(I) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = ABS( A( I, J ) ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) - DO I = J+1, N - T = ABS( A( I, J ) ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) - END DO - END DO - END IF - -* avg = s^T beta / n - AVG = 0.0D+0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N - - STD = 0.0D+0 - DO I = 2*N+1, 3*N - WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG - END DO - CALL DLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + SCALE = 0.0D0 + SUMSQ = 0.0D0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + END DO + END IF - IF ( STD .LT. TOL * AVG ) GOTO 999 +* avg = s^T beta / n + AVG = 0.0D0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - DO I = 1, N - T = ABS( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG - D = C1*C1 - 4*C0*C2 + STD = 0.0D0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL DLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( STD .LT. TOL * AVG ) GOTO 999 - D = SI - S( I ) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = ABS( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = ABS( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = ABS( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = ABS( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF + DO I = 1, N + T = ABS( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -329,13 +321,13 @@ SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BIGNUM = ONE / SMLNUM SMIN = BIGNUM SMAX = ZERO - T = ONE / SQRT(AVG) + T = ONE / SQRT( AVG ) BASE = DLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) * diff --git a/lapack-netlib/SRC/dsyev.f b/lapack-netlib/SRC/dsyev.f index 64b39ed847..ee8c479abe 100644 --- a/lapack-netlib/SRC/dsyev.f +++ b/lapack-netlib/SRC/dsyev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYeigen * * ===================================================================== SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsyev_2stage.f b/lapack-netlib/SRC/dsyev_2stage.f new file mode 100644 index 0000000000..af622fa2ea --- /dev/null +++ b/lapack-netlib/SRC/dsyev_2stage.f @@ -0,0 +1,348 @@ +*> \brief DSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, + $ XERBLA, DSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DORGTR to generate the orthogonal matrix, then call DSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSYEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsyevd.f b/lapack-netlib/SRC/dsyevd.f index 3c9545ac31..2db67846dc 100644 --- a/lapack-netlib/SRC/dsyevd.f +++ b/lapack-netlib/SRC/dsyevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -185,10 +185,10 @@ SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsyevd_2stage.f b/lapack-netlib/SRC/dsyevd_2stage.f new file mode 100644 index 0000000000..d9d080cb1e --- /dev/null +++ b/lapack-netlib/SRC/dsyevd_2stage.f @@ -0,0 +1,406 @@ +*> \brief DSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N+1 +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N+1 +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee \n +*> Modified description of INFO. Sven, 16 Feb 05. \n +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. +* + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, + $ LIWMIN, LLWORK, LLWRK2, LWMIN, + $ LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, + $ DSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + 1 + LHTRD + LWTRD + END IF + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call DORMTR to multiply it by the +* Householder transformations stored in A. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSYEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsyevr.f b/lapack-netlib/SRC/dsyevr.f index 08f363613d..42f6081cf1 100644 --- a/lapack-netlib/SRC/dsyevr.f +++ b/lapack-netlib/SRC/dsyevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -166,13 +169,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,7 +256,9 @@ *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through -*> ISUPPZ( 2*i ). +*> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by DORMTR. *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> @@ -301,12 +310,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup doubleSYeigen * @@ -325,10 +334,10 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -573,7 +582,7 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * * * Apply orthogonal matrix used in reduction to tridiagonal -* form to eigenvectors returned by DSTEIN. +* form to eigenvectors returned by DSTEMR. * IF( WANTZ .AND. INFO.EQ.0 ) THEN INDWKN = INDE diff --git a/lapack-netlib/SRC/dsyevr_2stage.f b/lapack-netlib/SRC/dsyevr_2stage.f new file mode 100644 index 0000000000..ae62582367 --- /dev/null +++ b/lapack-netlib/SRC/dsyevr_2stage.f @@ -0,0 +1,740 @@ +*> \brief DSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVR_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> DSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call +*> to DSYTRD. Then, whenever possible, DSYEVR_2STAGE calls DSTEMR to compute +*> the eigenspectrum using Relatively Robust Representations. DSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see DSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : DSYEVR_2STAGE calls DSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> DSYEVR_2STAGE calls DSTEBZ and SSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of DSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and +*> DSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> DLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> future releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> Supplying N columns is always safe. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by DORMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 26*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 5*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 5*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, + $ TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, + $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, + $ LLWORK, LLWRKN, LWMIN, NSPLIT, + $ LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + $ DSTERF, DSWAP, DSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 26*N, 5*N + LHTRD + LWTRD ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN +* NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) +* NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) +* LWKOPT = MAX( ( NB+1 )*N, LWMIN ) + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVR_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 7 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if DSTERF or DSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the +* elementary reflectors used in DSYTRD. + INDTAU = 1 +* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. + INDD = INDTAU + N +* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from DSYTRD. + INDE = INDD + N +* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over +* -written by DSTEMR (the DSTERF path copies the diagonal to W). + INDDD = INDE + N +* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in DSTERF and DSTEMR. + INDEE = INDDD + N +* INDHOUS is the starting offset Householder storage of stage 2 + INDHOUS = INDEE + N +* INDWK is the starting offset of the left-over workspace, and +* LLWORK is the remaining workspace size. + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* DSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call DSTERF or DSTEMR and DORMTR. +* + IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. + $ IEEEOK.EQ.1 ) THEN + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), + $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, + $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, + $ INFO ) +* +* +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN +* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are +* undefined. + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. +* Also call DSTEBZ and DSTEIN if DSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* +* Jump here if DSTEMR/DSTEIN succeeded. + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. +* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do +* not return this detailed information to the user. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + W( I ) = W( J ) + W( J ) = TMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of DSYEVR_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsyevx.f b/lapack-netlib/SRC/dsyevx.f index cb990e50d1..2fd7bce6b0 100644 --- a/lapack-netlib/SRC/dsyevx.f +++ b/lapack-netlib/SRC/dsyevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,12 +98,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -111,13 +114,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -232,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleSYeigen * @@ -246,10 +253,10 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dsyevx_2stage.f b/lapack-netlib/SRC/dsyevx_2stage.f new file mode 100644 index 0000000000..97ca806fdd --- /dev/null +++ b/lapack-netlib/SRC/dsyevx_2stage.f @@ -0,0 +1,608 @@ +*> \brief DSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 8*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 3*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 3*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, LLWRKN, + $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, + $ DSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 8*N, 3*N + LHTRD + LWTRD ) + WORK( 1 ) = LWMIN + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call DSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDHOUS = INDD + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for +* some eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of DSYEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsygs2.f b/lapack-netlib/SRC/dsygs2.f index 644dcfff1b..a54955c01e 100644 --- a/lapack-netlib/SRC/dsygs2.f +++ b/lapack-netlib/SRC/dsygs2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsygst.f b/lapack-netlib/SRC/dsygst.f index f1d5311c9a..5055acdf1d 100644 --- a/lapack-netlib/SRC/dsygst.f +++ b/lapack-netlib/SRC/dsygst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsygv.f b/lapack-netlib/SRC/dsygv.f index e6d7d3c2d2..651abc5c7b 100644 --- a/lapack-netlib/SRC/dsygv.f +++ b/lapack-netlib/SRC/dsygv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -175,10 +175,10 @@ SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsygv_2stage.f b/lapack-netlib/SRC/dsygv_2stage.f new file mode 100644 index 0000000000..b7da00f517 --- /dev/null +++ b/lapack-netlib/SRC/dsygv_2stage.f @@ -0,0 +1,370 @@ +*> \brief \b DSYGV_2STAGE +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYGV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be symmetric and B is also +*> positive definite. +*> This routine use the 2stage technique for the reduction to tridiagonal +*> which showed higher performance on recent architecture and for large +* sizes N>2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DSYEV returned an error code: +*> <= N: if INFO = i, DSYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER NEIG, LWMIN, LHTRD, LWTRD, KD, IB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DSYGST, DTRMM, DTRSM, XERBLA, + $ DSYEV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYGV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYGV_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsygvd.f b/lapack-netlib/SRC/dsygvd.f index 9c19e938d3..29c78283a7 100644 --- a/lapack-netlib/SRC/dsygvd.f +++ b/lapack-netlib/SRC/dsygvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYeigen * @@ -227,10 +227,10 @@ SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/dsygvx.f b/lapack-netlib/SRC/dsygvx.f index 0ed770637a..aeca6021de 100644 --- a/lapack-netlib/SRC/dsygvx.f +++ b/lapack-netlib/SRC/dsygvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, * VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, * LWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -144,13 +147,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -271,12 +278,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleSYeigen * @@ -290,10 +297,10 @@ SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/dsyrfs.f b/lapack-netlib/SRC/dsyrfs.f index fb807c880e..2732f175be 100644 --- a/lapack-netlib/SRC/dsyrfs.f +++ b/lapack-netlib/SRC/dsyrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -178,12 +178,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -191,10 +191,10 @@ SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsyrfsx.f b/lapack-netlib/SRC/dsyrfsx.f index 95aba2f990..e128cd4e0f 100644 --- a/lapack-netlib/SRC/dsyrfsx.f +++ b/lapack-netlib/SRC/dsyrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -387,10 +387,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -402,7 +402,7 @@ SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -462,12 +462,11 @@ SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, DLANSY, DLA_SYRCOND DOUBLE PRECISION DLAMCH, DLANSY, DLA_SYRCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/dsysv.f b/lapack-netlib/SRC/dsysv.f index cd61e0a560..c9811b5666 100644 --- a/lapack-netlib/SRC/dsysv.f +++ b/lapack-netlib/SRC/dsysv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYsolve * @@ -171,10 +171,10 @@ SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsysv_aa.f b/lapack-netlib/SRC/dsysv_aa.f new file mode 100644 index 0000000000..e458f12bbd --- /dev/null +++ b/lapack-netlib/SRC/dsysv_aa.f @@ -0,0 +1,256 @@ +*> \brief DSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. The factored +*> form of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> DSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for +*> the best performance, LWORK >= MAX(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_AA. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup doubleSYsolve +* +* ===================================================================== + SUBROUTINE DSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_SYTRF, LWKOPT_SYTRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_SYTRF = INT( WORK(1) ) + CALL DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_SYTRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_SYTRF, LWKOPT_SYTRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_AA +* + END diff --git a/lapack-netlib/SRC/dsysv_rk.f b/lapack-netlib/SRC/dsysv_rk.f new file mode 100644 index 0000000000..6a6036be19 --- /dev/null +++ b/lapack-netlib/SRC/dsysv_rk.f @@ -0,0 +1,317 @@ +*> \brief DSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYSV_RK computes the solution to a real system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> DSYTRF_RK is called to compute the factorization of a real +*> symmetric matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine DSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by DSYTRF_RK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by DSYTRF_RK. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF_RK, DSYTRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = P*U*D*(U**T)*(P**T) or +* A = P*U*D*(U**T)*(P**T). +* + CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_RK +* + END diff --git a/lapack-netlib/SRC/dsysv_rook.f b/lapack-netlib/SRC/dsysv_rook.f index 4db3a98ef8..d69c176279 100644 --- a/lapack-netlib/SRC/dsysv_rook.f +++ b/lapack-netlib/SRC/dsysv_rook.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYSV_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -53,7 +53,7 @@ *> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal *> pivoting method. *> -*> The factored form of A is then used to solve the system +*> The factored form of A is then used to solve the system *> of equations A * X = B by calling DSYTRS_ROOK. *> \endverbatim * @@ -154,7 +154,7 @@ *> The length of WORK. LWORK >= 1, and for best performance *> LWORK >= max(1,N*NB), where NB is the optimal blocksize for *> DSYTRF_ROOK. -*> +*> *> TRS will be done with Level 2 BLAS *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -176,10 +176,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -204,7 +204,7 @@ SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dsysvx.f b/lapack-netlib/SRC/dsysvx.f index c43e9a1488..cd059863e0 100644 --- a/lapack-netlib/SRC/dsysvx.f +++ b/lapack-netlib/SRC/dsysvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -32,7 +32,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -270,10 +270,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -284,7 +284,7 @@ SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dsysvxx.f b/lapack-netlib/SRC/dsysvxx.f index baf19fb333..6e167d81e1 100644 --- a/lapack-netlib/SRC/dsysvxx.f +++ b/lapack-netlib/SRC/dsysvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -490,14 +490,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup doubleSYdriver +*> \ingroup doubleSYsolve * * ===================================================================== SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, @@ -505,10 +505,10 @@ SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO @@ -550,7 +550,7 @@ SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, DOUBLE PRECISION DLAMCH, DLA_SYRPVGRW * .. * .. External Subroutines .. - EXTERNAL DSYCON, DSYEQUB, DSYTRF, DSYTRS, + EXTERNAL DSYEQUB, DSYTRF, DSYTRS, $ DLACPY, DLAQSY, XERBLA, DLASCL2, DSYRFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/dsyswapr.f b/lapack-netlib/SRC/dsyswapr.f index 695288924f..6e6c0f7e5c 100644 --- a/lapack-netlib/SRC/dsyswapr.f +++ b/lapack-netlib/SRC/dsyswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYSWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,12 +136,12 @@ SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL DSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -164,12 +164,12 @@ SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from I1 to I1-1 +* - swap row I1 and I2 from I1 to I1-1 CALL DSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP diff --git a/lapack-netlib/SRC/dsytd2.f b/lapack-netlib/SRC/dsytd2.f index a238f9ab3b..6fb4d5507e 100644 --- a/lapack-netlib/SRC/dsytd2.f +++ b/lapack-netlib/SRC/dsytd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytf2.f b/lapack-netlib/SRC/dsytf2.f index 27a676b843..39ef4de7cc 100644 --- a/lapack-netlib/SRC/dsytf2.f +++ b/lapack-netlib/SRC/dsytf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -194,10 +194,10 @@ * ===================================================================== SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytf2_rk.f b/lapack-netlib/SRC/dsytf2_rk.f new file mode 100644 index 0000000000..45cf62ab9d --- /dev/null +++ b/lapack-netlib/SRC/dsytf2_rk.f @@ -0,0 +1,943 @@ +*> \brief \b DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTF2_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = ZERO + A( K-1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL DSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = ZERO + A( K+1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of DSYTF2_RK +* + END diff --git a/lapack-netlib/SRC/dsytrd.f b/lapack-netlib/SRC/dsytrd.f index b268f4c1e4..d330b241fa 100644 --- a/lapack-netlib/SRC/dsytrd.f +++ b/lapack-netlib/SRC/dsytrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytrd_2stage.f b/lapack-netlib/SRC/dsytrd_2stage.f new file mode 100644 index 0000000000..9997ecd253 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_2stage.f @@ -0,0 +1,337 @@ +*> \brief \b DSYTRD_2STAGE +* +* @generated from zhetrd_2stage.f, fortran z -> d, Sun Nov 6 19:34:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, +* HOUS2, LHOUS2, WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER VECT, UPLO +* INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), +* HOUS2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q1**T Q2**T* A * Q2 * Q1 = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> in particular for the second stage (Band to +*> tridiagonal) and thus LHOUS2 is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate Q1 Q2 or to apply Q1 Q2, +*> then LHOUS2 is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the band superdiagonal +*> of A are overwritten by the corresponding elements of the +*> internal band-diagonal matrix AB, and the elements above +*> the KD superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q1 as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and band subdiagonal of A are over- +*> written by the corresponding elements of the internal band-diagonal +*> matrix AB, and the elements below the KD subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q1 as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-KD) +*> The scalar factors of the elementary reflectors of +*> the first stage (see Further Details). +*> \endverbatim +*> +*> \param[out] HOUS2 +*> \verbatim +*> HOUS2 is DOUBLE PRECISION array, dimension LHOUS2, that +*> store the Householder representation of the stage2 +*> band to tridiagonal. +*> \endverbatim +*> +*> \param[in] LHOUS2 +*> \verbatim +*> LHOUS2 is INTEGER +*> The dimension of the array HOUS2. LHOUS2 = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS2 array, returns +*> this value as the first entry of the HOUS2 array, and no error +*> message related to LHOUS2 is issued by XERBLA. +*> LHOUS2 = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, + $ HOUS2, LHOUS2, WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER VECT, UPLO + INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), + $ HOUS2( * ), WORK( * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTQ + INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRD_SY2SB, DSYTRD_SB2ST +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', VECT, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) +* WRITE(*,*),'DSYTRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, +* $ LHMIN, LWMIN +* + IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDAB = KD+1 + LWRK = LWORK-LDAB*N + ABPOS = 1 + WPOS = ABPOS + LDAB*N + CALL DSYTRD_SY2SB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, + $ TAU, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) + RETURN + END IF + CALL DSYTRD_SB2ST( 'Y', VECT, UPLO, N, KD, + $ WORK( ABPOS ), LDAB, D, E, + $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) + RETURN + END IF +* +* + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_2STAGE +* + END diff --git a/lapack-netlib/SRC/dsytrd_sb2st.F b/lapack-netlib/SRC/dsytrd_sb2st.F new file mode 100644 index 0000000000..59ef01381d --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_sb2st.F @@ -0,0 +1,556 @@ +*> \brief \b DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_SB2ST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, +* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* #if defined(_OPENMP) +* use omp_lib +* #endif +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER STAGE1, UPLO, VECT +* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] STAGE +*> \verbatim +*> STAGE is CHARACTER*1 +*> = 'N': "No": to mention that the stage 1 of the reduction +*> from dense to band using the dsytrd_sy2sb routine +*> was not called before this routine to reproduce AB. +*> In other term this routine is called as standalone. +*> = 'Y': "Yes": to mention that the stage 1 of the +*> reduction from dense to band using the dsytrd_sy2sb +*> routine has been called to produce AB (e.g., AB is +*> the output of dsytrd_sy2sb. +*> \endverbatim +*> +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> and thus LHOUS is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate or to apply Q later on, +*> then LHOUS is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] HOUS +*> \verbatim +*> HOUS is DOUBLE PRECISION array, dimension LHOUS, that +*> store the Householder representation. +*> \endverbatim +*> +*> \param[in] LHOUS +*> \verbatim +*> LHOUS is INTEGER +*> The dimension of the array HOUS. LHOUS = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS array, returns +*> this value as the first entry of the HOUS array, and no error +*> message related to LHOUS is issued by XERBLA. +*> LHOUS = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup real16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, + $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +#if defined(_OPENMP) + use omp_lib +#endif +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER STAGE1, UPLO, VECT + INTEGER N, KD, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RZERO + DOUBLE PRECISION ZERO, ONE + PARAMETER ( RZERO = 0.0D+0, + $ ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 + INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, + $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, + $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, + $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, + $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, + $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, + $ SIDEV, SIZETAU, LDV, LHMIN, LWMIN +* .. +* .. External Subroutines .. + EXTERNAL DSB2ST_KERNELS, DLACPY, DLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX, CEILING, REAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required. +* Test the input parameters +* + DEBUG = 0 + INFO = 0 + AFTERS1 = LSAME( STAGE1, 'Y' ) + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + IB = ILAENV( 18, 'DSYTRD_SB2ST', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) +* + IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.(KD+1) ) THEN + INFO = -7 + ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDV = KD + IB + SIZETAU = 2 * N + SIDEV = 2 * N + INDTAU = 1 + INDV = INDTAU + SIZETAU + LDA = 2 * KD + 1 + SIZEA = LDA * N + INDA = 1 + INDW = INDA + SIZEA + NTHREADS = 1 + TID = 0 +* + IF( UPPER ) THEN + APOS = INDA + KD + AWPOS = INDA + DPOS = APOS + KD + OFDPOS = DPOS - 1 + ABDPOS = KD + 1 + ABOFDPOS = KD + ELSE + APOS = INDA + AWPOS = INDA + KD + 1 + DPOS = APOS + OFDPOS = DPOS + 1 + ABDPOS = 1 + ABOFDPOS = 2 + + ENDIF +* +* Case KD=0: +* The matrix is diagonal. We just copy it (convert to "real" for +* real because D is double and the imaginary part should be 0) +* and store it in D. A sequential code here is better or +* in a parallel environment it might need two cores for D and E +* + IF( KD.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 30 CONTINUE + DO 40 I = 1, N-1 + E( I ) = RZERO + 40 CONTINUE +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Case KD=1: +* The matrix is already Tridiagonal. We have to make diagonal +* and offdiagonal elements real, and store them in D and E. +* For that, for real precision just copy the diag and offdiag +* to D and E while for the COMPLEX case the bulge chasing is +* performed to convert the hermetian tridiagonal to symmetric +* tridiagonal. A simpler coversion formula might be used, but then +* updating the Q matrix will be required and based if Q is generated +* or not this might complicate the story. +* + IF( KD.EQ.1 ) THEN + DO 50 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 50 CONTINUE +* + IF( UPPER ) THEN + DO 60 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I+1 ) ) + 60 CONTINUE + ELSE + DO 70 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I ) ) + 70 CONTINUE + ENDIF +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Main code start here. +* Reduce the symmetric band of A to a tridiagonal matrix. +* + THGRSIZ = N + GRSIZ = 1 + SHIFT = 3 + NBTILES = CEILING( REAL(N)/REAL(KD) ) + STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) + THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) +* + CALL DLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) + CALL DLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) +* +* +* openMP parallelisation start here +* +#if defined(_OPENMP) +!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) +!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) +!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) +!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) +!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) +!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT ) +!$OMP MASTER +#endif +* +* main bulge chasing loop +* + DO 100 THGRID = 1, THGRNB + STT = (THGRID-1)*THGRSIZ+1 + THED = MIN( (STT + THGRSIZ -1), (N-1)) + DO 110 I = STT, N-1 + ED = MIN( I, THED ) + IF( STT.GT.ED ) EXIT + DO 120 M = 1, STEPERCOL + ST = STT + DO 130 SWEEPID = ST, ED + DO 140 K = 1, GRSIZ + MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) + $ + (M-1)*GRSIZ + K + IF ( MYID.EQ.1 ) THEN + TTYPE = 1 + ELSE + TTYPE = MOD( MYID, 2 ) + 2 + ENDIF + + IF( TTYPE.EQ.2 ) THEN + COLPT = (MYID/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + BLKLASTIND = COLPT + ELSE + COLPT = ((MYID+1)/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + IF( ( STIND.GE.EDIND-1 ).AND. + $ ( EDIND.EQ.N ) ) THEN + BLKLASTIND = N + ELSE + BLKLASTIND = 0 + ENDIF + ENDIF +* +* Call the kernel +* +#if defined(_OPENMP) + IF( TTYPE.NE.1 ) THEN +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(in:WORK(MYID-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ELSE +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ENDIF +#else + CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +#endif + IF ( BLKLASTIND.GE.(N-1) ) THEN + STT = STT + 1 + EXIT + ENDIF + 140 CONTINUE + 130 CONTINUE + 120 CONTINUE + 110 CONTINUE + 100 CONTINUE +* +#if defined(_OPENMP) +!$OMP END MASTER +!$OMP END PARALLEL +#endif +* +* Copy the diagonal from A to D. Note that D is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + DO 150 I = 1, N + D( I ) = ( WORK( DPOS+(I-1)*LDA ) ) + 150 CONTINUE +* +* Copy the off diagonal from A to E. Note that E is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + IF( UPPER ) THEN + DO 160 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+I*LDA ) ) + 160 CONTINUE + ELSE + DO 170 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+(I-1)*LDA ) ) + 170 CONTINUE + ENDIF +* + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_SB2ST +* + END + diff --git a/lapack-netlib/SRC/dsytrd_sy2sb.f b/lapack-netlib/SRC/dsytrd_sy2sb.f new file mode 100644 index 0000000000..a0e028a302 --- /dev/null +++ b/lapack-netlib/SRC/dsytrd_sy2sb.f @@ -0,0 +1,517 @@ +*> \brief \b DSYTRD_SY2SB +* +* @generated from zhetrd_he2hb.f, fortran z -> d, Wed Dec 7 08:22:39 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRD_SY2SB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), +* TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric +*> band-diagonal form AB by a orthogonal similarity transformation: +*> Q**T * A * Q = AB. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the reduced matrix if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> The reduced matrix is stored in the array AB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AB +*> \verbatim +*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> On exit, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-KD) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK. +*> On exit, if INFO = 0, or if LWORK=-1, +*> WORK(1) returns the size of LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK which should be calculated +* by a workspace query. LWORK = MAX(1, LWORK_QUERY) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +*> where FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice otherwise +*> putting LWORK=-1 will provide the size of WORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in +*> A(i,i+kd+1:n), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in +* A(i+kd+2:n,i), and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( ab ab/v1 v1 v1 v1 ) ( ab ) +*> ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) +*> ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) +*> ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) +*> ( ab ) ( v1 v2 v3 ab/v4 ab ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RONE + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( RONE = 1.0D+0, + $ ZERO = 0.0D+0, + $ ONE = 1.0D+0, + $ HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, J, IINFO, LWMIN, PN, PK, LK, + $ LDT, LDW, LDS2, LDS1, + $ LS2, LS1, LW, LT, + $ TPOS, WPOS, S2POS, S1POS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYR2K, DSYMM, DGEMM, + $ DLARFT, DGELQF, DGEQRF, DLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required +* and test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + LWMIN = ILAENV( 20, 'DSYTRD_SY2SB', '', N, KD, -1, -1 ) + + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWMIN + RETURN + END IF +* +* Quick return if possible +* Copy the upper/lower portion of A into AB +* + IF( N.LE.KD+1 ) THEN + IF( UPPER ) THEN + DO 100 I = 1, N + LK = MIN( KD+1, I ) + CALL DCOPY( LK, A( I-LK+1, I ), 1, + $ AB( KD+1-LK+1, I ), 1 ) + 100 CONTINUE + ELSE + DO 110 I = 1, N + LK = MIN( KD+1, N-I+1 ) + CALL DCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) + 110 CONTINUE + ENDIF + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the pointer position for the workspace +* + LDT = KD + LDS1 = KD + LT = LDT*KD + LW = N*KD + LS1 = LDS1*KD + LS2 = LWMIN - LT - LW - LS1 +* LS2 = N*MAX(KD,FACTOPTNB) + TPOS = 1 + WPOS = TPOS + LT + S1POS = WPOS + LW + S2POS = S1POS + LS1 + IF( UPPER ) THEN + LDW = KD + LDS2 = KD + ELSE + LDW = N + LDS2 = N + ENDIF +* +* +* Set the workspace of the triangular matrix T to zero once such a +* way everytime T is generated the upper/lower portion will be always zero +* + CALL DLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) +* + IF( UPPER ) THEN + DO 10 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the LQ factorization of the current block +* + CALL DGELQF( KD, PN, A( I, I+KD ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 20 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 20 CONTINUE +* + CALL DLASET( 'Lower', PK, PK, ZERO, ONE, + $ A( I, I+KD ), LDA ) +* +* Form the matrix T +* + CALL DLARFT( 'Forward', 'Rowwise', PN, PK, + $ A( I, I+KD ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL DGEMM( 'Conjugate', 'No transpose', PK, PN, PK, + $ ONE, WORK( TPOS ), LDT, + $ A( I, I+KD ), LDA, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL DSYMM( 'Right', UPLO, PK, PN, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL DGEMM( 'No transpose', 'Conjugate', PK, PK, PN, + $ ONE, WORK( WPOS ), LDW, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL DGEMM( 'No transpose', 'No transpose', PK, PN, PK, + $ -HALF, WORK( S1POS ), LDS1, + $ A( I, I+KD ), LDA, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V'*W - W'*V +* + CALL DSYR2K( UPLO, 'Conjugate', PN, PK, + $ -ONE, A( I, I+KD ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) + 10 CONTINUE +* +* Copy the upper band to AB which is the band storage matrix +* + DO 30 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 30 CONTINUE +* + ELSE +* +* Reduce the lower triangle of A to lower band matrix +* + DO 40 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the QR factorization of the current block +* + CALL DGEQRF( PN, KD, A( I+KD, I ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 50 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 50 CONTINUE +* + CALL DLASET( 'Upper', PK, PK, ZERO, ONE, + $ A( I+KD, I ), LDA ) +* +* Form the matrix T +* + CALL DLARFT( 'Forward', 'Columnwise', PN, PK, + $ A( I+KD, I ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ ONE, A( I+KD, I ), LDA, + $ WORK( TPOS ), LDT, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL DSYMM( 'Left', UPLO, PN, PK, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL DGEMM( 'Conjugate', 'No transpose', PK, PK, PN, + $ ONE, WORK( S2POS ), LDS2, + $ WORK( WPOS ), LDW, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ -HALF, A( I+KD, I ), LDA, + $ WORK( S1POS ), LDS1, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', PN, PK, + $ -ONE, A( I+KD, I ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) +* ================================================================== +* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED +* DO 45 J = I, I+PK-1 +* LK = MIN( KD, N-J ) + 1 +* CALL DCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) +* 45 CONTINUE +* ================================================================== + 40 CONTINUE +* +* Copy the lower band to AB which is the band storage matrix +* + DO 60 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 60 CONTINUE + + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of DSYTRD_SY2SB +* + END diff --git a/lapack-netlib/SRC/dsytrf.f b/lapack-netlib/SRC/dsytrf.f index a0b83c7c94..d8da4f122a 100644 --- a/lapack-netlib/SRC/dsytrf.f +++ b/lapack-netlib/SRC/dsytrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -182,10 +182,10 @@ * ===================================================================== SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytrf_aa.f b/lapack-netlib/SRC/dsytrf_aa.f new file mode 100644 index 0000000000..c3d598b28a --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_aa.f @@ -0,0 +1,480 @@ +*> \brief \b DSYTRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRF_AA computes the factorization of a real symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a symmetric tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N). For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + DOUBLE PRECISION ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL DCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with DGEMM +* + CALL DGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL DCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with DGEMM +* + CALL DGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of DSYTRF_AA +* + END diff --git a/lapack-netlib/SRC/dsytrf_rk.f b/lapack-netlib/SRC/dsytrf_rk.f new file mode 100644 index 0000000000..e6fc4ece1e --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRF_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASYF_RK, DSYTF2_RK, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLASYF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL DLASYF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL DSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLASYF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL DLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL DSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL DSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRF_RK +* + END diff --git a/lapack-netlib/SRC/dsytrf_rook.f b/lapack-netlib/SRC/dsytrf_rook.f index 81264872ad..d2690499f1 100644 --- a/lapack-netlib/SRC/dsytrf_rook.f +++ b/lapack-netlib/SRC/dsytrf_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRF_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,10 +141,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -208,7 +208,7 @@ * ===================================================================== SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -261,7 +261,7 @@ SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'DSYTRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * @@ -321,7 +321,7 @@ SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + $ INFO = IINFO * * No need to adjust IPIV * diff --git a/lapack-netlib/SRC/dsytri.f b/lapack-netlib/SRC/dsytri.f index bbafae41a1..f093a13992 100644 --- a/lapack-netlib/SRC/dsytri.f +++ b/lapack-netlib/SRC/dsytri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytri2.f b/lapack-netlib/SRC/dsytri2.f index d943e68d9f..0d5b029d66 100644 --- a/lapack-netlib/SRC/dsytri2.f +++ b/lapack-netlib/SRC/dsytri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/dsytri2x.f b/lapack-netlib/SRC/dsytri2x.f index a2474d8b0c..bcd5c94249 100644 --- a/lapack-netlib/SRC/dsytri2x.f +++ b/lapack-netlib/SRC/dsytri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -212,7 +212,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -228,7 +228,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -245,8 +245,8 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K+1,INVD) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K+1,INVD) = -AKKP1 / D K=K+2 END IF END DO @@ -262,7 +262,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -272,7 +272,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -335,7 +335,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**T*invD1*U11->U11 * CALL DTRMM('L','U','T','U',NNB, NNB, @@ -345,13 +345,13 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) DO J=I,NNB A(CUT+I,CUT+J)=WORK(U11+I,J) END DO - END DO + END DO * * U01**T*invD*U01->A(CUT+I,CUT+J) * CALL DGEMM('T','N',NNB,NNB,CUT,ONE,A(1,CUT+1),LDA, $ WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * U11 = U11**T*invD1*U11 + U01**T*invD*U01 * @@ -380,7 +380,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -390,9 +390,9 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL DSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -406,7 +406,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -423,8 +423,8 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K-1,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K-1,INVD+1) = -AKKP1 / D K=K-2 END IF END DO @@ -440,7 +440,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -507,7 +507,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**T*invD1*L11->L11 * CALL DTRMM('L',UPLO,'T','U',NNB, NNB, @@ -526,7 +526,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL DGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**T*invD1*L11 + U01**T*invD*U01 * @@ -566,7 +566,7 @@ SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/dsytri_3.f b/lapack-netlib/SRC/dsytri_3.f new file mode 100644 index 0000000000..3437e14140 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_3.f @@ -0,0 +1,248 @@ +*> \brief \b DSYTRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRI_3 computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> DSYTRI_3 sets the leading dimension of the workspace before calling +*> DSYTRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSYTRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'DSYTRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYTRI_3 +* + END diff --git a/lapack-netlib/SRC/dsytri_3x.f b/lapack-netlib/SRC/dsytri_3x.f new file mode 100644 index 0000000000..fecde38f34 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_3x.f @@ -0,0 +1,645 @@ +*> \brief \b DSYTRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRI_3X computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J, + $ U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DSYSWAPR, DTRTRI, DTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K+1, 1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = WORK( K, INVD+1 ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = ONE + DO J = 1, I-1 + WORK( U11+I, J ) = ZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**T * invD1 * U11 -> U11 +* + CALL DTRMM( 'L', 'U', 'T', 'U', NNB, NNB, + $ ONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**T * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL DGEMM( 'T', 'N', NNB, NNB, CUT, ONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, ZERO, WORK(U11+1,1), N+NB+1 ) + +* +* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T * invD0 * U01 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', CUT, NNB, + $ ONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**T) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K-1, 1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = WORK( K, INVD+1 ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**T) = (inv(L))**T +* +* inv(L**T) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = ONE + DO J = I+1, NNB + WORK( U11+I, J ) = ZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**T * invD1 * L11 -> L11 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, ONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL DGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, ONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ ZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T * invD2 * L21 +* + CALL DTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, ONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**T * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**T) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of DSYTRI_3X +* + END + diff --git a/lapack-netlib/SRC/dsytri_rook.f b/lapack-netlib/SRC/dsytri_rook.f index f5b42a2974..cad2a7e9f3 100644 --- a/lapack-netlib/SRC/dsytri_rook.f +++ b/lapack-netlib/SRC/dsytri_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRI_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,10 +102,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -129,7 +129,7 @@ * ===================================================================== SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -300,7 +300,7 @@ SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) IF( KP.GT.1 ) $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) -* +* TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP @@ -391,7 +391,7 @@ SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 - END IF + END IF * IF( KSTEP.EQ.1 ) THEN * diff --git a/lapack-netlib/SRC/dsytrs.f b/lapack-netlib/SRC/dsytrs.f index 9aae7b130b..e5988f20f3 100644 --- a/lapack-netlib/SRC/dsytrs.f +++ b/lapack-netlib/SRC/dsytrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dsytrs2.f b/lapack-netlib/SRC/dsytrs2.f index 09a87fe3dc..c7ca8e9ffa 100644 --- a/lapack-netlib/SRC/dsytrs2.f +++ b/lapack-netlib/SRC/dsytrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,7 +106,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (N) +*> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO @@ -119,23 +119,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== - SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -200,7 +200,7 @@ SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**T. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -225,7 +225,7 @@ SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL DTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -277,7 +277,7 @@ SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**T. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -302,7 +302,7 @@ SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL DTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -324,7 +324,7 @@ SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] -* +* CALL DTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/dsytrs_3.f b/lapack-netlib/SRC/dsytrs_3.f new file mode 100644 index 0000000000..85c09e01b8 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_3.f @@ -0,0 +1,371 @@ +*> \brief \b DSYTRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DSYTRS_3 solves a system of linear equations A * X = B with a real +*> symmetric matrix A using the factorization computed +*> by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_RK or DSYTRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL DTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL DTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of DSYTRS_3 +* + END diff --git a/lapack-netlib/SRC/dsytrs_aa.f b/lapack-netlib/SRC/dsytrs_aa.f new file mode 100644 index 0000000000..b572581e53 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_aa.f @@ -0,0 +1,285 @@ +*> \brief \b DSYTRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS_AA solves a system of linear equations A*X = B with a real +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by DSYTRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> Details of factors computed by DSYTRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by DSYTRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleSYcomputational +* +* ===================================================================== + SUBROUTINE DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGTSV, DSWAP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A( 1, 1 ), LDA+1, WORK( N ), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK( N ), WORK( 2*N ), B, LDB, + $ INFO ) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL DTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK(N), WORK( 2*N ), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL DTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of DSYTRS_AA +* + END diff --git a/lapack-netlib/SRC/dsytrs_rook.f b/lapack-netlib/SRC/dsytrs_rook.f index b1cb9b152c..94a5e0042a 100644 --- a/lapack-netlib/SRC/dsytrs_rook.f +++ b/lapack-netlib/SRC/dsytrs_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DSYTRS_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,10 +108,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -136,7 +136,7 @@ SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dtbcon.f b/lapack-netlib/SRC/dtbcon.f index 6962ad50a2..ec0d3a15a1 100644 --- a/lapack-netlib/SRC/dtbcon.f +++ b/lapack-netlib/SRC/dtbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -143,10 +143,10 @@ SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dtbrfs.f b/lapack-netlib/SRC/dtbrfs.f index e2d5a3e685..05bfb7348f 100644 --- a/lapack-netlib/SRC/dtbrfs.f +++ b/lapack-netlib/SRC/dtbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -175,12 +175,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtbtrs.f b/lapack-netlib/SRC/dtbtrs.f index 15c75d2b7d..e5fb876592 100644 --- a/lapack-netlib/SRC/dtbtrs.f +++ b/lapack-netlib/SRC/dtbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -146,10 +146,10 @@ SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtfsm.f b/lapack-netlib/SRC/dtfsm.f index 3b5720f4dd..515f6f5438 100644 --- a/lapack-netlib/SRC/dtfsm.f +++ b/lapack-netlib/SRC/dtfsm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTFSM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTFSM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO * INTEGER LDB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -277,10 +277,10 @@ SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, $ B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtftri.f b/lapack-netlib/SRC/dtftri.f index a8a6a0bdc2..9debec9702 100644 --- a/lapack-netlib/SRC/dtftri.f +++ b/lapack-netlib/SRC/dtftri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO, DIAG * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -201,10 +201,10 @@ * ===================================================================== SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO, DIAG diff --git a/lapack-netlib/SRC/dtfttp.f b/lapack-netlib/SRC/dtfttp.f index 36ec09bfd9..c2929824af 100644 --- a/lapack-netlib/SRC/dtfttp.f +++ b/lapack-netlib/SRC/dtfttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTFTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTFTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,12 +88,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dtfttr.f b/lapack-netlib/SRC/dtfttr.f index 384f680c9c..bb1c6224f5 100644 --- a/lapack-netlib/SRC/dtfttr.f +++ b/lapack-netlib/SRC/dtfttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTFTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTFTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -196,10 +196,10 @@ * ===================================================================== SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dtgevc.f b/lapack-netlib/SRC/dtgevc.f index a988f52df3..756474c9e0 100644 --- a/lapack-netlib/SRC/dtgevc.f +++ b/lapack-netlib/SRC/dtgevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGEVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGEVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, * LDVL, VR, LDVR, MM, M, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N @@ -30,8 +30,8 @@ * DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -49,20 +49,20 @@ *> *> The right eigenvector x and the left eigenvector y of (S,P) *> corresponding to an eigenvalue w are defined by: -*> +*> *> S*x = w*P*x, (y**H)*S = w*(y**H)*P, -*> +*> *> where y**H denotes the conjugate tranpose of y. *> The eigenvalues are not input to this routine, but are computed *> directly from the diagonal blocks of S and P. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of (S,P), or the products Z*X and/or Q*Y, *> where Z and Q are input matrices. *> If Q and Z are the orthogonal factors from the generalized Schur *> factorization of a matrix pair (A,B), then Z*X and Q*Y *> are the matrices of right and left eigenvectors of (A,B). -*> +*> *> \endverbatim * * Arguments: @@ -179,7 +179,7 @@ *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part and the second the imaginary part. -*> +*> *> Not referenced if SIDE = 'L'. *> \endverbatim *> @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -295,10 +295,10 @@ SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/dtgex2.f b/lapack-netlib/SRC/dtgex2.f index 45eb166f49..93ff03acf6 100644 --- a/lapack-netlib/SRC/dtgex2.f +++ b/lapack-netlib/SRC/dtgex2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGEX2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGEX2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, J1, N1, N2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleGEauxiliary * @@ -221,10 +221,10 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -314,7 +314,7 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) * -* THRES has been changed from +* THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) diff --git a/lapack-netlib/SRC/dtgexc.f b/lapack-netlib/SRC/dtgexc.f index 4a55bf00af..0a905b8db3 100644 --- a/lapack-netlib/SRC/dtgexc.f +++ b/lapack-netlib/SRC/dtgexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, IFST, ILST, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -190,12 +190,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleGEcomputational * @@ -220,10 +220,10 @@ SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ diff --git a/lapack-netlib/SRC/dtgsen.f b/lapack-netlib/SRC/dtgsen.f index 82b17626fd..9f49239344 100644 --- a/lapack-netlib/SRC/dtgsen.f +++ b/lapack-netlib/SRC/dtgsen.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, * PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, @@ -35,7 +35,7 @@ * $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -249,7 +249,7 @@ *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, -*> dimension (MAX(1,LWORK)) +*> dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> @@ -300,12 +300,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup doubleOTHERcomputational * @@ -452,10 +452,10 @@ SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -542,6 +542,7 @@ SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * M = 0 PAIR = .FALSE. + IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. @@ -561,6 +562,7 @@ SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, END IF END IF 10 CONTINUE + END IF * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) diff --git a/lapack-netlib/SRC/dtgsja.f b/lapack-netlib/SRC/dtgsja.f index ceae9295d9..66f32b7909 100644 --- a/lapack-netlib/SRC/dtgsja.f +++ b/lapack-netlib/SRC/dtgsja.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGSJA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGSJA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, * LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, * Q, LDQ, WORK, NCYCLE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, @@ -33,7 +33,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -345,12 +345,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -378,10 +378,10 @@ SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/dtgsna.f b/lapack-netlib/SRC/dtgsna.f index 80394fa47c..68a68cad88 100644 --- a/lapack-netlib/SRC/dtgsna.f +++ b/lapack-netlib/SRC/dtgsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, * LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -225,12 +225,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -381,10 +381,10 @@ SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/dtgsy2.f b/lapack-netlib/SRC/dtgsy2.f index f4fe7e1488..1c687b15e2 100644 --- a/lapack-netlib/SRC/dtgsy2.f +++ b/lapack-netlib/SRC/dtgsy2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGSY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGSY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, * IWORK, PQ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, @@ -33,7 +33,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. -* +* * *> \par Purpose: * ============= @@ -254,12 +254,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleSYauxiliary * @@ -274,10 +274,10 @@ SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ IWORK, PQ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dtgsyl.f b/lapack-netlib/SRC/dtgsyl.f index d589016a65..1cc3a1bf89 100644 --- a/lapack-netlib/SRC/dtgsyl.f +++ b/lapack-netlib/SRC/dtgsyl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTGSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTGSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, @@ -34,7 +34,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -256,12 +256,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -299,10 +299,10 @@ SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/dtpcon.f b/lapack-netlib/SRC/dtpcon.f index 2619891193..9932a76ab7 100644 --- a/lapack-netlib/SRC/dtpcon.f +++ b/lapack-netlib/SRC/dtpcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -130,10 +130,10 @@ SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dtplqt.f b/lapack-netlib/SRC/dtplqt.f new file mode 100644 index 0000000000..b312c501fd --- /dev/null +++ b/lapack-netlib/SRC/dtplqt.f @@ -0,0 +1,270 @@ +*> \brief \b DTPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DTPLQT2, DTPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of DTPLQT +* + END diff --git a/lapack-netlib/SRC/dtplqt2.f b/lapack-netlib/SRC/dtplqt2.f new file mode 100644 index 0000000000..7e87e6c5b6 --- /dev/null +++ b/lapack-netlib/SRC/dtplqt2.f @@ -0,0 +1,312 @@ +*> \brief \b DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPLQT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT2 computes a LQ a factorization of a real "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular M-by-M matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,M) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ][ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ][ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L lower trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> +*> C = [ A ][ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ][ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> W = [ V1 ][ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W**T * T * W +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ONE = 1.0, ZERO = 0.0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DGEMV, DGER, DTRMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, M +* +* Generate elementary reflector H(I) to annihilate B(I,:) +* + P = N-L+MIN( L, I ) + CALL DLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) ) + IF( I.LT.M ) THEN +* +* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] +* + DO J = 1, M-I + T( M, J ) = (A( I+J, I )) + END DO + CALL DGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB, + $ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT ) +* +* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H +* + ALPHA = -(T( 1, I )) + DO J = 1, M-I + A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J )) + END DO + CALL DGER( M-I, P, ALPHA, T( M, 1 ), LDT, + $ B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + END IF + END DO +* + DO I = 2, M +* +* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H) +* + ALPHA = -T( 1, I ) + + DO J = 1, I-1 + T( I, J ) = ZERO + END DO + P = MIN( I-1, L ) + NP = MIN( N-L+1, N ) + MP = MIN( P+1, M ) +* +* Triangular part of B2 +* + DO J = 1, P + T( I, J ) = ALPHA*B( I, N-L+J ) + END DO + CALL DTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB, + $ T( I, 1 ), LDT ) +* +* Rectangular part of B2 +* + CALL DGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB, + $ B( I, NP ), LDB, ZERO, T( I,MP ), LDT ) +* +* B1 +* + CALL DGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB, + $ ONE, T( I, 1 ), LDT ) +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) +* + CALL DTRMV( 'L', 'T', 'N', I-1, T, LDT, T( I, 1 ), LDT ) +* +* T(I,I) = tau(I) +* + T( I, I ) = T( 1, I ) + T( 1, I ) = ZERO + END DO + DO I=1,M + DO J= I+1,M + T(I,J)=T(J,I) + T(J,I)= ZERO + END DO + END DO + +* +* End of DTPLQT2 +* + END diff --git a/lapack-netlib/SRC/dtpmlqt.f b/lapack-netlib/SRC/dtpmlqt.f new file mode 100644 index 0000000000..fd31bed57a --- /dev/null +++ b/lapack-netlib/SRC/dtpmlqt.f @@ -0,0 +1,366 @@ +*> \brief \b DTPMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMQRT applies a real orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DTPLQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTPLQT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DTPLQT, stored as a MB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. The dimension of WORK is +*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] [V2]. +*> +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. + DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, NB, LB, KF, LDAQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.K ) THEN + INFO = -9 + ELSE IF( LDT.LT.MB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL DTPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL DTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL DTPRFB( 'R', 'T', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of DTPMLQT +* + END diff --git a/lapack-netlib/SRC/dtpmqrt.f b/lapack-netlib/SRC/dtpmqrt.f index e8ace7038e..ba9fdf858e 100644 --- a/lapack-netlib/SRC/dtpmqrt.f +++ b/lapack-netlib/SRC/dtpmqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * A, LDA, B, LDB, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. -* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), +* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), * $ T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DTPMQRT applies a real orthogonal matrix Q obtained from a +*> DTPMQRT applies a real orthogonal matrix Q obtained from a *> "triangular-pentagonal" real block reflector H to a general *> real matrix C, which consists of two blocks A and B. *> \endverbatim @@ -69,7 +69,7 @@ *> N is INTEGER *> The number of columns of the matrix B. N >= 0. *> \endverbatim -*> +*> *> \param[in] K *> \verbatim *> K is INTEGER @@ -80,7 +80,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -124,19 +124,19 @@ *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension -*> (LDA,N) if SIDE = 'L' or +*> (LDA,N) if SIDE = 'L' or *> (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of +*> On exit, A is overwritten by the corresponding block of *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -150,7 +150,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -185,20 +185,20 @@ *> \verbatim *> *> The columns of the pentagonal matrix V contain the elementary reflectors -*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a *> trapezoidal block V2: *> *> V = [V1] *> [V2]. *> -*> The size of the trapezoidal block V2 is determined by the parameter L, +*> The size of the trapezoidal block V2 is determined by the parameter L, *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. *> -*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. -*> [B] -*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. +*> [B] +*> *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. *> *> The real orthogonal matrix Q is formed from V and T. @@ -216,17 +216,17 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. - DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), + DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), $ T( LDT, * ), WORK( * ) * .. * @@ -242,7 +242,7 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, DLARFB + EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -256,7 +256,7 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF ( LEFT ) THEN LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) @@ -275,7 +275,7 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN - INFO = -6 + INFO = -6 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN @@ -307,11 +307,11 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-M+L-I+1 END IF - CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB @@ -322,8 +322,8 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-N+L-I+1 END IF - CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * @@ -331,15 +331,15 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 - END IF + END IF CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * @@ -347,7 +347,7 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 @@ -355,7 +355,7 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, LB = MB-N+L-I+1 END IF CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * diff --git a/lapack-netlib/SRC/dtpqrt.f b/lapack-netlib/SRC/dtpqrt.f index c8f2e14c14..1a3f95475b 100644 --- a/lapack-netlib/SRC/dtpqrt.f +++ b/lapack-netlib/SRC/dtpqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DTPQRT computes a blocked QR factorization of a real -*> "triangular-pentagonal" matrix C, which is composed of a -*> triangular block A and pentagonal block B, using the compact +*> DTPQRT computes a blocked QR factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact *> WY representation for Q. *> \endverbatim * @@ -46,7 +46,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -88,7 +88,7 @@ *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -105,7 +105,7 @@ *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See Further Details. *> \endverbatim -*> +*> *> \param[in] LDT *> \verbatim *> LDT is INTEGER @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -141,10 +141,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -154,8 +154,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -169,17 +169,17 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> *> The number of blocks is B = ceiling(N/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. @@ -189,10 +189,10 @@ SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -240,7 +240,7 @@ SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, IF( M.EQ.0 .OR. N.EQ.0 ) RETURN * DO I = 1, N, NB -* +* * Compute the QR factorization of the current block * IB = MIN( N-I+1, NB ) @@ -251,20 +251,20 @@ SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, LB = MB-M+L-I+1 END IF * - CALL DTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, + CALL DTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, $ T(1, I ), LDT, IINFO ) * * Update by applying H**T to B(:,I+IB:N) from the left * IF( I+IB.LE.N ) THEN CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N-I-IB+1, IB, LB, - $ B( 1, I ), LDB, T( 1, I ), LDT, - $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, + $ B( 1, I ), LDB, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, $ WORK, IB ) END IF END DO RETURN -* +* * End of DTPQRT * END diff --git a/lapack-netlib/SRC/dtpqrt2.f b/lapack-netlib/SRC/dtpqrt2.f index ca2da232f5..2e18f4e3a0 100644 --- a/lapack-netlib/SRC/dtpqrt2.f +++ b/lapack-netlib/SRC/dtpqrt2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> DTPQRT2 computes a QR factorization of a real "triangular-pentagonal" -*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> matrix C, which is composed of a triangular block A and pentagonal block B, *> using the compact WY representation for Q. *> \endverbatim * @@ -44,7 +44,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The total number of rows of the matrix B. +*> The total number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -59,7 +59,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The number of rows of the upper trapezoidal part of B. +*> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> @@ -80,7 +80,7 @@ *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -128,10 +128,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -141,8 +141,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -156,12 +156,12 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> The (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**T @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L @@ -227,7 +227,7 @@ SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) RETURN -* +* DO I = 1, N * * Generate elementary reflector H(I) to annihilate B(:,I) @@ -241,16 +241,16 @@ SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) DO J = 1, N-I T( J, N ) = (A( I, I+J )) END DO - CALL DGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, + CALL DGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) * * C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H * - ALPHA = -(T( I, 1 )) + ALPHA = -(T( I, 1 )) DO J = 1, N-I A( I, I+J ) = A( I, I+J ) + ALPHA*(T( J, N )) END DO - CALL DGER( P, N-I, ALPHA, B( 1, I ), 1, + CALL DGER( P, N-I, ALPHA, B( 1, I ), 1, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO @@ -278,13 +278,13 @@ SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * Rectangular part of B2 * - CALL DGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, + CALL DGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) * * B1 * - CALL DGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, - $ ONE, T( 1, I ), 1 ) + CALL DGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, + $ ONE, T( 1, I ), 1 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * @@ -295,7 +295,7 @@ SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO - + * * End of DTPQRT2 * diff --git a/lapack-netlib/SRC/dtprfb.f b/lapack-netlib/SRC/dtprfb.f index 08976d06e1..6ae8fad8c4 100644 --- a/lapack-netlib/SRC/dtprfb.f +++ b/lapack-netlib/SRC/dtprfb.f @@ -2,44 +2,44 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPRFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPRFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, +* SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ V( LDV, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DTPRFB applies a real "triangular-pentagonal" block reflector H or its -*> transpose H**T to a real matrix C, which is composed of two +*> DTPRFB applies a real "triangular-pentagonal" block reflector H or its +*> transpose H**T to a real matrix C, which is composed of two *> blocks A and B, either from the left or right. -*> +*> *> \endverbatim * * Arguments: @@ -80,14 +80,14 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The number of columns of the matrix B. +*> The number of columns of the matrix B. *> N >= 0. *> \endverbatim *> @@ -95,14 +95,14 @@ *> \verbatim *> K is INTEGER *> The order of the matrix T, i.e. the number of elementary -*> reflectors whose product defines the block reflector. +*> reflectors whose product defines the block reflector. *> K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -129,13 +129,13 @@ *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the -*> block reflector. +*> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER -*> The leading dimension of the array T. +*> The leading dimension of the array T. *> LDT >= K. *> \endverbatim *> @@ -144,16 +144,16 @@ *> A is DOUBLE PRECISION array, dimension *> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of -*> H*C or H**T*C or C*H or C*H**T. See Futher Details. +*> On exit, A is overwritten by the corresponding block of +*> H*C or H**T*C or C*H or C*H**T. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -167,7 +167,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -182,19 +182,19 @@ *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= K; +*> If SIDE = 'L', LDWORK >= K; *> if SIDE = 'R', LDWORK >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -204,21 +204,21 @@ *> \verbatim *> *> The matrix C is a composite matrix formed from blocks A and B. -*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, +*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, *> and if SIDE = 'L', A is of size K-by-N. *> *> If SIDE = 'R' and DIRECT = 'F', C = [A B]. *> -*> If SIDE = 'L' and DIRECT = 'F', C = [A] +*> If SIDE = 'L' and DIRECT = 'F', C = [A] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] -*> [A]. +*> [A]. *> -*> The pentagonal matrix V is composed of a rectangular block V1 and a -*> trapezoidal block V2. The size of the trapezoidal block is determined by +*> The pentagonal matrix V is composed of a rectangular block V1 and a +*> trapezoidal block V2. The size of the trapezoidal block is determined by *> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; *> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. *> @@ -235,7 +235,7 @@ *> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] -*> +*> *> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) *> *> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. @@ -248,20 +248,20 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, + SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * @@ -322,7 +322,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END IF * * --------------------------------------------------------------------------- -* +* IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -336,34 +336,34 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - T (A + V**T B) or A = A - T**T (A + V**T B) -* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) +* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) -* +* DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( MP, 1 ), LDV, - $ WORK, LDWORK ) - CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, + $ WORK, LDWORK ) + CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, $ ONE, WORK, LDWORK ) - CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, + CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) -* +* DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) @@ -373,7 +373,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, - $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N @@ -383,7 +383,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -402,7 +402,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) @@ -410,20 +410,20 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) - CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, + CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, $ V, LDV, ONE, WORK, LDWORK ) - CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -443,7 +443,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -457,7 +457,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - T (A + V**T B) or A = A - T**T (A + V**T B) -* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) +* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) * * --------------------------------------------------------------------------- * @@ -472,10 +472,10 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) - CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, + CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V, LDV, - $ B, LDB, ZERO, WORK, LDWORK ) + $ B, LDB, ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K @@ -483,16 +483,16 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, + CALL DTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * - CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, + CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) @@ -505,7 +505,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -524,7 +524,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) @@ -532,20 +532,20 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) - CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, + CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) - CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V, LDV, ZERO, WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -565,7 +565,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -578,7 +578,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - T (A + V B) or A = A - T**T (A + V B) -* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) +* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) * * --------------------------------------------------------------------------- * @@ -589,12 +589,12 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO - END DO + END DO CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDB ) - CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, + CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, $ ONE, WORK, LDWORK ) - CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, + CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N @@ -603,7 +603,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N @@ -614,7 +614,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) - CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, + CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) @@ -625,7 +625,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -653,7 +653,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ WORK, LDWORK ) CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B, LDB, V, LDV, $ ONE, WORK, LDWORK ) - CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, + CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K @@ -662,7 +662,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -671,10 +671,10 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, - $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) + $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L @@ -684,7 +684,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -697,7 +697,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - T (A + V B) or A = A - T**T (A + V B) -* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) +* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) * * --------------------------------------------------------------------------- * @@ -733,10 +733,10 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) - CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, + CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, - $ WORK( KP, 1 ), LDWORK ) + $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) @@ -744,7 +744,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -773,7 +773,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, V, LDV, - $ ZERO, WORK, LDWORK ) + $ ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M @@ -781,7 +781,7 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -790,9 +790,9 @@ SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) - CALL DGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, + CALL DGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) diff --git a/lapack-netlib/SRC/dtprfs.f b/lapack-netlib/SRC/dtprfs.f index b5a5809f66..2dc427e459 100644 --- a/lapack-netlib/SRC/dtprfs.f +++ b/lapack-netlib/SRC/dtprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -175,10 +175,10 @@ SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtptri.f b/lapack-netlib/SRC/dtptri.f index 9e8aa1ce0b..32f38344ec 100644 --- a/lapack-netlib/SRC/dtptri.f +++ b/lapack-netlib/SRC/dtptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -117,10 +117,10 @@ * ===================================================================== SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/dtptrs.f b/lapack-netlib/SRC/dtptrs.f index abce4588c8..c62724128f 100644 --- a/lapack-netlib/SRC/dtptrs.f +++ b/lapack-netlib/SRC/dtptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtpttf.f b/lapack-netlib/SRC/dtpttf.f index f79babc673..a37a3e30a1 100644 --- a/lapack-netlib/SRC/dtpttf.f +++ b/lapack-netlib/SRC/dtpttf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dtpttr.f b/lapack-netlib/SRC/dtpttr.f index 1c11deb8e7..6258179938 100644 --- a/lapack-netlib/SRC/dtpttr.f +++ b/lapack-netlib/SRC/dtpttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTPTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTPTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dtrcon.f b/lapack-netlib/SRC/dtrcon.f index 80578d6180..ad40d3774a 100644 --- a/lapack-netlib/SRC/dtrcon.f +++ b/lapack-netlib/SRC/dtrcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -137,10 +137,10 @@ SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/dtrevc.f b/lapack-netlib/SRC/dtrevc.f index 62e5029125..921f5143ac 100644 --- a/lapack-netlib/SRC/dtrevc.f +++ b/lapack-netlib/SRC/dtrevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTREVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, MM, M, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, M, MM, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,16 +41,16 @@ *> a real upper quasi-triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. -*> +*> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: -*> -*> T*x = w*x, (y**T)*T = w*(y**T) -*> -*> where y**T denotes the transpose of y. +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal blocks of T. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the orthogonal factor that reduces a matrix @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -222,10 +222,10 @@ SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/dtrevc3.f b/lapack-netlib/SRC/dtrevc3.f new file mode 100644 index 0000000000..e6c0f2ffba --- /dev/null +++ b/lapack-netlib/SRC/dtrevc3.f @@ -0,0 +1,1304 @@ +*> \brief \b DTREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, +* VR, LDVR, MM, M, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTREVC3 computes some or all of the right and/or left eigenvectors of +*> a real upper quasi-triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal blocks of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the orthogonal factor that reduces a matrix +*> A to Schur form T, then Q*X and Q*Y are the matrices of right and +*> left eigenvectors of A. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed by the matrices in VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> If w(j) is a real eigenvalue, the corresponding real +*> eigenvector is computed if SELECT(j) is .TRUE.. +*> If w(j) and w(j+1) are the real and imaginary parts of a +*> complex eigenvalue, the corresponding complex eigenvector is +*> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +*> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +*> .FALSE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper quasi-triangular matrix T in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by DHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part, and the second the imaginary part. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by DHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part and the second the imaginary part. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected real eigenvector occupies one column and each +*> selected complex eigenvector occupies two columns. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,3*N). +*> For optimum performance, LWORK >= N + 2*N*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran d -> s +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, + $ VR, LDVR, MM, M, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NBMIN, NBMAX + PARAMETER ( NBMIN = 8, NBMAX = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, PAIR, + $ RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, + $ IV, MAXWRK, NB, KI2 + DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, ILAENV, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA, + $ DGEMM, DLASET, DLABAD +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + DOUBLE PRECISION X( 2, 2 ) + INTEGER ISCOMPLEX( NBMAX ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + NB = ILAENV( 1, 'DTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) + MAXWRK = N + 2*N*NB + WORK(1) = MAXWRK + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN + INFO = -14 + ELSE +* +* Set M to the number of columns required to store the selected +* eigenvectors, standardize the array SELECT if necessary, and +* test MM. +* + IF( SOMEV ) THEN + M = 0 + PAIR = .FALSE. + DO 10 J = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( J ) = .FALSE. + ELSE + IF( J.LT.N ) THEN + IF( T( J+1, J ).EQ.ZERO ) THEN + IF( SELECT( J ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN + SELECT( J ) = .TRUE. + M = M + 2 + END IF + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -11 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREVC3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN + NB = (LWORK - N) / (2*N) + NB = MIN( NB, NBMAX ) + CALL DLASET( 'F', N, 1+2*NB, ZERO, ZERO, WORK, N ) + ELSE + NB = 1 + END IF +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 30 J = 2, N + WORK( J ) = ZERO + DO 20 I = 1, J - 1 + WORK( J ) = WORK( J ) + ABS( T( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* +* Index IP is used to specify the real or complex eigenvalue: +* IP = 0, real eigenvalue, +* 1, first of conjugate complex pair: (wr,wi) +* -1, second of conjugate complex pair: (wr,wi) +* ISCOMPLEX array stores IP for each column in current block. +* + IF( RIGHTV ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* For complex right vector, uses IV-1 for real part and IV for complex part. +* Non-blocked version always uses IV=2; +* blocked version starts with IV=NB, goes down to 1 or 2. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 2 + IF( NB.GT.2 ) THEN + IV = NB + END IF + + IP = 0 + IS = M + DO 140 KI = N, 1, -1 + IF( IP.EQ.-1 ) THEN +* previous iteration (ki+1) was second of conjugate pair, +* so this ki is first of conjugate pair; skip to end of loop + IP = 1 + GO TO 140 + ELSE IF( KI.EQ.1 ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI, KI-1 ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is second of conjugate pair + IP = -1 + END IF + + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 140 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 140 + END IF + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* + $ SQRT( ABS( T( KI-1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* -------------------------------------------------------- +* Real right eigenvector +* + WORK( KI + IV*N ) = ONE +* +* Form right-hand side. +* + DO 50 K = 1, KI - 1 + WORK( K + IV*N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve upper quasi-triangular system: +* [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. +* + JNXT = KI - 1 + DO 60 J = KI - 1, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 60 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+IV*N ), N, WR, ZERO, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(2,1) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 2, 1 ) = X( 2, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) + WORK( J-1+IV*N ) = X( 1, 1 ) + WORK( J +IV*N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+IV*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL DCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) +* + II = IDAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / ABS( VR( II, IS ) ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 70 K = KI + 1, N + VR( K, IS ) = ZERO + 70 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.1 ) + $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1 + IV*N ), 1, WORK( KI + IV*N ), + $ VR( 1, KI ), 1 ) +* + II = IDAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / ABS( VR( II, KI ) ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + END IF + ELSE +* +* -------------------------------------------------------- +* Complex right eigenvector. +* +* Initial solve +* [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. +* [ ( T(KI, KI-1) T(KI, KI) ) ] +* + IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN + WORK( KI-1 + (IV-1)*N ) = ONE + WORK( KI + (IV )*N ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1 + (IV-1)*N ) = -WI / T( KI, KI-1 ) + WORK( KI + (IV )*N ) = ONE + END IF + WORK( KI + (IV-1)*N ) = ZERO + WORK( KI-1 + (IV )*N ) = ZERO +* +* Form right-hand side. +* + DO 80 K = 1, KI - 2 + WORK( K+(IV-1)*N ) = -WORK( KI-1+(IV-1)*N )*T(K,KI-1) + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(K,KI ) + 80 CONTINUE +* +* Solve upper quasi-triangular system: +* [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) +* + JNXT = KI - 2 + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+(IV-1)*N ), N, + $ WR, WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(1,2) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 1, 2 ) = X( 1, 2 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J+(IV-1)*N ) = X( 1, 1 ) + WORK( J+(IV )*N ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+(IV-1)*N ), N, WR, WI, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + REC = ONE / XNORM + X( 1, 1 ) = X( 1, 1 )*REC + X( 1, 2 ) = X( 1, 2 )*REC + X( 2, 1 ) = X( 2, 1 )*REC + X( 2, 2 ) = X( 2, 2 )*REC + SCALE = SCALE*REC + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J-1+(IV-1)*N ) = X( 1, 1 ) + WORK( J +(IV-1)*N ) = X( 2, 1 ) + WORK( J-1+(IV )*N ) = X( 1, 2 ) + WORK( J +(IV )*N ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV )*N ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL DCOPY( KI, WORK( 1+(IV-1)*N ), 1, VR(1,IS-1), 1 ) + CALL DCOPY( KI, WORK( 1+(IV )*N ), 1, VR(1,IS ), 1 ) +* + EMAX = ZERO + DO 100 K = 1, KI + EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ + $ ABS( VR( K, IS ) ) ) + 100 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 110 K = KI + 1, N + VR( K, IS-1 ) = ZERO + VR( K, IS ) = ZERO + 110 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.2 ) THEN + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV-1)*N ), 1, + $ WORK( KI-1 + (IV-1)*N ), VR(1,KI-1), 1) + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), VR( 1, KI ), 1 ) + ELSE + CALL DSCAL( N, WORK(KI-1+(IV-1)*N), VR(1,KI-1), 1) + CALL DSCAL( N, WORK(KI +(IV )*N), VR(1,KI ), 1) + END IF +* + EMAX = ZERO + DO 120 K = 1, N + EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ + $ ABS( VR( K, KI ) ) ) + 120 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + (IV-1)*N ) = ZERO + WORK( K + (IV )*N ) = ZERO + END DO + ISCOMPLEX( IV-1 ) = -IP + ISCOMPLEX( IV ) = IP + IV = IV - 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI-1 and KI) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI - 1 + END IF + +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.LE.2) .OR. (KI2.EQ.1) ) THEN + CALL DGEMM( 'N', 'N', N, NB-IV+1, KI2+NB-IV, ONE, + $ VR, LDVR, + $ WORK( 1 + (IV)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+IV)*N ), N ) +* normalize vectors + DO K = IV, NB + IF( ISCOMPLEX(K).EQ.0 ) THEN +* real eigenvector + II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1 ) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL DLACPY( 'F', N, NB-IV+1, + $ WORK( 1 + (NB+IV)*N ), N, + $ VR( 1, KI2 ), LDVR ) + IV = NB + ELSE + IV = IV - 1 + END IF + END IF ! blocked back-transform +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 140 CONTINUE + END IF + + IF( LEFTV ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* For complex left vector, uses IV for real part and IV+1 for complex part. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB-1 or NB. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 1 + IP = 0 + IS = 1 + DO 260 KI = 1, N + IF( IP.EQ.1 ) THEN +* previous iteration (ki-1) was first of conjugate pair, +* so this ki is second of conjugate pair; skip to end of loop + IP = -1 + GO TO 260 + ELSE IF( KI.EQ.N ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI+1, KI ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is first of conjugate pair + IP = 1 + END IF +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 260 + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* + $ SQRT( ABS( T( KI+1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* -------------------------------------------------------- +* Real left eigenvector +* + WORK( KI + IV*N ) = ONE +* +* Form right-hand side. +* + DO 160 K = KI + 1, N + WORK( K + IV*N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 1 + DO 170 J = KI + 1, N + IF( J.LT.JNXT ) + $ GO TO 170 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve [ T(J,J) - WR ]**T * X = WORK +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+IV*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* + WORK( J+1+IV*N ) = WORK( J+1+IV*N ) - + $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve +* [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) +* [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J +IV*N ) = X( 1, 1 ) + WORK( J+1+IV*N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J +IV*N ) ), + $ ABS( WORK( J+1+IV*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL DCOPY( N-KI+1, WORK( KI + IV*N ), 1, + $ VL( KI, IS ), 1 ) +* + II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / ABS( VL( II, IS ) ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 180 K = 1, KI - 1 + VL( K, IS ) = ZERO + 180 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N ) + $ CALL DGEMV( 'N', N, N-KI, ONE, + $ VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 + IV*N ), 1, + $ WORK( KI + IV*N ), VL( 1, KI ), 1 ) +* + II = IDAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / ABS( VL( II, KI ) ) + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + END IF + ELSE +* +* -------------------------------------------------------- +* Complex left eigenvector. +* +* Initial solve: +* [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. +* [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] +* + IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN + WORK( KI + (IV )*N ) = WI / T( KI, KI+1 ) + WORK( KI+1 + (IV+1)*N ) = ONE + ELSE + WORK( KI + (IV )*N ) = ONE + WORK( KI+1 + (IV+1)*N ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1 + (IV )*N ) = ZERO + WORK( KI + (IV+1)*N ) = ZERO +* +* Form right-hand side. +* + DO 190 K = KI + 2, N + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(KI, K) + WORK( K+(IV+1)*N ) = -WORK( KI+1+(IV+1)*N )*T(KI+1,K) + 190 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 2 + DO 200 J = KI + 2, N + IF( J.LT.JNXT ) + $ GO TO 200 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when +* forming the right-hand side elements. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+(IV )*N ) = WORK( J+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) + WORK( J+(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* +* Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J+(IV )*N ) = X( 1, 1 ) + WORK( J+(IV+1)*N ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+(IV )*N ) ), + $ ABS( WORK( J+(IV+1)*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side elements. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) + CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J +(IV )*N ) = WORK( J+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J +(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* + WORK( J+1+(IV )*N ) = WORK( J+1+(IV)*N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J+1+(IV+1)*N ) = WORK( J+1+(IV+1)*N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* +* Solve 2-by-2 complex linear equation +* [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B +* [ (T(j+1,j) T(j+1,j+1)) ] +* + CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) + CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J +(IV )*N ) = X( 1, 1 ) + WORK( J +(IV+1)*N ) = X( 1, 2 ) + WORK( J+1+(IV )*N ) = X( 2, 1 ) + WORK( J+1+(IV+1)*N ) = X( 2, 2 ) + VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), + $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), + $ VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 200 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL DCOPY( N-KI+1, WORK( KI + (IV )*N ), 1, + $ VL( KI, IS ), 1 ) + CALL DCOPY( N-KI+1, WORK( KI + (IV+1)*N ), 1, + $ VL( KI, IS+1 ), 1 ) +* + EMAX = ZERO + DO 220 K = KI, N + EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ + $ ABS( VL( K, IS+1 ) ) ) + 220 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) +* + DO 230 K = 1, KI - 1 + VL( K, IS ) = ZERO + VL( K, IS+1 ) = ZERO + 230 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N-1 ) THEN + CALL DGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), + $ VL( 1, KI ), 1 ) + CALL DGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV+1)*N ), 1, + $ WORK( KI+1 + (IV+1)*N ), + $ VL( 1, KI+1 ), 1 ) + ELSE + CALL DSCAL( N, WORK(KI+ (IV )*N), VL(1, KI ), 1) + CALL DSCAL( N, WORK(KI+1+(IV+1)*N), VL(1, KI+1), 1) + END IF +* + EMAX = ZERO + DO 240 K = 1, N + EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ + $ ABS( VL( K, KI+1 ) ) ) + 240 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) + CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + (IV )*N ) = ZERO + WORK( K + (IV+1)*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP + ISCOMPLEX( IV+1 ) = -IP + IV = IV + 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI and KI+1) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI + 1 + END IF + +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.GE.NB-1) .OR. (KI2.EQ.N) ) THEN + CALL DGEMM( 'N', 'N', N, IV, N-KI2+IV, ONE, + $ VL( 1, KI2-IV+1 ), LDVL, + $ WORK( KI2-IV+1 + (1)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+1)*N ), N ) +* normalize vectors + DO K = 1, IV + IF( ISCOMPLEX(K).EQ.0) THEN +* real eigenvector + II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL DLACPY( 'F', N, IV, + $ WORK( 1 + (NB+1)*N ), N, + $ VL( 1, KI2-IV+1 ), LDVL ) + IV = 1 + ELSE + IV = IV + 1 + END IF + END IF ! blocked back-transform +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 260 CONTINUE + END IF +* + RETURN +* +* End of DTREVC3 +* + END diff --git a/lapack-netlib/SRC/dtrexc.f b/lapack-netlib/SRC/dtrexc.f index 4ac8d9d590..468ae47b95 100644 --- a/lapack-netlib/SRC/dtrexc.f +++ b/lapack-netlib/SRC/dtrexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTREXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -63,6 +63,7 @@ *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. *> \endverbatim *> *> \param[in,out] T @@ -92,7 +93,8 @@ *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] IFST @@ -133,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -146,10 +148,10 @@ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ @@ -193,9 +195,9 @@ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN diff --git a/lapack-netlib/SRC/dtrrfs.f b/lapack-netlib/SRC/dtrrfs.f index 7668d60118..c9fe55c721 100644 --- a/lapack-netlib/SRC/dtrrfs.f +++ b/lapack-netlib/SRC/dtrrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtrsen.f b/lapack-netlib/SRC/dtrsen.f index 01417323dd..1fa126c5be 100644 --- a/lapack-netlib/SRC/dtrsen.f +++ b/lapack-netlib/SRC/dtrsen.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, * M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, JOB * INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), * $ WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -225,10 +225,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -313,7 +313,7 @@ SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dtrsna.f b/lapack-netlib/SRC/dtrsna.f index 6dcd20a951..2966e5fb5a 100644 --- a/lapack-netlib/SRC/dtrsna.f +++ b/lapack-netlib/SRC/dtrsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -208,12 +208,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -265,10 +265,10 @@ SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/dtrsyl.f b/lapack-netlib/SRC/dtrsyl.f index 0d16d9cfed..105032cb33 100644 --- a/lapack-netlib/SRC/dtrsyl.f +++ b/lapack-netlib/SRC/dtrsyl.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, * LDC, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANA, TRANB * INTEGER INFO, ISGN, LDA, LDB, LDC, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleSYcomputational * @@ -164,10 +164,10 @@ SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB diff --git a/lapack-netlib/SRC/dtrti2.f b/lapack-netlib/SRC/dtrti2.f index edf1b5b003..0a9d5b696c 100644 --- a/lapack-netlib/SRC/dtrti2.f +++ b/lapack-netlib/SRC/dtrti2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/dtrtri.f b/lapack-netlib/SRC/dtrtri.f index 5d27ca56af..d34b40bcc0 100644 --- a/lapack-netlib/SRC/dtrtri.f +++ b/lapack-netlib/SRC/dtrtri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/dtrtrs.f b/lapack-netlib/SRC/dtrtrs.f index 416a66e7cc..3e5ff6fda1 100644 --- a/lapack-netlib/SRC/dtrtrs.f +++ b/lapack-netlib/SRC/dtrtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -140,10 +140,10 @@ SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/dtrttf.f b/lapack-netlib/SRC/dtrttf.f index 69b502a710..8e91c3df81 100644 --- a/lapack-netlib/SRC/dtrttf.f +++ b/lapack-netlib/SRC/dtrttf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * @@ -194,10 +194,10 @@ * ===================================================================== SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/dtrttp.f b/lapack-netlib/SRC/dtrttp.f index 58c4083f84..ac10ef4beb 100644 --- a/lapack-netlib/SRC/dtrttp.f +++ b/lapack-netlib/SRC/dtrttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTRTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTRTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/dtzrzf.f b/lapack-netlib/SRC/dtzrzf.f index 00f70fc157..0d4f922c89 100644 --- a/lapack-netlib/SRC/dtzrzf.f +++ b/lapack-netlib/SRC/dtzrzf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DTZRZF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DTZRZF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,10 +111,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -142,7 +142,7 @@ *> *> V = ( I A(:,M+1:N) ) *> -*> I is the M-by-M identity matrix, A(:,M+1:N) +*> I is the M-by-M identity matrix, A(:,M+1:N) *> is the output stored in A on exit from DTZRZF, *> and tau(k) is the kth element of the array TAU. *> @@ -151,7 +151,7 @@ * ===================================================================== SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/dzsum1.f b/lapack-netlib/SRC/dzsum1.f index bfa032cacf..70a404283e 100644 --- a/lapack-netlib/SRC/dzsum1.f +++ b/lapack-netlib/SRC/dzsum1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DZSUM1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DZSUM1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 CX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,12 +64,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -81,10 +81,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/icmax1.f b/lapack-netlib/SRC/icmax1.f index 74d1c7f9ff..4141473878 100644 --- a/lapack-netlib/SRC/icmax1.f +++ b/lapack-netlib/SRC/icmax1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ICMAX1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ICMAX1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ICMAX1( N, CX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX CX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,10 +64,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date February 2014 * @@ -81,7 +81,7 @@ * ===================================================================== INTEGER FUNCTION ICMAX1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- * February 2014 diff --git a/lapack-netlib/SRC/ieeeck.f b/lapack-netlib/SRC/ieeeck.f index 132e436770..2655958b4a 100644 --- a/lapack-netlib/SRC/ieeeck.f +++ b/lapack-netlib/SRC/ieeeck.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download IEEECK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* +* * .. Scalar Arguments .. * INTEGER ISPEC * REAL ONE, ZERO * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ISPEC diff --git a/lapack-netlib/SRC/ilaclc.f b/lapack-netlib/SRC/ilaclc.f index 4bd639d1bf..35d86d2307 100644 --- a/lapack-netlib/SRC/ilaclc.f +++ b/lapack-netlib/SRC/ilaclc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILACLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILACLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILACLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILACLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/ilaclr.f b/lapack-netlib/SRC/ilaclr.f index 617d670a7d..c2e0584bb9 100644 --- a/lapack-netlib/SRC/ilaclr.f +++ b/lapack-netlib/SRC/ilaclr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILACLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILACLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILACLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILACLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/iladiag.f b/lapack-netlib/SRC/iladiag.f index 1d5c5bff18..58614d2682 100644 --- a/lapack-netlib/SRC/iladiag.f +++ b/lapack-netlib/SRC/iladiag.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILADIAG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILADIAG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADIAG( DIAG ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILADIAG( DIAG ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG diff --git a/lapack-netlib/SRC/iladlc.f b/lapack-netlib/SRC/iladlc.f index b56387d320..c6476113d1 100644 --- a/lapack-netlib/SRC/iladlc.f +++ b/lapack-netlib/SRC/iladlc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILADLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILADLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/iladlr.f b/lapack-netlib/SRC/iladlr.f index fe155af075..e8951d86cc 100644 --- a/lapack-netlib/SRC/iladlr.f +++ b/lapack-netlib/SRC/iladlr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILADLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILADLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/ilaenv.f b/lapack-netlib/SRC/ilaenv.f index 89a4468fff..2be0581517 100644 --- a/lapack-netlib/SRC/ilaenv.f +++ b/lapack-netlib/SRC/ilaenv.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAENV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. -* +* * *> \par Purpose: * ============= @@ -127,14 +127,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -162,10 +162,10 @@ * ===================================================================== INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -183,13 +183,14 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ + INTEGER IEEECK, IPARMQ, IPARAM2STAGE + EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE * .. * .. Executable Statements .. * GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC + $ 130, 140, 150, 160, 160, 160, 160, 160, + $ 170, 170, 170, 170, 170 )ISPEC * * Invalid value for ISPEC * @@ -283,6 +284,52 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NB = 32 END IF + ELSE IF( C3.EQ.'QR ') THEN + IF( N3 .EQ. 1) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF + ELSE IF( C3.EQ.'LQ ') THEN + IF( N3 .EQ. 2) THEN + IF( SNAME ) THEN +* M*N + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + ELSE + IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN + NB = N1 + ELSE + NB = 32768/N2 + END IF + END IF + ELSE + IF( SNAME ) THEN + NB = 1 + ELSE + NB = 1 + END IF + END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 @@ -397,6 +444,12 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NB = 64 END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN @@ -637,6 +690,13 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) RETURN +* + 170 CONTINUE +* +* 17 <= ISPEC <= 21: 2stage eigenvalues and SVD or related subroutines. +* + ILAENV = IPARAM2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN * * End of ILAENV * diff --git a/lapack-netlib/SRC/ilaprec.f b/lapack-netlib/SRC/ilaprec.f index 88ae77e4d7..f1f32ac4b2 100644 --- a/lapack-netlib/SRC/ilaprec.f +++ b/lapack-netlib/SRC/ilaprec.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAPREC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAPREC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAPREC( PREC ) -* +* * .. Scalar Arguments .. * CHARACTER PREC * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILAPREC( PREC ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER PREC diff --git a/lapack-netlib/SRC/ilaslc.f b/lapack-netlib/SRC/ilaslc.f index e1dc426caf..d7770fd4ba 100644 --- a/lapack-netlib/SRC/ilaslc.f +++ b/lapack-netlib/SRC/ilaslc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILASLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILASLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILASLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILASLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/ilaslr.f b/lapack-netlib/SRC/ilaslr.f index 9436dc4085..910bc800d0 100644 --- a/lapack-netlib/SRC/ilaslr.f +++ b/lapack-netlib/SRC/ilaslr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILASLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILASLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILASLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILASLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/ilatrans.f b/lapack-netlib/SRC/ilatrans.f index d8fc9bc643..6b90bfc765 100644 --- a/lapack-netlib/SRC/ilatrans.f +++ b/lapack-netlib/SRC/ilatrans.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILATRANS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILATRANS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILATRANS( TRANS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILATRANS( TRANS ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/ilauplo.f b/lapack-netlib/SRC/ilauplo.f index e65c103e7e..89bc9b225e 100644 --- a/lapack-netlib/SRC/ilauplo.f +++ b/lapack-netlib/SRC/ilauplo.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAUPLO + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAUPLO + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAUPLO( UPLO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILAUPLO( UPLO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ilaver.f b/lapack-netlib/SRC/ilaver.f index c882d03f5e..a99f727d52 100644 --- a/lapack-netlib/SRC/ilaver.f +++ b/lapack-netlib/SRC/ilaver.f @@ -2,8 +2,8 @@ ** * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH -* +* * *> \par Purpose: * ============= @@ -25,40 +25,46 @@ * ========== * *> \param[out] VERS_MAJOR +*> \verbatim *> return the lapack major version +*> \endverbatim *> *> \param[out] VERS_MINOR +*> \verbatim *> return the lapack minor version from the major version +*> \endverbatim *> *> \param[out] VERS_PATCH +*> \verbatim *> return the lapack patch version from the minor version +*> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * ===================================================================== * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 - VERS_MINOR = 6 + VERS_MINOR = 7 VERS_PATCH = 0 * ===================================================================== * diff --git a/lapack-netlib/SRC/ilazlc.f b/lapack-netlib/SRC/ilazlc.f index 718b277dfa..07dfc93e31 100644 --- a/lapack-netlib/SRC/ilazlc.f +++ b/lapack-netlib/SRC/ilazlc.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAZLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAZLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLC( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/ilazlr.f b/lapack-netlib/SRC/ilazlr.f index 44697214c7..4ca4ed1a44 100644 --- a/lapack-netlib/SRC/ilazlr.f +++ b/lapack-netlib/SRC/ilazlr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ILAZLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ILAZLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILAZLR( M, N, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/SRC/iparam2stage.F b/lapack-netlib/SRC/iparam2stage.F new file mode 100644 index 0000000000..0fc1795140 --- /dev/null +++ b/lapack-netlib/SRC/iparam2stage.F @@ -0,0 +1,386 @@ +*> \brief \b IPARAM2STAGE +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARAM2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, +* NI, NBI, IBI, NXI ) +* #if defined(_OPENMP) +* use omp_lib +* #endif +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, NI, NBI, IBI, NXI +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHETRD_2STAGE, xHETRD_H@2HB, xHETRD_HB2ST, +*> xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD +*> and related subroutines for eigenvalue problems. +*> It is called whenever ILAENV is called with 17 <= ISPEC <= 21 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARAM2STAGE should +*> return. +*> +*> ISPEC=17: the optimal blocksize nb for the reduction to +* BAND +*> +*> ISPEC=18: the optimal blocksize ib for the eigenvectors +*> singular vectors update routine +*> +*> ISPEC=19: The length of the array that store the Housholder +*> representation for the second stage +*> Band to Tridiagonal or Bidiagonal +*> +*> ISPEC=20: The workspace needed for the routine in input. +*> +*> ISPEC=21: For future release. +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] NI +*> \verbatim +*> NI is INTEGER which is the size of the matrix +*> \endverbatim +*> +*> \param[in] NBI +*> \verbatim +*> NBI is INTEGER which is the used in the reduciton, +* (e.g., the size of the band), needed to compute workspace +* and LHOUS2. +*> \endverbatim +*> +*> \param[in] IBI +*> \verbatim +*> IBI is INTEGER which represent the IB of the reduciton, +* needed to compute workspace and LHOUS2. +*> \endverbatim +*> +*> \param[in] NXI +*> \verbatim +*> NXI is INTEGER needed in the future release. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All detail are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, + $ NI, NBI, IBI, NXI ) +#if defined(_OPENMP) + use omp_lib +#endif + IMPLICIT NONE +* +* -- LAPACK auxiliary 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, NI, NBI, IBI, NXI +* +* ================================================================ +* .. +* .. Local Scalars .. + INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS, + $ FACTOPTNB, QROPTNB, LQOPTNB + LOGICAL RPREC, CPREC + CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*3 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, MAX +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Invalid value for ISPEC +* + IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF +* +* Get the number of threads +* + NTHREADS = 1 +#if defined(_OPENMP) +!$OMP PARALLEL + NTHREADS = OMP_GET_NUM_THREADS() +!$OMP END PARALLEL +#endif +* WRITE(*,*) 'IPARAM VOICI NTHREADS ISPEC ',NTHREADS, ISPEC +* + IF( ISPEC .NE. 19 ) THEN +* +* Convert NAME to upper case if the first character is lower case. +* + IPARAM2STAGE = -1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 100 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 100 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 110 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 110 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 120 I = 2, 12 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 120 CONTINUE + END IF + END IF +* + PREC = SUBNAM( 1: 1 ) + ALGO = SUBNAM( 4: 6 ) + STAG = SUBNAM( 8:12 ) + RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D' + CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z' +* +* Invalid value for PRECISION +* + IF( .NOT.( RPREC .OR. CPREC ) ) THEN + IPARAM2STAGE = -1 + RETURN + ENDIF + ENDIF +* WRITE(*,*),'RPREC,CPREC ',RPREC,CPREC, +* $ ' ALGO ',ALGO,' STAGE ',STAG +* +* + IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN +* +* ISPEC = 17, 18: block size KD, IB +* Could be also dependent from N but for now it +* depend only on sequential or parallel +* + IF( NTHREADS.GT.4 ) THEN + IF( CPREC ) THEN + KD = 128 + IB = 32 + ELSE + KD = 160 + IB = 40 + ENDIF + ELSE IF( NTHREADS.GT.1 ) THEN + IF( CPREC ) THEN + KD = 64 + IB = 32 + ELSE + KD = 64 + IB = 32 + ENDIF + ELSE + IF( CPREC ) THEN + KD = 16 + IB = 16 + ELSE + KD = 32 + IB = 16 + ENDIF + ENDIF + IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD + IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB +* + ELSE IF ( ISPEC .EQ. 19 ) THEN +* +* ISPEC = 19: +* LHOUS length of the Houselholder representation +* matrix (V,T) of the second stage. should be >= 1. +* +* Will add the VECT OPTION HERE next release + VECT = OPTS(1:1) + IF( VECT.EQ.'N' ) THEN + LHOUS = MAX( 1, 4*NI ) + ELSE +* This is not correct, it need to call the ALGO and the stage2 + LHOUS = MAX( 1, 4*NI ) + IBI + ENDIF + IF( LHOUS.GE.0 ) THEN + IPARAM2STAGE = LHOUS + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 20 ) THEN +* +* ISPEC = 20: (21 for future use) +* LWORK length of the workspace for +* either or both stages for TRD and BRD. should be >= 1. +* TRD: +* TRD_stage 1: = LT + LW + LS1 + LS2 +* = LDT*KD + N*KD + N*MAX(KD,FACTOPTNB) + LDS2*KD +* where LDT=LDS2=KD +* = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +* TRD_stage 2: = (2NB+1)*N + KD*NTHREADS +* TRD_both : = max(stage1,stage2) + AB ( AB=(KD+1)*N ) +* = N*KD + N*max(KD+1,FACTOPTNB) +* + max(2*KD*KD, KD*NTHREADS) +* + (KD+1)*N + LWORK = -1 + SUBNAM(1:1) = PREC + SUBNAM(2:6) = 'GEQRF' + QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 ) + SUBNAM(2:6) = 'GELQF' + LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 ) +* Could be QR or LQ for TRD and the max for BRD + FACTOPTNB = MAX(QROPTNB, LQOPTNB) + IF( ALGO.EQ.'TRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN + LWORK = (2*NBI+1)*NI + NBI*NTHREADS + ENDIF + ELSE IF( ALGO.EQ.'BRD' ) THEN + IF( STAG.EQ.'2STAG' ) THEN + LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB) + $ + MAX(2*NBI*NBI, NBI*NTHREADS) + $ + (NBI+1)*NI + ELSE IF( STAG.EQ.'GE2GB' ) THEN + LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI + ELSE IF( STAG.EQ.'GB2BD' ) THEN + LWORK = (3*NBI+1)*NI + NBI*NTHREADS + ENDIF + ENDIF + LWORK = MAX ( 1, LWORK ) + + IF( LWORK.GT.0 ) THEN + IPARAM2STAGE = LWORK + ELSE + IPARAM2STAGE = -1 + ENDIF +* + ELSE IF ( ISPEC .EQ. 21 ) THEN +* +* ISPEC = 21 for future use + IPARAM2STAGE = NXI + ENDIF +* +* ==== End of IPARAM2STAGE ==== +* + END diff --git a/lapack-netlib/SRC/iparmq.f b/lapack-netlib/SRC/iparmq.f index 94e35ae014..c0dedc9ec6 100644 --- a/lapack-netlib/SRC/iparmq.f +++ b/lapack-netlib/SRC/iparmq.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download IPARMQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, ISPEC, LWORK, N * CHARACTER NAME*( * ), OPTS*( * ) -* +* * *> \par Purpose: * ============= @@ -142,14 +142,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -222,10 +222,10 @@ * ===================================================================== INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, ISPEC, LWORK, N diff --git a/lapack-netlib/SRC/izmax1.f b/lapack-netlib/SRC/izmax1.f index 4fe9b0c7c6..bec5c68ea7 100644 --- a/lapack-netlib/SRC/izmax1.f +++ b/lapack-netlib/SRC/izmax1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download IZMAX1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download IZMAX1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IZMAX1( N, ZX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 ZX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,10 +64,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date February 2014 * @@ -81,7 +81,7 @@ * ===================================================================== INTEGER FUNCTION IZMAX1( N, ZX, INCX ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- * February 2014 diff --git a/lapack-netlib/SRC/lsamen.f b/lapack-netlib/SRC/lsamen.f index e14d96b156..d25c6f862d 100644 --- a/lapack-netlib/SRC/lsamen.f +++ b/lapack-netlib/SRC/lsamen.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download LSAMEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download LSAMEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION LSAMEN( N, CA, CB ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) CA, CB * INTEGER N * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION LSAMEN( N, CA, CB ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) CA, CB diff --git a/lapack-netlib/SRC/sbbcsd.f b/lapack-netlib/SRC/sbbcsd.f index 46b87c7ee5..6d1d833da0 100644 --- a/lapack-netlib/SRC/sbbcsd.f +++ b/lapack-netlib/SRC/sbbcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SBBCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SBBCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, * V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, * B22D, B22E, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -34,7 +34,7 @@ * REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,7 +149,7 @@ *> \param[in,out] U1 *> \verbatim *> U1 is REAL array, dimension (LDU1,P) -*> On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied +*> On entry, a P-by-P matrix. On exit, U1 is postmultiplied *> by the left singular vector matrix common to [ B11 ; 0 ] and *> [ B12 0 0 ; 0 -I 0 0 ]. *> \endverbatim @@ -157,13 +157,13 @@ *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER -*> The leading dimension of the array U1. +*> The leading dimension of the array U1, LDU1 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] U2 *> \verbatim *> U2 is REAL array, dimension (LDU2,M-P) -*> On entry, an LDU2-by-(M-P) matrix. On exit, U2 is +*> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is *> postmultiplied by the left singular vector matrix common to *> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. *> \endverbatim @@ -171,13 +171,13 @@ *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER -*> The leading dimension of the array U2. +*> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] V1T *> \verbatim *> V1T is REAL array, dimension (LDV1T,Q) -*> On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied +*> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied *> by the transpose of the right singular vector *> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. *> \endverbatim @@ -185,13 +185,13 @@ *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER -*> The leading dimension of the array V1T. +*> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). *> \endverbatim *> *> \param[in,out] V2T *> \verbatim *> V2T is REAL array, dimenison (LDV2T,M-Q) -*> On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is +*> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is *> premultiplied by the transpose of the right *> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and *> [ B22 0 0 ; 0 0 I ]. @@ -200,7 +200,7 @@ *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER -*> The leading dimension of the array V2T. +*> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). *> \endverbatim *> *> \param[out] B11D @@ -317,12 +317,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHERcomputational * @@ -332,10 +332,10 @@ SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS diff --git a/lapack-netlib/SRC/sbdsdc.f b/lapack-netlib/SRC/sbdsdc.f index 261aa1c21f..21c0b640a3 100644 --- a/lapack-netlib/SRC/sbdsdc.f +++ b/lapack-netlib/SRC/sbdsdc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SBDSDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SBDSDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, UPLO * INTEGER INFO, LDU, LDVT, N @@ -30,7 +30,7 @@ * REAL D( * ), E( * ), Q( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -186,12 +186,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -205,10 +205,10 @@ SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, UPLO @@ -311,7 +311,7 @@ SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WSTART = 1 QSTART = 3 IF( ICOMPQ.EQ.1 ) THEN - CALL SCOPY( N, D, 1, Q( 1 ), 1 ) + CALL SCOPY( N, D, 1, Q( 1 ), 1 ) CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 ) END IF IF( IUPLO.EQ.2 ) THEN @@ -335,8 +335,11 @@ SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, * If ICOMPQ = 0, use SLASDQ to compute the singular values. * IF( ICOMPQ.EQ.0 ) THEN +* Ignore WSTART, instead using WORK( 1 ), since the two vectors +* for CS and -SN above are added only if ICOMPQ == 2, +* and adding them exceeds documented WORK size of 4*n. CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, - $ LDU, WORK( WSTART ), INFO ) + $ LDU, WORK( 1 ), INFO ) GO TO 40 END IF * diff --git a/lapack-netlib/SRC/sbdsqr.f b/lapack-netlib/SRC/sbdsqr.f index 6b906bbb7e..e80ac4ea91 100644 --- a/lapack-netlib/SRC/sbdsqr.f +++ b/lapack-netlib/SRC/sbdsqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU @@ -29,7 +29,7 @@ * REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,9 +40,9 @@ *> left singular vectors from the singular value decomposition (SVD) of *> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit *> zero-shift QR algorithm. The SVD of B has the form -*> +*> *> B = Q * S * P**T -*> +*> *> where S is the diagonal matrix of singular values, Q is an orthogonal *> matrix of left singular vectors, and P is an orthogonal matrix of *> right singular vectors. If left singular vectors are requested, this @@ -51,9 +51,9 @@ *> P**T, for given real input matrices U and VT. When U and VT are the *> orthogonal matrices that reduce a general matrix A to bidiagonal *> form: A = U*B*VT, as computed by SGEBRD, then -*> +*> *> A = (U*Q) * S * (P**T*VT) -*> +*> *> is the SVD of A. Optionally, the subroutine may also compute Q**T*C *> for a given real input matrix C. *> @@ -179,7 +179,7 @@ *> = 1, a split was marked by a positive value in E *> = 2, current block of Z not diagonalized after 30*N *> iterations (in inner while loop) -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> else NCVT = NRU = NCC = 0, *> the algorithm did not converge; D and E contain the @@ -214,15 +214,25 @@ *> through the inner loop exceeds MAXITR*N**2. *> \endverbatim * +*> \par Note: +* =========== +*> +*> \verbatim +*> Bug report from Cezary Dendek. +*> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is +*> removed since it can overflow pretty easily (for N larger or equal +*> than 18,919). We instead use MAXITDIVN = MAXITR*N. +*> \endverbatim +* * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -230,10 +240,10 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -266,8 +276,8 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, - $ NM12, NM13, OLDLL, OLDM + INTEGER I, IDIR, ISUB, ITER, ITERDIVN J, LL, LLL, M, + $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM REAL ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, @@ -329,7 +339,7 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, CALL SLASQ1( N, D, E, WORK, INFO ) * * If INFO equals 2, dqds didn't finish, try to finish -* +* IF( INFO .NE. 2 ) RETURN INFO = 0 END IF @@ -400,20 +410,21 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( REAL( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) + THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) ELSE * * Absolute accuracy desired * - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) + THRESH = MAX( ABS( TOL )*SMAX, MAXITR*(N*(N*UNFL)) ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * - MAXIT = MAXITR*N*N - ITER = 0 + MAXITDIVN = MAXITR*N + ITERDIVN = 0 + ITER = -1 OLDLL = -1 OLDM = -1 * @@ -429,8 +440,13 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * IF( M.LE.1 ) $ GO TO 160 - IF( ITER.GT.MAXIT ) +* + IF( ITER.GE.N ) THEN + ITER = ITER - N + ITERDIVN = ITERDIVN + 1 + IF( ITERDIVN.GE.MAXITDIVN ) $ GO TO 200 + END IF * * Find diagonal block of matrix to work on * diff --git a/lapack-netlib/SRC/sbdsvdx.f b/lapack-netlib/SRC/sbdsvdx.f index 7526407002..4fa16ec853 100644 --- a/lapack-netlib/SRC/sbdsvdx.f +++ b/lapack-netlib/SRC/sbdsvdx.f @@ -2,23 +2,23 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SBDSVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SBDSVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * $ NS, S, Z, LDZ, WORK, IWORK, INFO ) * * .. Scalar Arguments .. @@ -28,45 +28,45 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* REAL D( * ), E( * ), S( * ), WORK( * ), +* REAL D( * ), E( * ), S( * ), WORK( * ), * Z( LDZ, * ) * .. -* +* *> \par Purpose: * ============= *> *> \verbatim *> *> SBDSVDX computes the singular value decomposition (SVD) of a real -*> N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, -*> where S is a diagonal matrix with non-negative diagonal elements -*> (the singular values of B), and U and VT are orthogonal matrices +*> N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, +*> where S is a diagonal matrix with non-negative diagonal elements +*> (the singular values of B), and U and VT are orthogonal matrices *> of left and right singular vectors, respectively. *> -*> Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] -*> and superdiagonal E = [ e_1 e_2 ... e_N-1 ], SBDSVDX computes the -*> singular value decompositon of B through the eigenvalues and +*> Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] +*> and superdiagonal E = [ e_1 e_2 ... e_N-1 ], SBDSVDX computes the +*> singular value decompositon of B through the eigenvalues and *> eigenvectors of the N*2-by-N*2 tridiagonal matrix -*> -*> | 0 d_1 | -*> | d_1 0 e_1 | -*> TGK = | e_1 0 d_2 | -*> | d_2 . . | +*> +*> | 0 d_1 | +*> | d_1 0 e_1 | +*> TGK = | e_1 0 d_2 | +*> | d_2 . . | *> | . . . | *> -*> If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then -*> (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / -*> sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and -*> P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. +*> If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then +*> (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / +*> sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and +*> P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. *> -*> Given a TGK matrix, one can either a) compute -s,-v and change signs -*> so that the singular values (and corresponding vectors) are already in -*> descending order (as in SGESVD/SGESDD) or b) compute s,v and reorder -*> the values (and corresponding vectors). SBDSVDX implements a) by -*> calling SSTEVX (bisection plus inverse iteration, to be replaced -*> with a version of the Multiple Relative Robust Representation -*> algorithm. (See P. Willems and B. Lang, A framework for the MR^3 -*> algorithm: theory and implementation, SIAM J. Sci. Comput., +*> Given a TGK matrix, one can either a) compute -s,-v and change signs +*> so that the singular values (and corresponding vectors) are already in +*> descending order (as in SGESVD/SGESDD) or b) compute s,v and reorder +*> the values (and corresponding vectors). SBDSVDX implements a) by +*> calling SSTEVX (bisection plus inverse iteration, to be replaced +*> with a version of the Multiple Relative Robust Representation +*> algorithm. (See P. Willems and B. Lang, A framework for the MR^3 +*> algorithm: theory and implementation, SIAM J. Sci. Comput., *> 35:740-766, 2013.) *> \endverbatim * @@ -80,7 +80,7 @@ *> = 'L': B is lower bidiagonal. *> \endverbatim *> -*> \param[in] JOBXZ +*> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute singular values only; @@ -101,13 +101,13 @@ *> N is INTEGER *> The order of the bidiagonal matrix. N >= 0. *> \endverbatim -*> +*> *> \param[in] D *> \verbatim *> D is REAL array, dimension (N) *> The n diagonal elements of the bidiagonal matrix B. *> \endverbatim -*> +*> *> \param[in] E *> \verbatim *> E is REAL array, dimension (max(1,N-1)) @@ -117,14 +117,16 @@ *> *> \param[in] VL *> \verbatim -*> VL is REAL -*> VL >=0. +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,13 +134,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -161,14 +167,14 @@ *> \verbatim *> Z is REAL array, dimension (2*N,K) ) *> If JOBZ = 'V', then if INFO = 0 the first NS columns of Z -*> contain the singular vectors of the matrix B corresponding to +*> contain the singular vectors of the matrix B corresponding to *> the selected singular values, with U in rows 1 to N and V *> in rows N+1 to N*2, i.e. -*> Z = [ U ] +*> Z = [ U ] *> [ V ] -*> If JOBZ = 'N', then Z is not referenced. -*> Note: The user must ensure that at least K = NS+1 columns are -*> supplied in the array Z; if RANGE = 'V', the exact value of +*> If JOBZ = 'N', then Z is not referenced. +*> Note: The user must ensure that at least K = NS+1 columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of *> NS is not known in advance and an upper bound must be used. *> \endverbatim *> @@ -188,9 +194,12 @@ *> \verbatim *> IWORK is INTEGER array, dimension (12*N) *> If JOBZ = 'V', then if INFO = 0, the first NS elements of -*> IWORK are zero. If INFO > 0, then IWORK contains the indices +*> IWORK are zero. If INFO > 0, then IWORK contains the indices *> of the eigenvectors that failed to converge in DSTEVX. +*> \endverbatim *> +*> \param[out] INFO +*> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value @@ -204,24 +213,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHEReigen * -* ===================================================================== - SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, +* ===================================================================== + SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ NS, S, Z, LDZ, WORK, IWORK, INFO) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2016 -* +* December 2016 +* * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDZ, N, NS @@ -229,28 +238,28 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * .. * .. Array Arguments .. INTEGER IWORK( * ) - REAL D( * ), E( * ), S( * ), WORK( * ), + REAL D( * ), E( * ), S( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE, TEN, HNDRD, MEIGTH - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0, + REAL ZERO, ONE, TEN, HNDRD, MEIGTH + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0, $ HNDRD = 100.0E0, MEIGTH = -0.1250E0 ) REAL FUDGE PARAMETER ( FUDGE = 2.0E0 ) * .. -* .. Local Scalars .. +* .. Local Scalars .. CHARACTER RNGVX - LOGICAL ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ - INTEGER I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR, - $ IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV, - $ IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K, + LOGICAL ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ + INTEGER I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR, + $ IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV, + $ IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K, $ NTGK, NRU, NRV, NSL REAL ABSTOL, EPS, EMIN, MU, NRMU, NRMV, ORTOL, SMAX, - $ SMIN, SQRT2, THRESH, TOL, ULP, + $ SMIN, SQRT2, THRESH, TOL, ULP, $ VLTGK, VUTGK, ZJTJI * .. * .. External Functions .. @@ -265,7 +274,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * .. Intrinsic Functions .. INTRINSIC ABS, REAL, SIGN, SQRT * .. -* .. Executable Statements .. +* .. Executable Statements .. * * Test the input parameters. * @@ -312,7 +321,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * NS = 0 IF( N.EQ.0 ) RETURN -* +* IF( N.EQ.1 ) THEN IF( ALLSV .OR. INDSV ) THEN NS = 1 @@ -330,17 +339,17 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, RETURN END IF * - ABSTOL = 2*SLAMCH( 'Safe Minimum' ) + ABSTOL = 2*SLAMCH( 'Safe Minimum' ) ULP = SLAMCH( 'Precision' ) EPS = SLAMCH( 'Epsilon' ) SQRT2 = SQRT( 2.0E0 ) ORTOL = SQRT( ULP ) -* +* * Criterion for splitting is taken from SBDSQR when singular -* values are computed to relative accuracy TOL. (See J. Demmel and -* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM +* values are computed to relative accuracy TOL. (See J. Demmel and +* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM * J. Sci. and Stat. Comput., 11:873–912, 1990.) -* +* TOL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS * * Compute approximate maximum, minimum singular values. @@ -371,7 +380,6 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( ABS( E( I ) ).LE.THRESH ) E( I ) = ZERO END DO IF( ABS( D( N ) ).LE.THRESH ) D( N ) = ZERO - E( N ) = ZERO * * Pointers for arrays used by SSTEVX. * @@ -382,23 +390,23 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IIWORK = IIFAIL + N*2 * * Set RNGVX, which corresponds to RANGE for SSTEVX in TGK mode. -* VL,VU or IL,IU are redefined to conform to implementation a) +* VL,VU or IL,IU are redefined to conform to implementation a) * described in the leading comments. * ILTGK = 0 - IUTGK = 0 + IUTGK = 0 VLTGK = ZERO VUTGK = ZERO * IF( ALLSV ) THEN * -* All singular values will be found. We aim at -s (see +* All singular values will be found. We aim at -s (see * leading comments) with RNGVX = 'I'. IL and IU are set -* later (as ILTGK and IUTGK) according to the dimension +* later (as ILTGK and IUTGK) according to the dimension * of the active submatrix. * RNGVX = 'I' - CALL SLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ ) + IF( WANTZ ) CALL SLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ ) ELSE IF( VALSV ) THEN * * Find singular values in a half-open interval. We aim @@ -411,31 +419,31 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL SCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL SCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL SSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL SSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ), $ VLTGK, VUTGK, ILTGK, ILTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) IF( NS.EQ.0 ) THEN RETURN ELSE - CALL SLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ ) + IF( WANTZ ) CALL SLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ ) END IF ELSE IF( INDSV ) THEN * -* Find the IL-th through the IU-th singular values. We aim -* at -s (see leading comments) and indices are mapped into +* Find the IL-th through the IU-th singular values. We aim +* at -s (see leading comments) and indices are mapped into * values, therefore mimicking SSTEBZ, where * * GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN * GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN * ILTGK = IL - IUTGK = IU + IUTGK = IU RNGVX = 'V' WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL SCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL SCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL SSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL SSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), $ VLTGK, VLTGK, ILTGK, ILTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) @@ -443,7 +451,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, WORK( IDTGK:IDTGK+2*N-1 ) = ZERO CALL SCOPY( N, D, 1, WORK( IETGK ), 2 ) CALL SCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) - CALL SSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), + CALL SSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ), $ VUTGK, VUTGK, IUTGK, IUTGK, ABSTOL, NS, S, $ Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ), $ IWORK( IIFAIL ), INFO ) @@ -451,12 +459,12 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, VUTGK = MIN( VUTGK, ZERO ) * * If VLTGK=VUTGK, SSTEVX returns an error message, -* so if needed we change VUTGK slightly. +* so if needed we change VUTGK slightly. * IF( VLTGK.EQ.VUTGK ) VLTGK = VLTGK - TOL * - CALL SLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ ) - END IF + IF( WANTZ ) CALL SLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ) + END IF * * Initialize variables and pointers for S, Z, and WORK. * @@ -475,7 +483,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IROWU = 2 IROWV = 1 SPLIT = .FALSE. - SVEQ0 = .FALSE. + SVEQ0 = .FALSE. * * Form the tridiagonal TGK matrix. * @@ -486,15 +494,15 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, CALL SCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 ) * * -* Check for splits in two levels, outer level +* Check for splits in two levels, outer level * in E and inner level in D. * - DO IEPTR = 2, N*2, 2 - IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN + DO IEPTR = 2, N*2, 2 + IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN * * Split in E (this piece of B is square) or bottom * of the (input bidiagonal) matrix. -* +* ISPLT = IDBEG IDEND = IEPTR - 1 DO IDPTR = IDBEG, IDEND, 2 @@ -511,22 +519,22 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( IDBEG.EQ.IDEND) THEN NRU = 1 NRV = 1 - END IF + END IF ELSE IF( IDPTR.EQ.IDEND ) THEN * * D=0 at the bottom. * SVEQ0 = .TRUE. - NRU = (IDEND-ISPLT)/2 + 1 - NRV = NRU + NRU = (IDEND-ISPLT)/2 + 1 + NRV = NRU IF( ISPLT.NE.IDBEG ) THEN NRU = NRU + 1 - END IF + END IF ELSE IF( ISPLT.EQ.IDBEG ) THEN * * Split: top rectangular submatrix. -* +* NRU = (IDPTR-IDBEG)/2 NRV = NRU + 1 ELSE @@ -534,7 +542,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * Split: middle square submatrix. * NRU = (IDPTR-ISPLT)/2 + 1 - NRV = NRU + NRV = NRU END IF END IF ELSE IF( IDPTR.EQ.IDEND ) THEN @@ -552,7 +560,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * Split: bottom rectangular submatrix. * NRV = (IDEND-ISPLT)/2 + 1 - NRU = NRV + 1 + NRU = NRV + 1 END IF END IF * @@ -560,32 +568,32 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * IF( NTGK.GT.0 ) THEN * -* Compute eigenvalues/vectors of the active -* submatrix according to RANGE: +* Compute eigenvalues/vectors of the active +* submatrix according to RANGE: * if RANGE='A' (ALLSV) then RNGVX = 'I' * if RANGE='V' (VALSV) then RNGVX = 'V' * if RANGE='I' (INDSV) then RNGVX = 'V' * ILTGK = 1 - IUTGK = NTGK / 2 + IUTGK = NTGK / 2 IF( ALLSV .OR. VUTGK.EQ.ZERO ) THEN - IF( SVEQ0 .OR. - $ SMIN.LT.EPS .OR. + IF( SVEQ0 .OR. + $ SMIN.LT.EPS .OR. $ MOD(NTGK,2).GT.0 ) THEN * Special case: eigenvalue equal to zero or very * small, additional eigenvector is needed. IUTGK = IUTGK + 1 - END IF + END IF END IF * -* Workspace needed by SSTEVX: -* WORK( ITEMP: ): 2*5*NTGK +* Workspace needed by SSTEVX: +* WORK( ITEMP: ): 2*5*NTGK * IWORK( 1: ): 2*6*NTGK * - CALL SSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ), - $ WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK, - $ ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ), - $ Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ), + CALL SSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ), + $ WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK, + $ ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ), + $ Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ), $ IWORK( IIWORK ), IWORK( IIFAIL ), $ INFO ) IF( INFO.NE.0 ) THEN @@ -593,7 +601,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, RETURN END IF EMIN = ABS( MAXVAL( S( ISBEG:ISBEG+NSL-1 ) ) ) -* +* IF( NSL.GT.0 .AND. WANTZ ) THEN * * Normalize u=Z([2,4,...],:) and v=Z([1,3,...],:), @@ -607,22 +615,22 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( NSL.GT.1 .AND. $ VUTGK.EQ.ZERO .AND. $ MOD(NTGK,2).EQ.0 .AND. - $ EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN + $ EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN * * D=0 at the top or bottom of the active submatrix: -* one eigenvalue is equal to zero; concatenate the -* eigenvectors corresponding to the two smallest +* one eigenvalue is equal to zero; concatenate the +* eigenvectors corresponding to the two smallest * eigenvalues. * Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) = $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) + $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) - Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = - $ ZERO + Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = + $ ZERO * IF( IUTGK*2.GT.NTGK ) THEN * Eigenvalue equal to zero or very small. * NSL = NSL - 1 -* END IF +* END IF END IF * DO I = 0, MIN( NSL-1, NRU-1 ) @@ -631,20 +639,20 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, INFO = N*2 + 1 RETURN END IF - CALL SSCAL( NRU, ONE/NRMU, + CALL SSCAL( NRU, ONE/NRMU, $ Z( IROWU,ICOLZ+I ), 2 ) IF( NRMU.NE.ONE .AND. $ ABS( NRMU-ORTOL )*SQRT2.GT.ONE ) $ THEN DO J = 0, I-1 - ZJTJI = -SDOT( NRU, Z( IROWU, ICOLZ+J ), + ZJTJI = -SDOT( NRU, Z( IROWU, ICOLZ+J ), $ 2, Z( IROWU, ICOLZ+I ), 2 ) - CALL SAXPY( NRU, ZJTJI, + CALL SAXPY( NRU, ZJTJI, $ Z( IROWU, ICOLZ+J ), 2, $ Z( IROWU, ICOLZ+I ), 2 ) END DO NRMU = SNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 ) - CALL SSCAL( NRU, ONE/NRMU, + CALL SSCAL( NRU, ONE/NRMU, $ Z( IROWU,ICOLZ+I ), 2 ) END IF END DO @@ -654,7 +662,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, INFO = N*2 + 1 RETURN END IF - CALL SSCAL( NRV, -ONE/NRMV, + CALL SSCAL( NRV, -ONE/NRMV, $ Z( IROWV,ICOLZ+I ), 2 ) IF( NRMV.NE.ONE .AND. $ ABS( NRMV-ORTOL )*SQRT2.GT.ONE ) @@ -662,12 +670,12 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, DO J = 0, I-1 ZJTJI = -SDOT( NRV, Z( IROWV, ICOLZ+J ), $ 2, Z( IROWV, ICOLZ+I ), 2 ) - CALL SAXPY( NRU, ZJTJI, + CALL SAXPY( NRU, ZJTJI, $ Z( IROWV, ICOLZ+J ), 2, $ Z( IROWV, ICOLZ+I ), 2 ) END DO NRMV = SNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 ) - CALL SSCAL( NRV, ONE/NRMV, + CALL SSCAL( NRV, ONE/NRMV, $ Z( IROWV,ICOLZ+I ), 2 ) END IF END DO @@ -676,18 +684,18 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ MOD(NTGK,2).GT.0 ) THEN * * D=0 in the middle of the active submatrix (one -* eigenvalue is equal to zero): save the corresponding +* eigenvalue is equal to zero): save the corresponding * eigenvector for later use (when bottom of the * active submatrix is reached). * SPLIT = .TRUE. - Z( IROWZ:IROWZ+NTGK-1,N+1 ) = + Z( IROWZ:IROWZ+NTGK-1,N+1 ) = $ Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) - Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = - $ ZERO - END IF + Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = + $ ZERO + END IF END IF !** WANTZ **! -* +* NSL = MIN( NSL, NRU ) SVEQ0 = .FALSE. * @@ -698,25 +706,27 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, END DO * * Update pointers for TGK, S and Z. -* +* ISBEG = ISBEG + NSL IROWZ = IROWZ + NTGK ICOLZ = ICOLZ + NSL IROWU = IROWZ - IROWV = IROWZ + 1 + IROWV = IROWZ + 1 ISPLT = IDPTR + 1 NS = NS + NSL NRU = 0 - NRV = 0 - END IF !** NTGK.GT.0 **! - IF( IROWZ.LT.N*2 ) Z( 1:IROWZ-1, ICOLZ ) = ZERO + NRV = 0 + END IF !** NTGK.GT.0 **! + IF( IROWZ.LT.N*2 .AND. WANTZ ) THEN + Z( 1:IROWZ-1, ICOLZ ) = ZERO + END IF END DO !** IDPTR loop **! - IF( SPLIT ) THEN + IF( SPLIT .AND. WANTZ ) THEN * * Bring back eigenvector corresponding * to eigenvalue equal to zero. * - Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = + Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = $ Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) + $ Z( IDBEG:IDEND-NTGK+1,N+1 ) Z( IDBEG:IDEND-NTGK+1,N+1 ) = 0 @@ -725,7 +735,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IROWU = IROWU + 1 IDBEG = IEPTR + 1 SVEQ0 = .FALSE. - SPLIT = .FALSE. + SPLIT = .FALSE. END IF !** Check for split in E **! END DO !** IEPTR loop **! * @@ -744,24 +754,25 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IF( K.NE.NS+1-I ) THEN S( K ) = S( NS+1-I ) S( NS+1-I ) = SMIN - CALL SSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 ) + IF( WANTZ ) CALL SSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 ) END IF END DO -* +* * If RANGE=I, check for singular values/vectors to be discarded. * IF( INDSV ) THEN K = IU - IL + 1 IF( K.LT.NS ) THEN S( K+1:NS ) = ZERO - Z( 1:N*2,K+1:NS ) = ZERO + IF( WANTZ ) Z( 1:N*2,K+1:NS ) = ZERO NS = K END IF - END IF + END IF * * Reorder Z: U = Z( 1:N,1:NS ), V = Z( N+1:N*2,1:NS ). * If B is a lower diagonal, swap U and V. * + IF( WANTZ ) THEN DO I = 1, NS CALL SCOPY( N*2, Z( 1,I ), 1, WORK, 1 ) IF( LOWER ) THEN @@ -772,6 +783,7 @@ SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, CALL SCOPY( N, WORK( 1 ), 2, Z( N+1,I ), 1 ) END IF END DO + END IF * RETURN * diff --git a/lapack-netlib/SRC/scsum1.f b/lapack-netlib/SRC/scsum1.f index 2fbb911b99..7fa03198ff 100644 --- a/lapack-netlib/SRC/scsum1.f +++ b/lapack-netlib/SRC/scsum1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SCSUM1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SCSUM1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SCSUM1( N, CX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX CX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,12 +64,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complexOTHERauxiliary * @@ -81,10 +81,10 @@ * ===================================================================== REAL FUNCTION SCSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/sdisna.f b/lapack-netlib/SRC/sdisna.f index d6d2d16b08..b034033871 100644 --- a/lapack-netlib/SRC/sdisna.f +++ b/lapack-netlib/SRC/sdisna.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SDISNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SDISNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER INFO, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), SEP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/sgbbrd.f b/lapack-netlib/SRC/sgbbrd.f index f5d3fd25c5..4711c80749 100644 --- a/lapack-netlib/SRC/sgbbrd.f +++ b/lapack-netlib/SRC/sgbbrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, * LDQ, PT, LDPT, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC @@ -29,7 +29,7 @@ * REAL AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), * $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -174,12 +174,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -187,10 +187,10 @@ SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER VECT diff --git a/lapack-netlib/SRC/sgbcon.f b/lapack-netlib/SRC/sgbcon.f index 4301febb6e..2294bbf4e9 100644 --- a/lapack-netlib/SRC/sgbcon.f +++ b/lapack-netlib/SRC/sgbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, KL, KU, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -146,10 +146,10 @@ SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/sgbequ.f b/lapack-netlib/SRC/sgbequ.f index 3d7a36c7c3..1001361574 100644 --- a/lapack-netlib/SRC/sgbequ.f +++ b/lapack-netlib/SRC/sgbequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * REAL AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -153,10 +153,10 @@ SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/sgbequb.f b/lapack-netlib/SRC/sgbequb.f index d1effd9e33..5fa4abfc82 100644 --- a/lapack-netlib/SRC/sgbequb.f +++ b/lapack-netlib/SRC/sgbequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * REAL AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,9 +48,9 @@ *> number of A but works well in practice. *> *> This routine differs from SGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -83,7 +83,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> AB is REAL array, dimension (LDAB,N) *> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. *> The j-th column of A is stored in the j-th column of the *> array AB as follows: @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realGBcomputational * @@ -160,10 +160,10 @@ SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/sgbrfs.f b/lapack-netlib/SRC/sgbrfs.f index 514aeb0052..593c158613 100644 --- a/lapack-netlib/SRC/sgbrfs.f +++ b/lapack-netlib/SRC/sgbrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -205,10 +205,10 @@ SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgbrfsx.f b/lapack-netlib/SRC/sgbrfsx.f index a154c3d6e7..032b78b803 100644 --- a/lapack-netlib/SRC/sgbrfsx.f +++ b/lapack-netlib/SRC/sgbrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,7 +121,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> AB is REAL array, dimension (LDAB,N) *> The original band matrix A, stored in rows 1 to KL+KU+1. *> The j-th column of A is stored in the j-th column of the *> array AB as follows: @@ -136,7 +136,7 @@ *> *> \param[in] AFB *> \verbatim -*> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) +*> AFB is REAL array, dimension (LDAFB,N) *> Details of the LU factorization of the band matrix A, as *> computed by DGBTRF. U is stored as an upper triangular band *> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and @@ -424,10 +424,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -440,7 +440,7 @@ SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -502,11 +502,10 @@ SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL SLAMCH, SLANGB, SLA_GBRCOND REAL SLAMCH, SLANGB, SLA_GBRCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. @@ -646,7 +645,7 @@ SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, * * Perform refinement on each right-hand side * - IF (REF_TYPE .NE. 0) THEN + IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN PREC_TYPE = ILAPREC( 'D' ) diff --git a/lapack-netlib/SRC/sgbsv.f b/lapack-netlib/SRC/sgbsv.f index 308e38d62f..9b922966ec 100644 --- a/lapack-netlib/SRC/sgbsv.f +++ b/lapack-netlib/SRC/sgbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS diff --git a/lapack-netlib/SRC/sgbsvx.f b/lapack-netlib/SRC/sgbsvx.f index 10cb45464a..acd7db2846 100644 --- a/lapack-netlib/SRC/sgbsvx.f +++ b/lapack-netlib/SRC/sgbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -354,10 +354,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -368,7 +368,7 @@ SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -387,7 +387,7 @@ SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * * ===================================================================== * Moved setting of INFO = N+1 so INFO does not subsequently get -* overwritten. Sven, 17 Mar 05. +* overwritten. Sven, 17 Mar 05. * ===================================================================== * * .. Parameters .. diff --git a/lapack-netlib/SRC/sgbsvxx.f b/lapack-netlib/SRC/sgbsvxx.f index 3e6d3ed9e6..b2132325e5 100644 --- a/lapack-netlib/SRC/sgbsvxx.f +++ b/lapack-netlib/SRC/sgbsvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RCOND, RPVGRW, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -547,10 +547,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -563,7 +563,7 @@ SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sgbtf2.f b/lapack-netlib/SRC/sgbtf2.f index 11c5ee3976..ecf10e3149 100644 --- a/lapack-netlib/SRC/sgbtf2.f +++ b/lapack-netlib/SRC/sgbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/sgbtrf.f b/lapack-netlib/SRC/sgbtrf.f index 3df8d69894..2572f37b79 100644 --- a/lapack-netlib/SRC/sgbtrf.f +++ b/lapack-netlib/SRC/sgbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/sgbtrs.f b/lapack-netlib/SRC/sgbtrs.f index d47d41c0ab..477b033318 100644 --- a/lapack-netlib/SRC/sgbtrs.f +++ b/lapack-netlib/SRC/sgbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * REAL AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -138,10 +138,10 @@ SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgebak.f b/lapack-netlib/SRC/sgebak.f index acb80d27fb..ec58bf335e 100644 --- a/lapack-netlib/SRC/sgebak.f +++ b/lapack-netlib/SRC/sgebak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL V( LDV, * ), SCALE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -130,10 +130,10 @@ SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/sgebal.f b/lapack-netlib/SRC/sgebal.f index cdf0a91b0e..d34dc3b673 100644 --- a/lapack-netlib/SRC/sgebal.f +++ b/lapack-netlib/SRC/sgebal.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), SCALE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/sgebd2.f b/lapack-netlib/SRC/sgebd2.f index 26d16f0fad..eb125fba34 100644 --- a/lapack-netlib/SRC/sgebd2.f +++ b/lapack-netlib/SRC/sgebd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgebrd.f b/lapack-netlib/SRC/sgebrd.f index f4dfd2b2d3..0f38156dc1 100644 --- a/lapack-netlib/SRC/sgebrd.f +++ b/lapack-netlib/SRC/sgebrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,19 +135,19 @@ *> \param[out] INFO *> \verbatim *> INFO is INTEGER -*> = 0: successful exit +*> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -205,10 +205,10 @@ SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgecon.f b/lapack-netlib/SRC/sgecon.f index 60c6b1e3ae..d8f087ddf2 100644 --- a/lapack-netlib/SRC/sgecon.f +++ b/lapack-netlib/SRC/sgecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -124,10 +124,10 @@ SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/sgeequ.f b/lapack-netlib/SRC/sgeequ.f index e64acbdd5b..bb5592bd10 100644 --- a/lapack-netlib/SRC/sgeequ.f +++ b/lapack-netlib/SRC/sgeequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * REAL AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -139,10 +139,10 @@ SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgeequb.f b/lapack-netlib/SRC/sgeequb.f index 018c7cef08..e04ee451d2 100644 --- a/lapack-netlib/SRC/sgeequb.f +++ b/lapack-netlib/SRC/sgeequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * REAL AMAX, COLCND, ROWCND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,9 +48,9 @@ *> number of A but works well in practice. *> *> This routine differs from SGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -146,10 +146,10 @@ SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgees.f b/lapack-netlib/SRC/sgees.f index 691749c1a0..06319bf738 100644 --- a/lapack-netlib/SRC/sgees.f +++ b/lapack-netlib/SRC/sgees.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, * VS, LDVS, WORK, LWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -34,7 +34,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -203,12 +203,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEeigen * @@ -216,10 +216,10 @@ SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT diff --git a/lapack-netlib/SRC/sgeesx.f b/lapack-netlib/SRC/sgeesx.f index fe98b450e1..c90de9b818 100644 --- a/lapack-netlib/SRC/sgeesx.f +++ b/lapack-netlib/SRC/sgeesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, * WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, * IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SENSE, SORT * INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM @@ -37,7 +37,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -90,7 +90,7 @@ *> *> \param[in] SELECT *> \verbatim -*> SELECT is procedure) LOGICAL FUNCTION of two REAL arguments +*> SELECT is a LOGICAL FUNCTION of two REAL arguments *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to sort *> to the top left of the Schur form. @@ -267,12 +267,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realGEeigen * @@ -281,10 +281,10 @@ SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT diff --git a/lapack-netlib/SRC/sgeev.f b/lapack-netlib/SRC/sgeev.f index 667de0afe4..08c5a57f40 100644 --- a/lapack-netlib/SRC/sgeev.f +++ b/lapack-netlib/SRC/sgeev.f @@ -2,34 +2,34 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, * LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. -* REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +* REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,61 +176,64 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date September 2012 +* @generated from dgeev.f, fortran d -> s, Tue Apr 19 01:47:44 2016 * *> \ingroup realGEeigen * * ===================================================================== SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. - REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. * * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE + REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, - $ MAXWRK, MINWRK, NOUT - REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT + REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) - REAL DUM( 1 ) + REAL DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY, - $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC, + $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC3, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV, ISAMAX - REAL SLAMCH, SLANGE, SLAPY2, SNRM2 - EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2, + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SLANGE, SLAPY2, SNRM2 + EXTERNAL LSAME, ISAMAX, ILAENV, SLAMCH, SLANGE, SLAPY2, $ SNRM2 * .. * .. Intrinsic Functions .. @@ -279,24 +282,34 @@ SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'SORGHR', ' ', N, 1, N, -1 ) ) CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL STREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) ELSE IF( WANTVR ) THEN MINWRK = 4*N MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'SORGHR', ' ', N, 1, N, -1 ) ) CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL STREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) - ELSE + ELSE MINWRK = 3*N CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, - $ WORK, -1, INFO ) - HSWORK = WORK( 1 ) + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) END IF MAXWRK = MAX( MAXWRK, MINWRK ) @@ -426,10 +439,10 @@ SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (Workspace: need 4*N) +* (Workspace: need 4*N, prefer N + N + 2*N*NB) * - CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), IERR ) + CALL STREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * IF( WANTVL ) THEN diff --git a/lapack-netlib/SRC/sgeevx.f b/lapack-netlib/SRC/sgeevx.f index 821c080cd5..164cc6f9a6 100644 --- a/lapack-netlib/SRC/sgeevx.f +++ b/lapack-netlib/SRC/sgeevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,19 +21,19 @@ * SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, * VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, * RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N -* REAL ABNRM +* REAL ABNRM * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* REAL A( LDA, * ), RCONDE( * ), RCONDV( * ), +* REAL A( LDA, * ), RCONDE( * ), RCONDV( * ), * $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -210,7 +210,7 @@ *> \verbatim *> IHI is INTEGER *> ILO and IHI are integer values determined when A was -*> balanced. The balanced A(i,j) = 0 if I > J and +*> balanced. The balanced A(i,j) = 0 if I > J and *> J = 1,...,ILO-1 or I = IHI+1,...,N. *> \endverbatim *> @@ -289,12 +289,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date September 2012 +* @generated from dgeevx.f, fortran d -> s, Tue Apr 19 01:47:44 2016 * *> \ingroup realGEeigen * @@ -302,20 +304,21 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N - REAL ABNRM + REAL ABNRM * .. * .. Array Arguments .. INTEGER IWORK( * ) - REAL A( LDA, * ), RCONDE( * ), RCONDV( * ), + REAL A( LDA, * ), RCONDE( * ), RCONDV( * ), $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. @@ -323,32 +326,32 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE + REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, $ WNTSNN, WNTSNV CHARACTER JOB, SIDE - INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK, - $ MINWRK, NOUT - REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT + REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) - REAL DUM( 1 ) + REAL DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY, - $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC, + $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC3, $ STRSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV, ISAMAX - REAL SLAMCH, SLANGE, SLAPY2, SNRM2 - EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2, + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SLANGE, SLAPY2, SNRM2 + EXTERNAL LSAME, ISAMAX, ILAENV, SLAMCH, SLANGE, SLAPY2, $ SNRM2 * .. * .. Intrinsic Functions .. @@ -366,8 +369,9 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, WNTSNE = LSAME( SENSE, 'E' ) WNTSNV = LSAME( SENSE, 'V' ) WNTSNB = LSAME( SENSE, 'B' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR. - $ LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) + $ .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) + $ THEN INFO = -1 ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN INFO = -2 @@ -405,9 +409,19 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, MAXWRK = N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) * IF( WANTVL ) THEN + CALL STREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN + CALL STREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, $ WORK, -1, INFO ) ELSE @@ -419,7 +433,7 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ LDVR, WORK, -1, INFO ) END IF END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) * IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = 2*N @@ -571,18 +585,18 @@ SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * -* If INFO > 0 from SHSEQR, then quit +* If INFO .NE. 0 from SHSEQR, then quit * - IF( INFO.GT.0 ) + IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (Workspace: need 3*N) +* (Workspace: need 3*N, prefer N + 2*N*NB) * - CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), IERR ) + CALL STREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * * Compute condition numbers if desired diff --git a/lapack-netlib/SRC/sgehd2.f b/lapack-netlib/SRC/sgehd2.f index 6c8fc1392c..6a172b7b27 100644 --- a/lapack-netlib/SRC/sgehd2.f +++ b/lapack-netlib/SRC/sgehd2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEHD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff --git a/lapack-netlib/SRC/sgehrd.f b/lapack-netlib/SRC/sgehrd.f index cff1a8acc0..75a1bca036 100644 --- a/lapack-netlib/SRC/sgehrd.f +++ b/lapack-netlib/SRC/sgehrd.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -186,7 +186,7 @@ SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E+0, + PARAMETER ( ZERO = 0.0E+0, $ ONE = 1.0E+0 ) * .. * .. Local Scalars .. @@ -225,14 +225,14 @@ SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) END IF * IF( INFO.EQ.0 ) THEN -* +* * Compute the workspace requirements -* +* NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT END IF -* +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEHRD', -INFO ) RETURN @@ -316,7 +316,7 @@ SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL SGEMM( 'No transpose', 'Transpose', + CALL SGEMM( 'No transpose', 'Transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) diff --git a/lapack-netlib/SRC/sgejsv.f b/lapack-netlib/SRC/sgejsv.f index 55bb59e126..589cf07f66 100644 --- a/lapack-netlib/SRC/sgejsv.f +++ b/lapack-netlib/SRC/sgejsv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEJSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEJSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * M, N, A, LDA, SVA, U, LDU, V, LDV, * WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * IMPLICIT NONE * INTEGER INFO, LDA, LDU, LDV, LWORK, M, N @@ -32,7 +32,7 @@ * INTEGER IWORK( * ) * CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV * .. -* +* * *> \par Purpose: * ============= @@ -53,7 +53,6 @@ *> of [SIGMA] is computed and stored in the array SVA. *> SGEJSV can sometimes compute tiny singular values and their singular vectors much *> more accurately than other SVD routines, see below under Further Details. - *> \endverbatim * * Arguments: @@ -88,7 +87,7 @@ *> rows, then using this condition number gives too pessimistic *> error bound. *> = 'A': Small singular values are the noise and the matrix is treated -*> as numerically rank defficient. The error in the computed +*> as numerically rank deficient. The error in the computed *> singular values is bounded by f(m,n)*epsilon*||A||. *> The computed SVD A = U * S * V^t restores A up to *> f(m,n)*epsilon*||A||. @@ -100,7 +99,7 @@ *> numerical RANK is declared to be r. The SVD is computed with *> absolute error bounds, but more accurately than with 'A'. *> \endverbatim -*> +*> *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 @@ -111,7 +110,7 @@ *> of U. *> = 'N': U is not computed. *> \endverbatim -*> +*> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 @@ -125,7 +124,7 @@ *> of V. *> = 'N': V is not computed. *> \endverbatim -*> +*> *> \param[in] JOBR *> \verbatim *> JOBR is CHARACTER*1 @@ -146,7 +145,7 @@ *> For computing the singular values in the FULL range [SFMIN,BIG] *> use SGESVJ. *> \endverbatim -*> +*> *> \param[in] JOBT *> \verbatim *> JOBT is CHARACTER*1 @@ -167,7 +166,7 @@ *> The implementer can easily remove this constraint and make the *> code more complicated. See the descriptions of U and V. *> \endverbatim -*> +*> *> \param[in] JOBP *> \verbatim *> JOBP is CHARACTER*1 @@ -238,7 +237,7 @@ *> copied back to the V array. This 'W' option is just *> a reminder to the caller that in this case U is *> reserved as workspace of length N*N. -*> If JOBU = 'N' U is not referenced. +*> If JOBU = 'N' U is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDU @@ -260,7 +259,7 @@ *> copied back to the U array. This 'W' option is just *> a reminder to the caller that in this case V is *> reserved as workspace of length N*N. -*> If JOBV = 'N' V is not referenced. +*> If JOBV = 'N' V is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDV @@ -320,15 +319,15 @@ *> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal *> block size for DGEQP3 and DGEQRF. -*> In general, optimal LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7). +*> In general, optimal LWORK is computed as +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7). *> -> .. an estimate of the scaled condition number of A is *> required (JOBA='E', 'G'). In this case, LWORK is the maximum *> of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4*N,7). -*> ->> For optimal performance (blocked code) the optimal value +*> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB, N*N+4*N, 7). *> In general, the optimal length LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), *> N+N*N+LWORK(DPOCON),7). *> *> If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), @@ -336,7 +335,7 @@ *> -> For optimal performance, LWORK >= max(2*M+N,3*N+(N+1)*NB,7), *> where NB is the optimal block size for DGEQP3, DGEQRF, DGELQ, *> DORMLQ. In general, the optimal length LWORK is computed as -*> LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON), +*> LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON), *> N+LWORK(DGELQ), 2*N+LWORK(DGEQRF), N+LWORK(DORMLQ)). *> *> If SIGMA and the left singular vectors are needed @@ -347,14 +346,14 @@ *> where NB is the optimal block size for DGEQP3, DGEQRF, DORMQR. *> In general, the optimal length LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DPOCON), -*> 2*N+LWORK(DGEQRF), N+LWORK(DORMQR)). -*> Here LWORK(DORMQR) equals N*NB (for JOBU.EQ.'U') or +*> 2*N+LWORK(DGEQRF), N+LWORK(DORMQR)). +*> Here LWORK(DORMQR) equals N*NB (for JOBU.EQ.'U') or *> M*NB (for JOBU.EQ.'F'). -*> -*> If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and -*> -> if JOBV.EQ.'V' -*> the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N). -*> -> if JOBV.EQ.'J' the minimal requirement is +*> +*> If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and +*> -> if JOBV.EQ.'V' +*> the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N). +*> -> if JOBV.EQ.'J' the minimal requirement is *> LWORK >= max(2*M+N, 4*N+N*N,2*N+N*N+6). *> -> For optimal performance, LWORK should be additionally *> larger than N+M*NB, where NB is the optimal block size @@ -379,7 +378,7 @@ *> \verbatim *> INFO is INTEGER *> < 0 : if INFO = -i, then the i-th argument had an illegal value. -*> = 0 : successfull exit; +*> = 0 : successful exit; *> > 0 : SGEJSV did not converge in the maximal allowed number *> of sweeps. The computed values may be inaccurate. *> \endverbatim @@ -387,12 +386,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realGEsing * @@ -429,8 +428,8 @@ *> The rank revealing QR factorization (in this code: SGEQP3) should be *> implemented as in [3]. We have a new version of SGEQP3 under development *> that is more robust than the current one in LAPACK, with a cleaner cut in -*> rank defficient cases. It will be available in the SIGMA library [4]. -*> If M is much larger than N, it is obvious that the inital QRF with +*> rank deficient cases. It will be available in the SIGMA library [4]. +*> If M is much larger than N, it is obvious that the initial QRF with *> column pivoting can be preprocessed by the QRF without pivoting. That *> well known trick is not used in SGEJSV because in some cases heavy row *> weighting can be treated with complete pivoting. The overhead in cases @@ -459,7 +458,7 @@ *> LAPACK Working note 170. *> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR *> factorization software - a case study. -*> ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28. +*> ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. *> LAPACK Working note 176. *> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, *> QSVD, (H,K)-SVD computations. @@ -477,10 +476,10 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ M, N, A, LDA, SVA, U, LDU, V, LDV, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. IMPLICIT NONE @@ -563,7 +562,7 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN INFO = - 13 ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN - INFO = - 14 + INFO = - 15 ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. $ (LWORK .LT. MAX(7,4*N+1,2*M+N))) .OR. $ (.NOT.(LSVEC .OR. RSVEC) .AND. ERREST .AND. @@ -572,7 +571,7 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ .OR. $ (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX(7,2*M+N,4*N+1))) $ .OR. - $ (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. + $ (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. $ (LWORK.LT.MAX(2*M+N,6*N+2*N*N))) $ .OR. (LSVEC .AND. RSVEC .AND. JRACC .AND. $ LWORK.LT.MAX(2*M+N,4*N+N*N,2*N+N*N+6))) @@ -591,7 +590,11 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * * Quick return for void matrix (Y3K safe) * #:) - IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) THEN + IWORK(1:3) = 0 + WORK(1:7) = 0 + RETURN + ENDIF * * Determine whether the matrix U should be M x N or M x M * @@ -717,6 +720,7 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, IWORK(1) = 0 IWORK(2) = 0 END IF + IWORK(3) = 0 IF ( ERREST ) WORK(3) = ONE IF ( LSVEC .AND. RSVEC ) THEN WORK(4) = ONE @@ -830,7 +834,7 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, KILL = LSVEC LSVEC = RSVEC RSVEC = KILL - IF ( LSVEC ) N1 = N + IF ( LSVEC ) N1 = N * ROWPIV = .TRUE. END IF @@ -963,7 +967,7 @@ SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, ELSE IF ( L2RANK ) THEN * .. similarly as above, only slightly more gentle (less agressive). * Sudden drop on the diagonal of R1 is used as the criterion for -* close-to-rank-defficient. +* close-to-rank-deficient. TEMP1 = SQRT(SFMIN) DO 3401 p = 2, N IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. diff --git a/lapack-netlib/SRC/sgelq.f b/lapack-netlib/SRC/sgelq.f new file mode 100644 index 0000000000..4fe4d191d2 --- /dev/null +++ b/lapack-netlib/SRC/sgelq.f @@ -0,0 +1,305 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SGELQ computes a LQ factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-min(M,N) lower trapezoidal matrix L +*> (L is lower triangular if M <= N); +*> the elements above the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any LQ factorization algorithm they wish. The triangular +*> (trapezoidal) L has to be stored in the lower part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> SLASWLQ or SGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, SGELQ will use either +*> SLASWLQ (if the matrix is short-and-wide) or SGELQT to compute +*> the LQ factorization. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGELQT, SLASWLQ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'SGELQ ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'SGELQ ', ' ', M, N, 2, -1 ) + ELSE + MB = 1 + NB = N + END IF + IF( MB.GT.MIN( M, N ) .OR. MB.LT.1 ) MB = 1 + IF( NB.GT.N .OR. NB.LE.M ) NB = N + MINTSZ = M + 5 + IF ( NB.GT.M .AND. N.GT.M ) THEN + IF( MOD( N - M, NB - M ).EQ.0 ) THEN + NBLCKS = ( N - M ) / ( NB - M ) + ELSE + NBLCKS = ( N - M ) / ( NB - M ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) .OR. LWORK.LT.MB*M ) + $ .AND. ( LWORK.GE.M ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + MB = 1 + NB = N + END IF + IF( LWORK.LT.MB*M ) THEN + LMINWS = .TRUE. + MB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, M*MB ) ) .AND .( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = MB*M*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, MB*M ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGELQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF( ( N.LE.M ) .OR. ( NB.LE.M ) .OR. ( NB.GE.N ) ) THEN + CALL SGELQT( M, N, MB, A, LDA, T( 6 ), MB, WORK, INFO ) + ELSE + CALL SLASWLQ( M, N, MB, NB, A, LDA, T( 6 ), MB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, MB*M ) + RETURN +* +* End of SGELQ +* + END diff --git a/lapack-netlib/SRC/sgelq2.f b/lapack-netlib/SRC/sgelq2.f index 955331db20..5b1ad215a7 100644 --- a/lapack-netlib/SRC/sgelq2.f +++ b/lapack-netlib/SRC/sgelq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgelqf.f b/lapack-netlib/SRC/sgelqf.f index 90082106ea..99c03c0a3d 100644 --- a/lapack-netlib/SRC/sgelqf.f +++ b/lapack-netlib/SRC/sgelqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgelqt.f b/lapack-netlib/SRC/sgelqt.f new file mode 100644 index 0000000000..786255d122 --- /dev/null +++ b/lapack-netlib/SRC/sgelqt.f @@ -0,0 +1,193 @@ +* Definition: +* =========== +* +* SUBROUTINE SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is +*> lower triangular if M <= N); the elements above the diagonal +*> are the rows of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K +* .. +* .. External Subroutines .. + EXTERNAL SGEQRT2, SGEQRT3, SLARFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGELQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, MB + IB = MIN( K-I+1, MB ) +* +* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) +* + CALL SGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO ) + IF( I+IB.LE.M ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the right +* + CALL SLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, WORK , M-I-IB+1 ) + END IF + END DO + RETURN +* +* End of SGELQT +* + END diff --git a/lapack-netlib/SRC/sgelqt3.f b/lapack-netlib/SRC/sgelqt3.f new file mode 100644 index 0000000000..b94fc278e0 --- /dev/null +++ b/lapack-netlib/SRC/sgelqt3.f @@ -0,0 +1,242 @@ +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE SGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT3 recursively computes a LQ factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M =< N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> below the diagonal contain the N-by-N lower triangular matrix L; the +*> elements above the diagonal are the rows of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE SGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0D+00 ) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, M1, M2, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( N .LT. M ) THEN + INFO = -2 + ELSE IF( LDA .LT. MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LDT .LT. MAX( 1, M ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGELQT3', -INFO ) + RETURN + END IF +* + IF( M.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL SLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T ) +* + ELSE +* +* Otherwise, split A into blocks... +* + M1 = M/2 + M2 = M-M1 + I1 = MIN( M1+1, M ) + J1 = MIN( M+1, N ) +* +* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL SGELQT3( M1, N, A, LDA, T, LDT, IINFO ) +* +* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)] +* + DO I=1,M2 + DO J=1,M1 + T( I+M1, J ) = A( I+M1, J ) + END DO + END DO + CALL STRMM( 'R', 'U', 'T', 'U', M2, M1, ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + CALL SGEMM( 'N', 'T', M2, M1, N-M1, ONE, A( I1, I1 ), LDA, + & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT) +* + CALL STRMM( 'R', 'U', 'N', 'N', M2, M1, ONE, + & T, LDT, T( I1, 1 ), LDT ) +* + CALL SGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT, + & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA ) +* + CALL STRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + DO I=1,M2 + DO J=1,M1 + A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J ) + T( I+M1, J )=0 + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL SGELQT3( M2, N-M1, A( I1, I1 ), LDA, + & T( I1, I1 ), LDT, IINFO ) +* +* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,M2 + DO J=1,M1 + T( J, I+M1 ) = (A( J, I+M1 )) + END DO + END DO +* + CALL STRMM( 'R', 'U', 'T', 'U', M1, M2, ONE, + & A( I1, I1 ), LDA, T( 1, I1 ), LDT ) +* + CALL SGEMM( 'N', 'T', M1, M2, N-M, ONE, A( 1, J1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT ) +* + CALL STRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT, + & T( 1, I1 ), LDT ) +* + CALL STRMM( 'R', 'U', 'N', 'N', M1, M2, ONE, + & T( I1, I1 ), LDT, T( 1, I1 ), LDT ) +* +* +* +* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] +* [ A(1:N1,J1:N) L2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of SGELQT3 +* + END diff --git a/lapack-netlib/SRC/sgels.f b/lapack-netlib/SRC/sgels.f index 003c85de55..ee50f30ada 100644 --- a/lapack-netlib/SRC/sgels.f +++ b/lapack-netlib/SRC/sgels.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -39,7 +39,7 @@ *> involving an M-by-N matrix A, or its transpose, using a QR or LQ *> factorization of A. It is assumed that A has full rank. *> -*> The following options are provided: +*> The following options are provided: *> *> 1. If TRANS = 'N' and m >= n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem @@ -49,15 +49,15 @@ *> an underdetermined system A * X = B. *> *> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of -*> an undetermined system A**T * X = B. +*> an underdetermined system A**T * X = B. *> *> 4. If TRANS = 'T' and m < n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem *> minimize || B - A**T * X ||. *> -*> Several right hand side vectors b and solution vectors x can be +*> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the -*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. *> \endverbatim * @@ -68,7 +68,7 @@ *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': the linear system involves A; -*> = 'T': the linear system involves A**T. +*> = 'T': the linear system involves A**T. *> \endverbatim *> *> \param[in] M @@ -112,7 +112,7 @@ *> B is REAL array, dimension (LDB,NRHS) *> On entry, the matrix B of right hand side vectors, stored *> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS -*> if TRANS = 'T'. +*> if TRANS = 'T'. *> On exit, if INFO = 0, B is overwritten by the solution *> vectors, stored columnwise: *> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * @@ -183,10 +183,10 @@ SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -379,7 +379,7 @@ SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * ELSE * -* Overdetermined system of equations A**T * X = B +* Underdetermined system of equations A**T * X = B * * B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) * diff --git a/lapack-netlib/SRC/sgelsd.f b/lapack-netlib/SRC/sgelsd.f index d03f37b3ca..91656a9b33 100644 --- a/lapack-netlib/SRC/sgelsd.f +++ b/lapack-netlib/SRC/sgelsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, * RANK, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,7 +52,7 @@ *> Householder transformations, reducing the original problem *> into a "bidiagonal least squares problem" (BLS) *> (2) Solve the BLS using a divide and conquer approach. -*> (3) Apply back all the Householder tranformations to solve +*> (3) Apply back all the Householder transformations to solve *> the original least squares problem. *> *> The effective rank of A is determined by treating as zero those @@ -190,12 +190,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * @@ -210,10 +210,10 @@ SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, $ RANK, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/sgelss.f b/lapack-netlib/SRC/sgelss.f index bb46130e35..29380d4dcf 100644 --- a/lapack-netlib/SRC/sgelss.f +++ b/lapack-netlib/SRC/sgelss.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELSS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * @@ -172,10 +172,10 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -197,7 +197,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, $ MAXWRK, MINMN, MINWRK, MM, MNTHR INTEGER LWORK_SGEQRF, LWORK_SORMQR, LWORK_SGEBRD, - $ LWORK_SORMBR, LWORK_SORGBR, LWORK_SORMLQ + $ LWORK_SORMBR, LWORK_SORGBR, LWORK_SORMLQ REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR * .. * .. Local Arrays .. @@ -284,7 +284,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL SORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_SORGBR=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = MAX( MAXWRK, 3*N + LWORK_SGEBRD ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_SORMBR ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_SORGBR ) @@ -309,7 +309,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ DUM(1), DUM(1), -1, INFO ) LWORK_SGEBRD=DUM(1) * Compute space needed for SORMBR - CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, + CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_SORMBR=DUM(1) * Compute space needed for SORGBR @@ -320,7 +320,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_SORMLQ=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, $ -1 ) MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_SGEBRD ) @@ -342,7 +342,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ DUM(1), DUM(1), -1, INFO ) LWORK_SGEBRD=DUM(1) * Compute space needed for SORMBR - CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, + CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_SORMBR=DUM(1) * Compute space needed for SORGBR diff --git a/lapack-netlib/SRC/sgelsy.f b/lapack-netlib/SRC/sgelsy.f index 2ad42b7f85..58bd7c8cf6 100644 --- a/lapack-netlib/SRC/sgelsy.f +++ b/lapack-netlib/SRC/sgelsy.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGELSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGELSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * REAL RCOND @@ -29,7 +29,7 @@ * INTEGER JPVT( * ) * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,19 +184,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * *> \par Contributors: * ================== *> -*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n *> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> @@ -204,10 +204,10 @@ SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/sgemlq.f b/lapack-netlib/SRC/sgemlq.f new file mode 100644 index 0000000000..dedbe7752d --- /dev/null +++ b/lapack-netlib/SRC/sgemlq.f @@ -0,0 +1,283 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMLQ overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by short wide LQ +*> factorization (SGELQ) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> Part of the data structure to represent Q as returned by DGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by SGELQ. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> SLASWLQ or SGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, SGELQ will use either +*> SLASWLQ (if the matrix is wide-and-short) or SGELQT to compute +*> the LQ factorization. +*> This version of SGEMLQ will use either SLAMSWLQ or SGEMLQT to +*> multiply matrix Q by another matrix. +*> Further Details in SLAMSWLQ or SGEMLQT. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLAMSWLQ, SGEMLQT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * MB + MN = M + ELSE + LW = M * MB + MN = N + END IF +* + IF( ( NB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, NB - K ) .EQ. 0 ) THEN + NBLCKS = ( MN - K ) / ( NB - K ) + ELSE + NBLCKS = ( MN - K ) / ( NB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = REAL( LW ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( NB.LE.K ) .OR. ( NB.GE.MAX( M, N, K ) ) ) THEN + CALL SGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T( 6 ), MB, C, LDC, WORK, INFO ) + ELSE + CALL SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ MB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = REAL( LW ) +* + RETURN +* +* End of SGEMLQ +* + END diff --git a/lapack-netlib/SRC/sgemlqt.f b/lapack-netlib/SRC/sgemlqt.f new file mode 100644 index 0000000000..4707434297 --- /dev/null +++ b/lapack-netlib/SRC/sgemlqt.f @@ -0,0 +1,272 @@ +* Definition: +* =========== +* +* SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. +* REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMQRT overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q C C Q +*> TRANS = 'T': Q**T C C Q**T +*> +*> where Q is a real orthogonal matrix defined as the product of K +*> elementary reflectors: +*> +*> Q = H(1) H(2) . . . H(K) = I - V T V**T +*> +*> generated using the compact WY representation as returned by DGELQT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DGELQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension (LDV,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQT in the first K rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DGELQT, stored as a MB-by-M matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array. The dimension of +*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE SGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. + REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0) THEN + INFO = -5 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL SLARFB( 'L', 'T', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL SLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL SLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL SLARFB( 'R', 'T', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of SGEMLQT +* + END diff --git a/lapack-netlib/SRC/sgemqr.f b/lapack-netlib/SRC/sgemqr.f new file mode 100644 index 0000000000..307fc8ca93 --- /dev/null +++ b/lapack-netlib/SRC/sgemqr.f @@ -0,0 +1,285 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMQR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (SGEQR) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,K) +*> Part of the data structure to represent Q as returned by SGEQR. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by SGEQR. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> SLATSQR or SGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, SGEQR will use either +*> SLATSQR (if the matrix is tall-and-skinny) or SGEQRT to compute +*> the QR factorization. +*> This version of SGEMQR will use either SLAMTSQR or SGEMQRT to +*> multiply matrix Q by another matrix. +*> Further Details in SLAMTSQR or SGEMQRT. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMQRT, SLAMTSQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * NB + MN = M + ELSE + LW = MB * NB + MN = N + END IF +* + IF( ( MB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, MB - K ).EQ.0 ) THEN + NBLCKS = ( MN - K ) / ( MB - K ) + ELSE + NBLCKS = ( MN - K ) / ( MB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, MN ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( MB.LE.K ) .OR. ( MB.GE.MAX( M, N, K ) ) ) THEN + CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, INFO ) + ELSE + CALL SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of SGEMQR +* + END diff --git a/lapack-netlib/SRC/sgemqrt.f b/lapack-netlib/SRC/sgemqrt.f index 3b29f765fb..843151a9ce 100644 --- a/lapack-netlib/SRC/sgemqrt.f +++ b/lapack-netlib/SRC/sgemqrt.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, +* SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDC, M, N, NB, LDT @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -46,7 +46,7 @@ *> *> Q = H(1) H(2) . . . H(K) = I - V T V**T *> -*> generated using the compact WY representation as returned by SGEQRT. +*> generated using the compact WY representation as returned by SGEQRT. *> *> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. *> \endverbatim @@ -155,23 +155,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== - SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, + SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -207,7 +207,7 @@ SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF( LEFT ) THEN LDWORK = MAX( 1, N ) Q = M @@ -248,17 +248,17 @@ SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL SLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL SLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL SLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL SLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * @@ -266,9 +266,9 @@ SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL SLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL SLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * @@ -276,9 +276,9 @@ SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL SLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL SLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * diff --git a/lapack-netlib/SRC/sgeql2.f b/lapack-netlib/SRC/sgeql2.f index 4d44618604..53009b9de4 100644 --- a/lapack-netlib/SRC/sgeql2.f +++ b/lapack-netlib/SRC/sgeql2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgeqlf.f b/lapack-netlib/SRC/sgeqlf.f index 7d2949a949..ccf7a0a0d8 100644 --- a/lapack-netlib/SRC/sgeqlf.f +++ b/lapack-netlib/SRC/sgeqlf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQLF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQLF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgeqp3.f b/lapack-netlib/SRC/sgeqp3.f index ae28fc4bb3..303a944f4d 100644 --- a/lapack-netlib/SRC/sgeqp3.f +++ b/lapack-netlib/SRC/sgeqp3.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -27,7 +27,7 @@ * INTEGER JPVT( * ) * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -151,10 +151,10 @@ * ===================================================================== SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgeqr.f b/lapack-netlib/SRC/sgeqr.f new file mode 100644 index 0000000000..f939abd9df --- /dev/null +++ b/lapack-netlib/SRC/sgeqr.f @@ -0,0 +1,307 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SGEQR computes a QR factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R +*> (R is upper triangular if M >= N); +*> the elements below the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any QR factorization algorithm they wish. The triangular +*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> SLATSQR or SGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, SGEQR will use either +*> SLATSQR (if the matrix is tall-and-skinny) or SGEQRT to compute +*> the QR factorization. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + REAL A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLATSQR, SGEQRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'SGEQR ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'SGEQR ', ' ', M, N, 2, -1 ) + ELSE + MB = M + NB = 1 + END IF + IF( MB.GT.M .OR. MB.LE.N ) MB = M + IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1 + MINTSZ = N + 5 + IF ( MB.GT.N .AND. M.GT.N ) THEN + IF( MOD( M - N, MB - N ).EQ.0 ) THEN + NBLCKS = ( M - N ) / ( MB - N ) + ELSE + NBLCKS = ( M - N ) / ( MB - N ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N ) + $ .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + NB = 1 + MB = M + END IF + IF( LWORK.LT.NB*N ) THEN + LMINWS = .TRUE. + NB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = NB*N*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, NB*N ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN + CALL SGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO ) + ELSE + CALL SLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, NB*N ) +* + RETURN +* +* End of SGEQR +* + END diff --git a/lapack-netlib/SRC/sgeqr2.f b/lapack-netlib/SRC/sgeqr2.f index 1f027f6dcb..3b990f8253 100644 --- a/lapack-netlib/SRC/sgeqr2.f +++ b/lapack-netlib/SRC/sgeqr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgeqr2p.f b/lapack-netlib/SRC/sgeqr2p.f index c5cd0c8488..f48af9d2d8 100644 --- a/lapack-netlib/SRC/sgeqr2p.f +++ b/lapack-netlib/SRC/sgeqr2p.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQR2P + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> On entry, the m by n matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the min(m,n) by n upper trapezoidal matrix R (R is -*> upper triangular if m >= n). The diagonal entries of R +*> upper triangular if m >= n). The diagonal entries of R *> are nonnegative; the elements below the diagonal, *> with the array TAU, represent the orthogonal matrix Q as a *> product of elementary reflectors (see Further Details). @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -124,10 +124,10 @@ * ===================================================================== SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgeqrf.f b/lapack-netlib/SRC/sgeqrf.f index 8474bf4c5c..0f79c2ca5f 100644 --- a/lapack-netlib/SRC/sgeqrf.f +++ b/lapack-netlib/SRC/sgeqrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,7 +87,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is +*> For optimum performance LWORK >= N*NB, where NB is *> the optimal blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgeqrfp.f b/lapack-netlib/SRC/sgeqrfp.f index f07fcd42f7..654c0a13ae 100644 --- a/lapack-netlib/SRC/sgeqrfp.f +++ b/lapack-netlib/SRC/sgeqrfp.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQRFP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQRFP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> On entry, the M-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the min(M,N)-by-N upper trapezoidal matrix R (R is -*> upper triangular if m >= n). The diagonal entries of R +*> upper triangular if m >= n). The diagonal entries of R *> are nonnegative; the elements below the diagonal, *> with the array TAU, represent the orthogonal matrix Q as a *> product of min(m,n) elementary reflectors (see Further @@ -88,7 +88,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is +*> For optimum performance LWORK >= N*NB, where NB is *> the optimal blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -139,10 +139,10 @@ * ===================================================================== SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgeqrt.f b/lapack-netlib/SRC/sgeqrt.f index e995212a3a..d8b9fade52 100644 --- a/lapack-netlib/SRC/sgeqrt.f +++ b/lapack-netlib/SRC/sgeqrt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. * REAL A( LDA, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> SGEQRT computes a blocked QR factorization of a real M-by-N matrix A -*> using the compact WY representation of Q. +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -130,9 +130,9 @@ *> in the matrix A. The 1's along the diagonal of V are not stored in A. *> *> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = (T1 T2 ... TB). @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -194,7 +194,7 @@ SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * DO I = 1, K, NB IB = MIN( K-I+1, NB ) -* +* * Compute the QR factorization of the current block A(I:M,I:I+IB-1) * IF( USE_RECURSIVE_QR ) THEN @@ -207,12 +207,12 @@ SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * Update by applying H**T to A(I:M,I+IB:N) from the left * CALL SLARFB( 'L', 'T', 'F', 'C', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I, I ), LDA, T( 1, I ), LDT, $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN -* +* * End of SGEQRT * END diff --git a/lapack-netlib/SRC/sgeqrt2.f b/lapack-netlib/SRC/sgeqrt2.f index 08e9cf1d56..349fd4b60c 100644 --- a/lapack-netlib/SRC/sgeqrt2.f +++ b/lapack-netlib/SRC/sgeqrt2.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SGEQRT2 computes a QR factorization of a real M-by-N matrix A, -*> using the compact WY representation of Q. +*> SGEQRT2 computes a QR factorization of a real M-by-N matrix A, +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N @@ -170,7 +170,7 @@ SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) CALL XERBLA( 'SGEQRT2', -INFO ) RETURN END IF -* +* K = MIN( M, N ) * DO I = 1, K @@ -188,13 +188,13 @@ SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)] * - CALL SGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, + CALL SGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) * * A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H * ALPHA = -(T( I, 1 )) - CALL SGER( M-I+1, N-I, ALPHA, A( I, I ), 1, + CALL SGER( M-I+1, N-I, ALPHA, A( I, I ), 1, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF @@ -207,7 +207,7 @@ SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) * T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I) * ALPHA = -T( I, 1 ) - CALL SGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, + CALL SGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * @@ -220,7 +220,7 @@ SUBROUTINE SGEQRT2( M, N, A, LDA, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO - + * * End of SGEQRT2 * diff --git a/lapack-netlib/SRC/sgeqrt3.f b/lapack-netlib/SRC/sgeqrt3.f index 86a43f67de..8316c7fed0 100644 --- a/lapack-netlib/SRC/sgeqrt3.f +++ b/lapack-netlib/SRC/sgeqrt3.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGEQRT3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. * REAL A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SGEQRT3 recursively computes a QR factorization of a real M-by-N -*> matrix A, using the compact WY representation of Q. +*> SGEQRT3 recursively computes a QR factorization of a real M-by-N +*> matrix A, using the compact WY representation of Q. *> -*> Based on the algorithm of Elmroth and Gustavson, +*> Based on the algorithm of Elmroth and Gustavson, *> IBM J. Res. Develop. Vol 44 No. 4 July 2000. *> \endverbatim * @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realGEcomputational * @@ -132,10 +132,10 @@ * ===================================================================== RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT @@ -177,8 +177,8 @@ RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute Householder transform when N=1 * - CALL SLARFG( M, A, A( MIN( 2, M ), 1 ), 1, T ) -* + CALL SLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) +* ELSE * * Otherwise, split A into blocks... @@ -199,7 +199,7 @@ RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) T( I, J+N1 ) = A( I, J+N1 ) END DO END DO - CALL STRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, + CALL STRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * CALL SGEMM( 'T', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, @@ -208,7 +208,7 @@ RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL STRMM( 'L', 'U', 'T', 'N', N1, N2, ONE, & T, LDT, T( 1, J1 ), LDT ) * - CALL SGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, + CALL SGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL STRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, @@ -222,7 +222,7 @@ RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H * - CALL SGEQRT3( M-N1, N2, A( J1, J1 ), LDA, + CALL SGEQRT3( M-N1, N2, A( J1, J1 ), LDA, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 @@ -236,13 +236,13 @@ RECURSIVE SUBROUTINE SGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL STRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) * - CALL SGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, + CALL SGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) * - CALL STRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, + CALL STRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, & T( 1, J1 ), LDT ) * - CALL STRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, + CALL STRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] diff --git a/lapack-netlib/SRC/sgerfs.f b/lapack-netlib/SRC/sgerfs.f index c7ec92508a..aba761de10 100644 --- a/lapack-netlib/SRC/sgerfs.f +++ b/lapack-netlib/SRC/sgerfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -185,10 +185,10 @@ SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgerfsx.f b/lapack-netlib/SRC/sgerfsx.f index 2e1a6d741b..3f518899e2 100644 --- a/lapack-netlib/SRC/sgerfsx.f +++ b/lapack-netlib/SRC/sgerfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,7 +143,7 @@ *> R is REAL array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. +*> is not accessed. *> If R is accessed, each element of R should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -158,7 +158,7 @@ *> C is REAL array, dimension (N) *> The column scale factors for A. If EQUED = 'C' or 'B', A is *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C -*> is not accessed. +*> is not accessed. *> If C is accessed, each element of C should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -399,12 +399,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -414,10 +414,10 @@ SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, EQUED @@ -475,11 +475,10 @@ SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL SLAMCH, SLANGE, SLA_GERCOND REAL SLAMCH, SLANGE, SLA_GERCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/sgerq2.f b/lapack-netlib/SRC/sgerq2.f index 6bbfbb8098..68f78c6e2b 100644 --- a/lapack-netlib/SRC/sgerq2.f +++ b/lapack-netlib/SRC/sgerq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGERQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgerqf.f b/lapack-netlib/SRC/sgerqf.f index 57147304d0..8b842cbd89 100644 --- a/lapack-netlib/SRC/sgerqf.f +++ b/lapack-netlib/SRC/sgerqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGERQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGERQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sgesc2.f b/lapack-netlib/SRC/sgesc2.f index bba4c63719..c78daa334e 100644 --- a/lapack-netlib/SRC/sgesc2.f +++ b/lapack-netlib/SRC/sgesc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, N * REAL SCALE @@ -28,7 +28,7 @@ * INTEGER IPIV( * ), JPIV( * ) * REAL A( LDA, * ), RHS( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, N diff --git a/lapack-netlib/SRC/sgesdd.f b/lapack-netlib/SRC/sgesdd.f index 1bc7e8a4e9..0ba2a78c75 100644 --- a/lapack-netlib/SRC/sgesdd.f +++ b/lapack-netlib/SRC/sgesdd.f @@ -2,35 +2,35 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESDD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESDD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, -* LWORK, IWORK, INFO ) -* +* SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, +* WORK, LWORK, IWORK, INFO ) +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* REAL A( LDA, * ), S( * ), U( LDU, * ), +* REAL A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,8 +154,8 @@ *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; +*> The leading dimension of the array VT. LDVT >= 1; +*> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; *> if JOBZ = 'S', LDVT >= min(M,N). *> \endverbatim *> @@ -169,16 +169,18 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. -*> If JOBZ = 'N', -*> LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)). -*> If JOBZ = 'O', -*> LWORK >= 3*min(M,N) + -*> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). -*> If JOBZ = 'S' or 'A' -*> LWORK >= min(M,N)*(7+4*min(M,N)) -*> For good performance, LWORK should generally be larger. -*> If LWORK = -1 but other input arguments are legal, WORK(1) -*> returns the optimal LWORK. +*> If LWORK = -1, a workspace query is assumed. The optimal +*> size for the WORK array is calculated and stored in WORK(1), +*> and no other work except argument checking is performed. +*> +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ). +*> If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ). +*> If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn. +*> If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx. +*> These are not tight minimums in all cases; see comments inside code. +*> For good performance, LWORK should generally be larger; +*> a query is recommended. *> \endverbatim *> *> \param[out] IWORK @@ -197,12 +199,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realGEsing * @@ -213,13 +215,14 @@ *> California at Berkeley, USA *> * ===================================================================== - SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, - $ LWORK, IWORK, INFO ) + SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ @@ -227,14 +230,14 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * .. * .. Array Arguments .. INTEGER IWORK( * ) - REAL A( LDA, * ), S( * ), U( LDU, * ), + REAL A( LDA, * ), S( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. - REAL ZERO, ONE + REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. @@ -243,7 +246,16 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, $ MNTHR, NWORK, WRKBL - REAL ANRM, BIGNUM, EPS, SMLNUM + INTEGER LWORK_SGEBRD_MN, LWORK_SGEBRD_MM, + $ LWORK_SGEBRD_NN, LWORK_SGELQF_MN, + $ LWORK_SGEQRF_MN, + $ LWORK_SORGBR_P_MM, LWORK_SORGBR_Q_NN, + $ LWORK_SORGLQ_MN, LWORK_SORGLQ_NN, + $ LWORK_SORGQR_MM, LWORK_SORGQR_MN, + $ LWORK_SORMBR_PRT_MM, LWORK_SORMBR_QLN_MM, + $ LWORK_SORMBR_PRT_MN, LWORK_SORMBR_QLN_MN, + $ LWORK_SORMBR_PRT_NN, LWORK_SORMBR_QLN_NN + REAL ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) @@ -256,9 +268,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV REAL SLAMCH, SLANGE - EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE + EXTERNAL SLAMCH, SLANGE, LSAME * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -267,13 +278,13 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Test the input arguments * - INFO = 0 - MINMN = MIN( M, N ) - WNTQA = LSAME( JOBZ, 'A' ) - WNTQS = LSAME( JOBZ, 'S' ) + INFO = 0 + MINMN = MIN( M, N ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS - WNTQO = LSAME( JOBZ, 'O' ) - WNTQN = LSAME( JOBZ, 'N' ) + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN @@ -294,222 +305,270 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF * * Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, +* Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace allocated at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) +* following subroutine, as returned by ILAENV. * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 + BDSPAC = 0 + MNTHR = INT( MINMN*11.0E0 / 6.0E0 ) IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for SBDSDC * - MNTHR = INT( MINMN*11.0E0 / 6.0E0 ) IF( WNTQN ) THEN +* sbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. BDSPAC = 7*N ELSE BDSPAC = 3*N*N + 4*N END IF +* +* Compute space preferred for each routine + CALL SGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_SGEBRD_MN = INT( DUM(1) ) +* + CALL SGEBRD( N, N, DUM(1), N, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_SGEBRD_NN = INT( DUM(1) ) +* + CALL SGEQRF( M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_SGEQRF_MN = INT( DUM(1) ) +* + CALL SORGBR( 'Q', N, N, N, DUM(1), N, DUM(1), DUM(1), -1, + $ IERR ) + LWORK_SORGBR_Q_NN = INT( DUM(1) ) +* + CALL SORGQR( M, M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_SORGQR_MM = INT( DUM(1) ) +* + CALL SORGQR( M, N, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) + LWORK_SORGQR_MN = INT( DUM(1) ) +* + CALL SORMBR( 'P', 'R', 'T', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_SORMBR_PRT_NN = INT( DUM(1) ) +* + CALL SORMBR( 'Q', 'L', 'N', N, N, N, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_SORMBR_QLN_NN = INT( DUM(1) ) +* + CALL SORMBR( 'Q', 'L', 'N', M, N, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_SORMBR_QLN_MN = INT( DUM(1) ) +* + CALL SORMBR( 'Q', 'L', 'N', M, M, N, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_SORMBR_QLN_MM = INT( DUM(1) ) +* IF( M.GE.MNTHR ) THEN IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+N ) + WRKBL = N + LWORK_SGEQRF_MN + WRKBL = MAX( WRKBL, 3*N + LWORK_SGEBRD_NN ) + MAXWRK = MAX( WRKBL, BDSPAC + N ) MINWRK = BDSPAC + N ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') -* - WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 2 (M >> N, JOBZ='O') +* + WRKBL = N + LWORK_SGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_SORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + 2*N*N MINWRK = BDSPAC + 2*N*N + 3*N ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') -* - WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 3 (M >> N, JOBZ='S') +* + WRKBL = N + LWORK_SGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_SORGQR_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N MINWRK = BDSPAC + N*N + 3*N ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') -* - WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 4 (M >> N, JOBZ='A') +* + WRKBL = N + LWORK_SGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_SORGQR_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SGEBRD_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 2*N + M + MINWRK = N*N + MAX( 3*N + BDSPAC, N + M ) END IF ELSE * -* Path 5 (M at least N, but not much larger) +* Path 5 (M >= N, but not much larger) * - WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1, - $ -1 ) + WRKBL = 3*N + LWORK_SGEBRD_MN IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) +* Path 5n (M >= N, jobz='N') + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQO ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) +* Path 5o (M >= N, jobz='O') + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + M*N - MINWRK = 3*N + MAX( M, N*N+BDSPAC ) + MINWRK = 3*N + MAX( M, N*N + BDSPAC ) ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) +* Path 5s (M >= N, jobz='S') + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_MN ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*N+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC+3*N ) +* Path 5a (M >= N, jobz='A') + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*N + LWORK_SORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) END IF END IF - ELSE IF ( MINMN.GT.0 ) THEN + ELSE IF( MINMN.GT.0 ) THEN * * Compute space needed for SBDSDC * - MNTHR = INT( MINMN*11.0E0 / 6.0E0 ) IF( WNTQN ) THEN +* sbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) +* keep 7*N for backwards compatability. BDSPAC = 7*M ELSE BDSPAC = 3*M*M + 4*M END IF +* +* Compute space preferred for each routine + CALL SGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_SGEBRD_MN = INT( DUM(1) ) +* + CALL SGEBRD( M, M, A, M, S, DUM(1), DUM(1), + $ DUM(1), DUM(1), -1, IERR ) + LWORK_SGEBRD_MM = INT( DUM(1) ) +* + CALL SGELQF( M, N, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_SGELQF_MN = INT( DUM(1) ) +* + CALL SORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) + LWORK_SORGLQ_NN = INT( DUM(1) ) +* + CALL SORGLQ( M, N, M, A, M, DUM(1), DUM(1), -1, IERR ) + LWORK_SORGLQ_MN = INT( DUM(1) ) +* + CALL SORGBR( 'P', M, M, M, A, N, DUM(1), DUM(1), -1, IERR ) + LWORK_SORGBR_P_MM = INT( DUM(1) ) +* + CALL SORMBR( 'P', 'R', 'T', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_SORMBR_PRT_MM = INT( DUM(1) ) +* + CALL SORMBR( 'P', 'R', 'T', M, N, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_SORMBR_PRT_MN = INT( DUM(1) ) +* + CALL SORMBR( 'P', 'R', 'T', N, N, M, DUM(1), N, + $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) + LWORK_SORMBR_PRT_NN = INT( DUM(1) ) +* + CALL SORMBR( 'Q', 'L', 'N', M, M, M, DUM(1), M, + $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) + LWORK_SORMBR_QLN_MM = INT( DUM(1) ) +* IF( N.GE.MNTHR ) THEN IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * - WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+M ) + WRKBL = M + LWORK_SGELQF_MN + WRKBL = MAX( WRKBL, 3*M + LWORK_SGEBRD_MM ) + MAXWRK = MAX( WRKBL, BDSPAC + M ) MINWRK = BDSPAC + M ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') -* - WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 2t (N >> M, JOBZ='O') +* + WRKBL = M + LWORK_SGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_SORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + 2*M*M MINWRK = BDSPAC + 2*M*M + 3*M ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* - WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 3t (N >> M, JOBZ='S') +* + WRKBL = M + LWORK_SGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_SORGLQ_MN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M MINWRK = BDSPAC + M*M + 3*M ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') -* - WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 4t (N >> M, JOBZ='A') +* + WRKBL = M + LWORK_SGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_SORGLQ_NN ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SGEBRD_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_MM ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = M*M + MAX( 3*M + BDSPAC, M + N ) END IF ELSE * -* Path 5t (N greater than M, but not much larger) +* Path 5t (N > M, but not much larger) * - WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1, - $ -1 ) + WRKBL = 3*M + LWORK_SGEBRD_MN IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5tn (N > M, jobz='N') + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQO ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) +* Path 5to (N > M, jobz='O') + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_MN ) + WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*N - MINWRK = 3*M + MAX( N, M*M+BDSPAC ) + MINWRK = 3*M + MAX( N, M*M + BDSPAC ) ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5ts (N > M, jobz='S') + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_MN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) +* Path 5ta (N > M, jobz='A') + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 3*M + LWORK_SORMBR_PRT_NN ) + MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) END IF END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * @@ -559,17 +618,18 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) +* Workspace: need N [tau] + N [work] +* Workspace: prefer N [tau] + N*NB [work] * CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Zero out below R * @@ -580,7 +640,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work] * CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -588,14 +649,14 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IE + N * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need N+BDSPAC) +* Workspace: need N [e] + BDSPAC * CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ = 'O') +* Path 2 (M >> N, JOBZ = 'O') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * @@ -603,42 +664,45 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK(IR) is LDWRKR by N * - IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. LDA*N + N*N + 3*N + BDSPAC ) THEN LDWRKR = LDA ELSE - LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N + LDWRKR = ( LWORK - N*N - 3*N - BDSPAC ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), + CALL SLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * -* Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Bidiagonalize R in WORK(IR) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * WORK(IU) is N by N * @@ -648,7 +712,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -656,21 +720,23 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite WORK(IU) by left singular vectors of R * and VT by right singular vectors of R -* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in WORK(IR) and copying to A -* (Workspace: need 2*N*N, prefer N*N+M*N) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] +* Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U] * DO 10 I = 1, M, LDWRKR - CHUNK = MIN( M-I+1, LDWRKR ) + CHUNK = MIN( M - I + 1, LDWRKR ) CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), N, ZERO, WORK( IR ), $ LDWRKR ) @@ -680,7 +746,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') +* Path 3 (M >> N, JOBZ='S') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -693,38 +759,41 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), + CALL SLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need N*N [R] + N [tau] + N [work] +* Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagoal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -732,19 +801,20 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of R and VT * by right singular vectors of R -* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U -* (Workspace: need N*N) +* Workspace: need N*N [R] * CALL SLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), @@ -752,7 +822,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') +* Path 4 (M >> N, JOBZ='A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -765,16 +835,18 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* Workspace: need N*N [U] + N [tau] + N [work] +* Workspace: prefer N*N [U] + N [tau] + N*NB [work] * CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) +* Workspace: need N*N [U] + N [tau] + M [work] +* Workspace: prefer N*N [U] + N [tau] + M*NB [work] CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce R in A, zeroing out other entries * @@ -785,7 +857,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -794,7 +867,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -802,18 +875,19 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite WORK(IU) by left singular vectors of R and VT * by right singular vectors of R -* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) +* Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] +* Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A -* (Workspace: need N*N) +* Workspace: need N*N [U] * CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ), $ LDWRKU, ZERO, A, LDA ) @@ -828,7 +902,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * M .LT. MNTHR * -* Path 5 (M at least N, but not much larger) +* Path 5 (M >= N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 @@ -837,21 +911,24 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work] * CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5n (M >= N, JOBZ='N') * Perform bidiagonal SVD, only computing singular values -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 5o (M >= N, JOBZ='O') IU = NWORK - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * * WORK( IU ) is M by N * @@ -859,6 +936,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IU + LDWRKU*N CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), $ LDWRKU ) +* IR is unused; silence compile warnings + IR = -1 ELSE * * WORK( IU ) is N by N @@ -869,53 +948,59 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * WORK(IR) is LDWRKR by N * IR = NWORK - LDWRKR = ( LWORK-N*N-3*N ) / N + LDWRKR = ( LWORK - N*N - 3*N ) / N END IF NWORK = IU + LDWRKU*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), $ IWORK, INFO ) * * Overwrite VT by right singular vectors of A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * +* Path 5o-fast * Overwrite WORK(IU) by left singular vectors of A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + M*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy left singular vectors of A from WORK(IU) to A * CALL SLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) ELSE * +* Path 5o-slow * Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of * bidiagonal matrix in WORK(IU), storing result in * WORK(IR) and copying to A -* (Workspace: need 2*N*N, prefer N*N+M*N) +* Workspace: need 3*N [e, tauq, taup] + N*N [U] + NB*N [R] +* Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N [R] * DO 20 I = 1, M, LDWRKR - CHUNK = MIN( M-I+1, LDWRKR ) + CHUNK = MIN( M - I + 1, LDWRKR ) CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), LDWRKU, ZERO, $ WORK( IR ), LDWRKR ) @@ -926,10 +1011,11 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * +* Path 5s (M >= N, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU ) CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -938,20 +1024,22 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 3*N, prefer 2*N+N*NB) +* Workspace: need 3*N [e, tauq, taup] + N [work] +* Workspace: prefer 3*N [e, tauq, taup] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * +* Path 5a (M >= N, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU ) CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -961,20 +1049,21 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Set the right corner of U to identity matrix * IF( M.GT.N ) THEN - CALL SLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ), + CALL SLASET( 'F', M - N, M - N, ZERO, ONE, U(N+1,N+1), $ LDU ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) +* Workspace: need 3*N [e, tauq, taup] + M [work] +* Workspace: prefer 3*N [e, tauq, taup] + M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) END IF * END IF @@ -989,17 +1078,18 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) +* Workspace: need M [tau] + M [work] +* Workspace: prefer M [tau] + M*NB [work] * CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Zero out above L * @@ -1010,7 +1100,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work] * CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1018,68 +1109,69 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = IE + M * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need M+BDSPAC) +* Workspace: need M [e] + BDSPAC * CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') +* Path 2t (N >> M, JOBZ='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IVT = 1 * -* IVT is M by M +* WORK(IVT) is M by M +* WORK(IL) is M by M; it is later resized to M by chunk for gemm * IL = IVT + M*M - IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN -* -* WORK(IL) is M by N -* + IF( LWORK .GE. M*N + M*M + 3*M + BDSPAC ) THEN LDWRKL = M CHUNK = N ELSE LDWRKL = M - CHUNK = ( LWORK-M*M ) / M + CHUNK = ( LWORK - M*M ) / M END IF ITAU = IL + LDWRKL*M NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing about above it * CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) - CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IL+LDWRKL ), LDWRKL ) + CALL SLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U, and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), @@ -1087,21 +1179,24 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L -* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) +* Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), WORK( IVT ), M, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by Q * in A, storing result in WORK(IL) and copying to A -* (Workspace: need 2*M*M, prefer M*M+M*N) +* Workspace: need M*M [VT] + M*M [L] +* Workspace: prefer M*M [VT] + M*N [L] +* At this point, L is resized as M by chunk. * DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) + BLK = MIN( N - I + 1, CHUNK ) CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL ) CALL SLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, @@ -1110,7 +1205,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') +* Path 3t (N >> M, JOBZ='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1123,38 +1218,41 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing out above it * CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) - CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IL+LDWRKL ), LDWRKL ) + CALL SLASET( 'U', M - 1, M - 1, ZERO, ZERO, + $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [L] + M [tau] + M [work] +* Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Bidiagonalize L in WORK(IU). +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -1162,18 +1260,19 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and VT * by right singular vectors of L -* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IL) by * Q in A, storing result in VT -* (Workspace: need M*M) +* Workspace: need M*M [L] * CALL SLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, @@ -1181,7 +1280,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') +* Path 4t (N >> M, JOBZ='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1194,17 +1293,19 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M [tau] + M [work] +* Workspace: prefer M*M [VT] + M [tau] + M*NB [work] * CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need M*M [VT] + M [tau] + N [work] +* Workspace: prefer M*M [VT] + M [tau] + N*NB [work] * CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce L in A, zeroing out other entries * @@ -1215,7 +1316,8 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1224,7 +1326,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, @@ -1232,18 +1334,19 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L -* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) +* Workspace: need M*M [VT] + 3*M [e, tauq, taup]+ M [work] +* Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', M, M, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by * Q in VT, storing result in A -* (Workspace: need M*M) +* Workspace: need M*M [VT] * CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, $ VT, LDVT, ZERO, A, LDA ) @@ -1258,7 +1361,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * N .LT. MNTHR * -* Path 5t (N greater than M, but not much larger) +* Path 5t (N > M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 @@ -1267,28 +1370,33 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work] * CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5tn (N > M, JOBZ='N') * Perform bidiagonal SVD, only computing singular values -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 5to (N > M, JOBZ='O') LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * * WORK( IVT ) is M by N * CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), $ LDWKVT ) NWORK = IVT + LDWKVT*N +* IL is unused; silence compile warnings + IL = -1 ELSE * * WORK( IVT ) is M by M @@ -1298,52 +1406,58 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK(IL) is M by CHUNK * - CHUNK = ( LWORK-M*M-3*M ) / M + CHUNK = ( LWORK - M*M - 3*M ) / M END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M*M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + BDSPAC * CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, $ WORK( NWORK ), IWORK, INFO ) * * Overwrite U by left singular vectors of A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) * - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * +* Path 5to-fast * Overwrite WORK(IVT) by left singular vectors of A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*N [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work] * CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy right singular vectors of A from WORK(IVT) to A * CALL SLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) ELSE * +* Path 5to-slow * Generate P**T in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( NWORK ), LWORK-NWORK+1, IERR ) + $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by right singular vectors of * bidiagonal matrix in WORK(IVT), storing result in * WORK(IL) and copying to A -* (Workspace: need 2*M*M, prefer M*M+M*N) +* Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M*NB [L] +* Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N [L] * DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) + BLK = MIN( N - I + 1, CHUNK ) CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), $ LDWKVT, A( 1, I ), LDA, ZERO, $ WORK( IL ), M ) @@ -1353,10 +1467,11 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF ELSE IF( WNTQS ) THEN * +* Path 5ts (N > M, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1365,20 +1480,22 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 3*M, prefer 2*M+M*NB) +* Workspace: need 3*M [e, tauq, taup] + M [work] +* Workspace: prefer 3*M [e, tauq, taup] + M*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * +* Path 5ta (N > M, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1388,20 +1505,21 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Set the right corner of VT to identity matrix * IF( N.GT.M ) THEN - CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ), + CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT(M+1,M+1), $ LDVT ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A -* (Workspace: need 2*M+N, prefer 2*M+N*NB) +* Workspace: need 3*M [e, tauq, taup] + N [work] +* Workspace: prefer 3*M [e, tauq, taup] + N*NB [work] * CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), - $ LWORK-NWORK+1, IERR ) + $ LWORK - NWORK + 1, IERR ) END IF * END IF diff --git a/lapack-netlib/SRC/sgesv.f b/lapack-netlib/SRC/sgesv.f index 40509d3cd5..6ef2cf98b5 100644 --- a/lapack-netlib/SRC/sgesv.f +++ b/lapack-netlib/SRC/sgesv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEsolve * * ===================================================================== SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff --git a/lapack-netlib/SRC/sgesvd.f b/lapack-netlib/SRC/sgesvd.f index 263548b077..c1756fa613 100644 --- a/lapack-netlib/SRC/sgesvd.f +++ b/lapack-netlib/SRC/sgesvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,7 +173,7 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code): -*> - PATH 1 (M much larger than N, JOBU='N') +*> - PATH 1 (M much larger than N, JOBU='N') *> - PATH 1t (N much larger than M, JOBVT='N') *> LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)) for the other paths *> For good performance, LWORK should generally be larger. @@ -198,10 +198,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -211,7 +211,7 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -314,24 +314,24 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, BDSPAC = 5*N * Compute space needed for SGEQRF CALL SGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_SGEQRF=DUM(1) + LWORK_SGEQRF = INT( DUM(1) ) * Compute space needed for SORGQR CALL SORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_SORGQR_N=DUM(1) + LWORK_SORGQR_N = INT( DUM(1) ) CALL SORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_SORGQR_M=DUM(1) + LWORK_SORGQR_M = INT( DUM(1) ) * Compute space needed for SGEBRD CALL SGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_SGEBRD=DUM(1) + LWORK_SGEBRD = INT( DUM(1) ) * Compute space needed for SORGBR P CALL SORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_P=DUM(1) + LWORK_SORGBR_P = INT( DUM(1) ) * Compute space needed for SORGBR Q CALL SORGBR( 'Q', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_Q=DUM(1) + LWORK_SORGBR_Q = INT( DUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN @@ -447,18 +447,18 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * CALL SGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_SGEBRD=DUM(1) + LWORK_SGEBRD = INT( DUM(1) ) MAXWRK = 3*N + LWORK_SGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL SORGBR( 'Q', M, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_Q=DUM(1) + LWORK_SORGBR_Q = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*N+LWORK_SORGBR_Q ) END IF IF( WNTUA ) THEN CALL SORGBR( 'Q', M, M, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_Q=DUM(1) + LWORK_SORGBR_Q = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*N+LWORK_SORGBR_Q ) END IF IF( .NOT.WNTVN ) THEN @@ -475,24 +475,24 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, BDSPAC = 5*M * Compute space needed for SGELQF CALL SGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_SGELQF=DUM(1) + LWORK_SGELQF = INT( DUM(1) ) * Compute space needed for SORGLQ CALL SORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) - LWORK_SORGLQ_N=DUM(1) + LWORK_SORGLQ_N = INT( DUM(1) ) CALL SORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_SORGLQ_M=DUM(1) + LWORK_SORGLQ_M = INT( DUM(1) ) * Compute space needed for SGEBRD CALL SGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_SGEBRD=DUM(1) + LWORK_SGEBRD = INT( DUM(1) ) * Compute space needed for SORGBR P CALL SORGBR( 'P', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_P=DUM(1) + LWORK_SORGBR_P = INT( DUM(1) ) * Compute space needed for SORGBR Q CALL SORGBR( 'Q', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_Q=DUM(1) + LWORK_SORGBR_Q = INT( DUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * @@ -608,19 +608,19 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * CALL SGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) - LWORK_SGEBRD=DUM(1) + LWORK_SGEBRD = INT( DUM(1) ) MAXWRK = 3*M + LWORK_SGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for SORGBR P CALL SORGBR( 'P', M, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_P=DUM(1) + LWORK_SORGBR_P = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*M+LWORK_SORGBR_P ) END IF IF( WNTVA ) THEN CALL SORGBR( 'P', N, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) - LWORK_SORGBR_P=DUM(1) + LWORK_SORGBR_P = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*M+LWORK_SORGBR_P ) END IF IF( .NOT.WNTUN ) THEN @@ -693,7 +693,10 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R * - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), + $ LDA ) + END IF IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N @@ -1122,8 +1125,10 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N+2*N*NB) @@ -1285,8 +1290,10 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N+2*N*NB) @@ -1588,8 +1595,10 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N+2*N*NB) @@ -1756,8 +1765,10 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * * Zero out below R in A * - CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N+2*N*NB) diff --git a/lapack-netlib/SRC/sgesvdx.f b/lapack-netlib/SRC/sgesvdx.f index aae8b07640..24422fdae3 100644 --- a/lapack-netlib/SRC/sgesvdx.f +++ b/lapack-netlib/SRC/sgesvdx.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, -* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, +* SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, +* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, * $ LWORK, IWORK, INFO ) -* +* * * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT, RANGE @@ -33,7 +33,7 @@ * REAL A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -43,23 +43,23 @@ *> SGESVDX computes the singular value decomposition (SVD) of a real *> M-by-N matrix A, optionally computing the left and/or right singular *> vectors. The SVD is written -*> +*> *> A = U * SIGMA * transpose(V) -*> +*> *> where SIGMA is an M-by-N matrix which is zero except for its *> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and *> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA *> are the singular values of A; they are real and non-negative, and *> are returned in descending order. The first min(m,n) columns of *> U and V are the left and right singular vectors of A. -*> -*> SGESVDX uses an eigenvalue problem for obtaining the SVD, which -*> allows for the computation of a subset of singular values and +*> +*> SGESVDX uses an eigenvalue problem for obtaining the SVD, which +*> allows for the computation of a subset of singular values and *> vectors. See SBDSVDX for details. -*> +*> *> Note that the routine returns V**T, not V. *> \endverbatim -* +* * Arguments: * ========== * @@ -68,7 +68,7 @@ *> JOBU is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'V': the first min(m,n) columns of U (the left singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array U; *> = 'N': no columns of U (no left singular vectors) are *> computed. @@ -80,7 +80,7 @@ *> Specifies options for computing all or part of the matrix *> V**T: *> = 'V': the first min(m,n) rows of V**T (the right singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array VT; *> = 'N': no rows of V**T (no right singular vectors) are *> computed. @@ -92,7 +92,7 @@ *> = 'A': all singular values will be found. *> = 'V': all singular values in the half-open interval (VL,VU] *> will be found. -*> = 'I': the IL-th through IU-th singular values will be found. +*> = 'I': the IL-th through IU-th singular values will be found. *> \endverbatim *> *> \param[in] M @@ -123,13 +123,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL -*> VL >=0. +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -137,13 +139,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -151,7 +157,7 @@ *> \param[out] NS *> \verbatim *> NS is INTEGER -*> The total number of singular values found, +*> The total number of singular values found, *> 0 <= NS <= min(M,N). *> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1. *> \endverbatim @@ -165,11 +171,11 @@ *> \param[out] U *> \verbatim *> U is REAL array, dimension (LDU,UCOL) -*> If JOBU = 'V', U contains columns of U (the left singular -*> vectors, stored columnwise) as specified by RANGE; if +*> If JOBU = 'V', U contains columns of U (the left singular +*> vectors, stored columnwise) as specified by RANGE; if *> JOBU = 'N', U is not referenced. -*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', -*> the exact value of NS is not known ILQFin advance and an upper +*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -183,11 +189,11 @@ *> \param[out] VT *> \verbatim *> VT is REAL array, dimension (LDVT,N) -*> If JOBVT = 'V', VT contains the rows of V**T (the right singular -*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', +*> If JOBVT = 'V', VT contains the rows of V**T (the right singular +*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', *> VT is not referenced. -*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', -*> the exact value of NS is not known in advance and an upper +*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -208,9 +214,9 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see +*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see *> comments inside the code): -*> - PATH 1 (M much larger than N) +*> - PATH 1 (M much larger than N) *> - PATH 1t (N much larger than M) *> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths. *> For good performance, LWORK should generally be larger. @@ -224,8 +230,8 @@ *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (12*MIN(M,N)) -*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, -*> then IWORK contains the indices of the eigenvectors that failed +*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, +*> then IWORK contains the indices of the eigenvectors that failed *> to converge in SBDSVDX/SSTEVX. *> \endverbatim *> @@ -243,24 +249,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realGEsing * * ===================================================================== - SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, - $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, + SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, + $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT, RANGE @@ -283,7 +289,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CHARACTER JOBZ, RNGTGK LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL, - $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, + $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, $ J, MAXWRK, MINMN, MINWRK, MNTHR REAL ABSTOL, ANRM, BIGNUM, EPS, SMLNUM * .. @@ -293,13 +299,13 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * .. External Subroutines .. EXTERNAL SBDSVDX, SGEBRD, SGELQF, SGEQRF, SLACPY, $ SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, - $ SSCAL, XERBLA + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV - REAL SLAMCH, SLANGE, SNRM2 - EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE, SNRM2 + REAL SLAMCH, SLANGE + EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT @@ -357,8 +363,14 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( INFO.EQ.0 ) THEN IF( WANTU .AND. LDU.LT.M ) THEN INFO = -15 - ELSE IF( WANTVT .AND. LDVT.LT.MINMN ) THEN - INFO = -16 + ELSE IF( WANTVT ) THEN + IF( INDS ) THEN + IF( LDVT.LT.IU-IL+1 ) THEN + INFO = -17 + END IF + ELSE IF( LDVT.LT.MINMN ) THEN + INFO = -17 + END IF END IF END IF END IF @@ -380,18 +392,34 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1 (M much larger than N) * - MAXWRK = N*(N*2+16) + + MAXWRK = N + $ N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, N*(N*2+20) + 2*N* + MAXWRK = MAX( MAXWRK, N*(N+5) + 2*N* $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - MINWRK = N*(N*2+21) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'SORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*3+6)+N* + $ ILAENV( 1, 'SORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = N*(N*3+20) ELSE * * Path 2 (M at least N, but not much larger) * - MAXWRK = N*(N*2+19) + ( M+N )* + MAXWRK = 4*N + ( M+N )* $ ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) - MINWRK = N*(N*2+20) + M + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'SORMQR', ' ', N, N, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,N*(N*2+5)+N* + $ ILAENV( 1, 'SORMLQ', ' ', N, N, -1, -1 ) ) + END IF + MINWRK = MAX(N*(N*2+19),4*N+M) END IF ELSE MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 ) @@ -399,18 +427,34 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1t (N much larger than M) * - MAXWRK = M*(M*2+16) + + MAXWRK = M + $ M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*(M*2+20) + 2*M* + MAXWRK = MAX( MAXWRK, M*(M+5) + 2*M* $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - MINWRK = M*(M*2+21) + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'SORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*3+6)+M* + $ ILAENV( 1, 'SORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = M*(M*3+20) ELSE * -* Path 2t (N greater than M, but not much larger) +* Path 2t (N at least M, but not much larger) * - MAXWRK = M*(M*2+19) + ( M+N )* + MAXWRK = 4*M + ( M+N )* $ ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) - MINWRK = M*(M*2+20) + N + IF (WANTU) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'SORMQR', ' ', M, M, -1, -1 ) ) + END IF + IF (WANTVT) THEN + MAXWRK = MAX(MAXWRK,M*(M*2+5)+M* + $ ILAENV( 1, 'SORMLQ', ' ', M, M, -1, -1 ) ) + END IF + MINWRK = MAX(M*(M*2+19),4*M+N) END IF END IF END IF @@ -445,7 +489,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, RNGTGK = 'I' ILTGK = IL IUTGK = IU - ELSE + ELSE RNGTGK = 'V' ILTGK = 0 IUTGK = 0 @@ -489,7 +533,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAU + N CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) -* +* * Copy R into WORK and bidiagonalize it: * (Workspace: need N*N+5*N, prefer N*N+4*N+2*N*NB) * @@ -498,19 +542,19 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + N ITAUQ = IE + N ITAUP = ITAUQ + N - ITEMP = ITAUP + N + ITEMP = ITAUP + N CALL SLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IQRF+1 ), N ) - CALL SGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), + CALL SGEBRD( N, N, WORK( IQRF ), N, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 14*N + 2*N*(N+1)) -* +* (Workspace: need 14*N + 2*N*(N+1)) +* ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -522,23 +566,23 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL SLASET( 'A', M-N, N, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) * * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL SORMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL SORMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call SORMQR to compute Q*(QB*UB). * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL SORMQR( 'L', 'N', M, NS, N, A, LDA, + CALL SORMQR( 'L', 'N', M, NS, N, A, LDA, $ WORK( ITAU ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -551,7 +595,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call SORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL SORMBR( 'P', 'R', 'T', NS, N, N, WORK( IQRF ), N, + CALL SORMBR( 'P', 'R', 'T', NS, N, N, WORK( IQRF ), N, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) END IF @@ -569,17 +613,17 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + N ITAUQ = IE + N ITAUP = ITAUQ + N - ITEMP = ITAUP + N - CALL SGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + ITEMP = ITAUP + N + CALL SGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 14*N + 2*N*(N+1)) -* +* (Workspace: need 14*N + 2*N*(N+1)) +* ITGKZ = ITEMP ITEMP = ITGKZ + N*(N*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ N*2, WORK( ITEMP ), IWORK, INFO) * @@ -591,16 +635,16 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( N, WORK( J ), 1, U( 1,I ), 1 ) J = J + N*2 END DO - CALL SLASET( 'A', M-N, N, ZERO, ZERO, U( N+1,1 ), LDU ) + CALL SLASET( 'A', M-N, NS, ZERO, ZERO, U( N+1,1 ), LDU ) * * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) -* - CALL SORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), +* + CALL SORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -613,11 +657,11 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call SORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL SORMBR( 'P', 'R', 'T', NS, N, N, A, LDA, + CALL SORMBR( 'P', 'R', 'T', NS, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) END IF - END IF + END IF ELSE * * A has more columns than rows. If A has sufficiently more @@ -626,7 +670,7 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M): -* A = L * Q = ( QB * B * PB**T ) * Q +* A = L * Q = ( QB * B * PB**T ) * Q * = ( QB * ( UB * S * VB**T ) * PB**T ) * Q * U = QB * UB ; V**T = VB**T * PB**T * Q * @@ -649,16 +693,16 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAUP + M CALL SLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M ) - CALL SGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), + CALL SGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) * @@ -674,11 +718,11 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL SORMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL SORMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -687,28 +731,28 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL SLASET( 'A', M, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT ) + CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) * * Call SORMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL SORMBR( 'P', 'R', 'T', NS, M, M, WORK( ILQF ), M, + CALL SORMBR( 'P', 'R', 'T', NS, M, M, WORK( ILQF ), M, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call SORMLQ to compute ((VB**T)*(PB**T))*Q. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL SORMLQ( 'R', 'N', NS, N, M, A, LDA, + CALL SORMLQ( 'R', 'N', NS, N, M, A, LDA, $ WORK( ITAU ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF ELSE * * Path 2t (N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T -* U = QB * UB; V**T = VB**T * PB**T +* U = QB * UB; V**T = VB**T * PB**T * * Bidiagonalize A * (Workspace: need 4*M+N, prefer 4*M+(M+N)*NB) @@ -718,19 +762,19 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITAUQ = IE + M ITAUP = ITAUQ + M ITEMP = ITAUP + M - CALL SGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), + CALL SGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * ITGKZ = ITEMP ITEMP = ITGKZ + M*(M*2+1) - CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), + CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ), $ VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ), $ M*2, WORK( ITEMP ), IWORK, INFO) -* +* * If needed, compute left singular vectors. * IF( WANTU ) THEN @@ -743,11 +787,11 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call SORMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL SORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL SORMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -756,15 +800,15 @@ SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT ) J = J + M*2 END DO - CALL SLASET( 'A', M, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT ) + CALL SLASET( 'A', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT) * * Call SORMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL SORMBR( 'P', 'R', 'T', NS, N, M, A, LDA, + CALL SORMBR( 'P', 'R', 'T', NS, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF END IF END IF * diff --git a/lapack-netlib/SRC/sgesvj.f b/lapack-netlib/SRC/sgesvj.f index d3fc45270f..5e53cea106 100644 --- a/lapack-netlib/SRC/sgesvj.f +++ b/lapack-netlib/SRC/sgesvj.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESVJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESVJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * LDV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N * CHARACTER*1 JOBA, JOBU, JOBV @@ -29,7 +29,7 @@ * REAL A( LDA, * ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -208,7 +208,7 @@ *> *> \param[in,out] WORK *> \verbatim -*> WORK is REAL array, dimension max(4,M+N). +*> WORK is REAL array, dimension MAX(6,M+N). *> On entry, *> If JOBU .EQ. 'C' : *> WORK(1) = CTOL, where CTOL defines the threshold for convergence. @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -323,10 +323,10 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N @@ -925,7 +925,7 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ FASTR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*SQRT( MAX( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, ABS( T ) ) * @@ -1247,7 +1247,7 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, MXSINJ = MAX( MXSINJ, ABS( SN ) ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*SQRT( MAX( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = WORK( p ) / WORK( q ) @@ -1561,7 +1561,7 @@ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) + IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. $ ( SFMIN / SKL ) ) ) ) THEN DO 2400 p = 1, N diff --git a/lapack-netlib/SRC/sgesvx.f b/lapack-netlib/SRC/sgesvx.f index 67938a9e24..b297a36d6a 100644 --- a/lapack-netlib/SRC/sgesvx.f +++ b/lapack-netlib/SRC/sgesvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, * EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -335,10 +335,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -349,7 +349,7 @@ SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sgesvxx.f b/lapack-netlib/SRC/sgesvxx.f index bc53c7c7cf..281f198d5c 100644 --- a/lapack-netlib/SRC/sgesvxx.f +++ b/lapack-netlib/SRC/sgesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -527,10 +527,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -543,7 +543,7 @@ SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sgetc2.f b/lapack-netlib/SRC/sgetc2.f index 5984465195..b0301b9538 100644 --- a/lapack-netlib/SRC/sgetc2.f +++ b/lapack-netlib/SRC/sgetc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGETC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGETC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ), JPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup realGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/sgetf2.f b/lapack-netlib/SRC/sgetf2.f index 4b31027618..8d28a4a0cd 100644 --- a/lapack-netlib/SRC/sgetf2.f +++ b/lapack-netlib/SRC/sgetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -164,8 +164,8 @@ SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * -* Compute machine safe minimum -* +* Compute machine safe minimum +* SFMIN = SLAMCH('S') * DO 10 J = 1, MIN( M, N ) @@ -183,15 +183,15 @@ SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) * * Compute elements J+1:M of J-th column. * - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF * ELSE IF( INFO.EQ.0 ) THEN * diff --git a/lapack-netlib/SRC/sgetrf.f b/lapack-netlib/SRC/sgetrf.f index ec092331f9..9e13f0fcaa 100644 --- a/lapack-netlib/SRC/sgetrf.f +++ b/lapack-netlib/SRC/sgetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/sgetrf2.f b/lapack-netlib/SRC/sgetrf2.f index 068710b779..a7e778b9f1 100644 --- a/lapack-netlib/SRC/sgetrf2.f +++ b/lapack-netlib/SRC/sgetrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE SGETRF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -35,11 +35,11 @@ *> *> This is the recursive version of the algorithm. It divides *> the matrix into four submatrices: -*> +*> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = min(m,n) +*> A = [ -----|----- ] with n1 = min(m,n)/2 * [ A21 | A22 ] n2 = n-n1 -*> +*> *> [ A11 ] *> The subroutine calls itself to factor [ --- ], *> [ A12 ] @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realGEcomputational * * ===================================================================== RECURSIVE SUBROUTINE SGETRF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -239,12 +239,12 @@ RECURSIVE SUBROUTINE SGETRF2( M, N, A, LDA, IPIV, INFO ) * * Solve A12 * - CALL STRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + CALL STRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, $ A( 1, N1+1 ), LDA ) * * Update A22 * - CALL SGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + CALL SGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) * * Factor A22 diff --git a/lapack-netlib/SRC/sgetri.f b/lapack-netlib/SRC/sgetri.f index 15a837453f..e609247712 100644 --- a/lapack-netlib/SRC/sgetri.f +++ b/lapack-netlib/SRC/sgetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/sgetrs.f b/lapack-netlib/SRC/sgetrs.f index caa45670cd..d52f773d13 100644 --- a/lapack-netlib/SRC/sgetrs.f +++ b/lapack-netlib/SRC/sgetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgetsls.f b/lapack-netlib/SRC/sgetsls.f new file mode 100644 index 0000000000..b2312d6423 --- /dev/null +++ b/lapack-netlib/SRC/sgetsls.f @@ -0,0 +1,494 @@ +* Definition: +* =========== +* +* SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGETSLS solves overdetermined or underdetermined real linear systems +*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ +*> factorization of A. It is assumed that A has full rank. +*> +*> +*> +*> The following options are provided: +*> +*> 1. If TRANS = 'N' and m >= n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A*X ||. +*> +*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of +*> an underdetermined system A * X = B. +*> +*> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of +*> an undetermined system A**T * X = B. +*> +*> 4. If TRANS = 'T' and m < n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A**T * X ||. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'T': the linear system involves A**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> A is overwritten by details of its QR or LQ +*> factorization as returned by SGEQR or SGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the matrix B of right hand side vectors, stored +*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS +*> if TRANS = 'T'. +*> On exit, if INFO = 0, B is overwritten by the solution +*> vectors, stored columnwise: +*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least +*> squares solution vectors. +*> if TRANS = 'N' and m < n, rows 1 to N of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'T' and m >= n, rows 1 to M of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'T' and m < n, rows 1 to M of B contain the +*> least squares solution vectors. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of A is zero, so that A does not have +*> full rank; the least squares solution could not be +*> computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEsolve +* +* ===================================================================== + SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TRAN + INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, + $ SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2, + $ WSIZEO, WSIZEM, INFO2 + REAL ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANGE + EXTERNAL LSAME, ILAENV, SLABAD, SLAMCH, SLANGE +* .. +* .. External Subroutines .. + EXTERNAL SGEQR, SGEMQR, SLASCL, SLASET, + $ STRTRS, XERBLA, SGELQ, SGEMLQ +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN, INT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNK = MAX( MINMN, NRHS ) + TRAN = LSAME( TRANS, 'T' ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) + IF( .NOT.( LSAME( TRANS, 'N' ) .OR. + $ LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size and minimum LWORK +* + IF( M.GE.N ) THEN + CALL SGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL SGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL SGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL SGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZM, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + ELSE + CALL SGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL SGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL SGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL SGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + END IF +* + IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN + INFO = -10 + END IF +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGETSLS', -INFO ) + WORK( 1 ) = REAL( WSIZEO ) + RETURN + END IF + IF( LQUERY ) THEN + IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO ) + IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM ) + RETURN + END IF + IF( LWORK.LT.WSIZEO ) THEN + LW1 = TSZM + LW2 = LWM + ELSE + LW1 = TSZO + LW2 = LWO + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + CALL SLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO, + $ B, LDB ) + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL SLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max element outside range [SMLNUM,BIGNUM] +* + ANRM = SLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL SLASET( 'F', MAXMN, NRHS, ZERO, ZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF ( TRAN ) THEN + BROW = N + END IF + BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +* + IF ( M.GE.N ) THEN +* +* compute QR factorization of A +* + CALL SGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) + IF ( .NOT.TRAN ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) +* + CALL SGEMQR( 'L' , 'T', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL STRTRS( 'U', 'N', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) + IF( INFO.GT.0 ) THEN + RETURN + END IF + SCLLEN = N + ELSE +* +* Overdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) +* + CALL STRTRS( 'U', 'T', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(N+1:M,1:NRHS) = ZERO +* + DO 20 J = 1, NRHS + DO 10 I = N + 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* +* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) +* + CALL SGEMQR( 'L', 'N', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL SGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TRAN ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL STRTRS( 'L', 'N', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(M+1:N,1:NRHS) = 0 +* + DO 40 J = 1, NRHS + DO 30 I = M + 1, N + B( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS) +* + CALL SGEMLQ( 'L', 'T', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = N +* + ELSE +* +* overdetermined system min || A**T * X - B || +* +* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) +* + CALL SGEMLQ( 'L', 'N', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS) +* + CALL STRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = M +* + END IF +* + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF +* + 50 CONTINUE + WORK( 1 ) = REAL( TSZO + LWO ) + RETURN +* +* End of SGETSLS +* + END diff --git a/lapack-netlib/SRC/sggbak.f b/lapack-netlib/SRC/sggbak.f index f10895cb31..7e5620ee6d 100644 --- a/lapack-netlib/SRC/sggbak.f +++ b/lapack-netlib/SRC/sggbak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, * LDV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -147,10 +147,10 @@ SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/sggbal.f b/lapack-netlib/SRC/sggbal.f index 31b18e9286..3e64a0f762 100644 --- a/lapack-netlib/SRC/sggbal.f +++ b/lapack-netlib/SRC/sggbal.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, * RSCALE, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, LDB, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), B( LDB, * ), LSCALE( * ), * $ RSCALE( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -177,10 +177,10 @@ SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/sgges.f b/lapack-netlib/SRC/sgges.f index 2f686a2880..75f31c76f3 100644 --- a/lapack-netlib/SRC/sgges.f +++ b/lapack-netlib/SRC/sgges.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, * SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, * LDVSR, WORK, LWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM @@ -36,7 +36,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -270,12 +270,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEeigen * @@ -284,10 +284,10 @@ SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, $ LDVSR, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT @@ -577,13 +577,13 @@ SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IERR ) * -* Check if unscaling would cause over/underflow, if so, rescale -* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of +* Check if unscaling would cause over/underflow, if so, rescale +* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of * B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) * IF( ILASCL )THEN - DO 50 I = 1, N - IF( ALPHAI( I ).NE.ZERO ) THEN + DO 50 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( ALPHAR( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR. $ ( SAFMIN/ALPHAR( I ) ).GT.( ANRM/ANRMTO ) ) THEN WORK( 1 ) = ABS( A( I, I )/ALPHAR( I ) ) @@ -599,9 +599,9 @@ SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, END IF END IF 50 CONTINUE - END IF + END IF * - IF( ILBSCL )THEN + IF( ILBSCL )THEN DO 60 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I )/SAFMAX ).GT.( BNRMTO/BNRM ) .OR. @@ -610,10 +610,10 @@ SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) - END IF + END IF END IF - 60 CONTINUE - END IF + 60 CONTINUE + END IF * * Undo scaling * diff --git a/lapack-netlib/SRC/sggesx.f b/lapack-netlib/SRC/sggesx.f index 7a2b34df21..223256d55c 100644 --- a/lapack-netlib/SRC/sggesx.f +++ b/lapack-netlib/SRC/sggesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, * VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, * LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SENSE, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, @@ -40,7 +40,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -332,12 +332,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEeigen * @@ -365,10 +365,10 @@ SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, $ LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT @@ -718,17 +718,17 @@ SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, * (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of * B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) * - IF( ILASCL ) THEN - DO 20 I = 1, N + IF( ILASCL ) THEN + DO 20 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. - $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) + $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) - ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) + ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) $ .OR. ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) @@ -738,9 +738,9 @@ SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, END IF END IF 20 CONTINUE - END IF + END IF * - IF( ILBSCL ) THEN + IF( ILBSCL ) THEN DO 25 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. @@ -749,10 +749,10 @@ SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) - END IF - END IF + END IF + END IF 25 CONTINUE - END IF + END IF * * Undo scaling * diff --git a/lapack-netlib/SRC/sggev.f b/lapack-netlib/SRC/sggev.f index 51321a2393..8551eb08f1 100644 --- a/lapack-netlib/SRC/sggev.f +++ b/lapack-netlib/SRC/sggev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -30,7 +30,7 @@ * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,10 +213,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -226,7 +226,7 @@ SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sggevx.f b/lapack-netlib/SRC/sggevx.f index ad5b35696d..08f02251f2 100644 --- a/lapack-netlib/SRC/sggevx.f +++ b/lapack-netlib/SRC/sggevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, * IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, * RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -36,7 +36,7 @@ * $ RCONDE( * ), RCONDV( * ), RSCALE( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -347,10 +347,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -391,7 +391,7 @@ SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sggglm.f b/lapack-netlib/SRC/sggglm.f index bc3d5d0ffa..fe63da5f5e 100644 --- a/lapack-netlib/SRC/sggglm.f +++ b/lapack-netlib/SRC/sggglm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGGLM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGGLM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), * $ X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -185,10 +185,10 @@ SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -215,7 +215,7 @@ SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/sgghd3.f b/lapack-netlib/SRC/sgghd3.f index 3c58aea786..758f4b5c7d 100644 --- a/lapack-netlib/SRC/sgghd3.f +++ b/lapack-netlib/SRC/sgghd3.f @@ -230,7 +230,7 @@ SUBROUTINE SGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -277,7 +277,7 @@ SUBROUTINE SGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * INFO = 0 NB = ILAENV( 1, 'SGGHD3', ' ', N, ILO, IHI, -1 ) - LWKOPT = 6*N*NB + LWKOPT = MAX( 6*N*NB, 1 ) WORK( 1 ) = REAL( LWKOPT ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) diff --git a/lapack-netlib/SRC/sgghrd.f b/lapack-netlib/SRC/sgghrd.f index 9ff6e8fa8f..6580ab7713 100644 --- a/lapack-netlib/SRC/sgghrd.f +++ b/lapack-netlib/SRC/sgghrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ * INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -207,10 +207,10 @@ SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ diff --git a/lapack-netlib/SRC/sgglse.f b/lapack-netlib/SRC/sgglse.f index ce0bcfed39..20e319ce82 100644 --- a/lapack-netlib/SRC/sgglse.f +++ b/lapack-netlib/SRC/sgglse.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGLSE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGLSE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), B( LDB, * ), C( * ), D( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERsolve * @@ -180,10 +180,10 @@ SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -210,7 +210,7 @@ SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/sggqrf.f b/lapack-netlib/SRC/sggqrf.f index 31f99bdc29..bce1d5b9e6 100644 --- a/lapack-netlib/SRC/sggqrf.f +++ b/lapack-netlib/SRC/sggqrf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -215,10 +215,10 @@ SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -239,7 +239,7 @@ SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/sggrqf.f b/lapack-netlib/SRC/sggrqf.f index da2663534c..82a57b1705 100644 --- a/lapack-netlib/SRC/sggrqf.f +++ b/lapack-netlib/SRC/sggrqf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -214,10 +214,10 @@ SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -237,8 +237,8 @@ SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA * .. * .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV + INTEGER ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/sggsvd3.f b/lapack-netlib/SRC/sggsvd3.f index 3e7b114ee9..4f41fc3a85 100644 --- a/lapack-netlib/SRC/sggsvd3.f +++ b/lapack-netlib/SRC/sggsvd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGSVD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGSVD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -323,14 +323,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * -*> \ingroup realOTHERsing +*> \ingroup realGEsing * *> \par Contributors: * ================== @@ -349,7 +349,7 @@ SUBROUTINE SGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * August 2015 diff --git a/lapack-netlib/SRC/sggsvp3.f b/lapack-netlib/SRC/sggsvp3.f index f54962462b..ec7229a337 100644 --- a/lapack-netlib/SRC/sggsvp3.f +++ b/lapack-netlib/SRC/sggsvp3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGGSVP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGGSVP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. +*> numerical rank of the (M+P)-by-N matrix (A**T,B**T)**T. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -220,7 +220,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> WORK is REAL array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> @@ -245,10 +245,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -272,7 +272,7 @@ SUBROUTINE SGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * August 2015 diff --git a/lapack-netlib/SRC/sgsvj0.f b/lapack-netlib/SRC/sgsvj0.f index 4be9f9b936..690b03eb37 100644 --- a/lapack-netlib/SRC/sgsvj0.f +++ b/lapack-netlib/SRC/sgsvj0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGSVJ0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP * REAL EPS, SFMIN, TOL @@ -30,7 +30,7 @@ * REAL A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -188,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -218,10 +218,10 @@ SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP @@ -280,7 +280,7 @@ SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, INFO = -5 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN @@ -485,7 +485,7 @@ SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ FASTR ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*SQRT( MAX( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, ABS( T ) ) * @@ -800,7 +800,7 @@ SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, MXSINJ = MAX( MXSINJ, ABS( SN ) ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*SQRT( MAX( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) diff --git a/lapack-netlib/SRC/sgsvj1.f b/lapack-netlib/SRC/sgsvj1.f index a483f5da37..1005ee2b5c 100644 --- a/lapack-netlib/SRC/sgsvj1.f +++ b/lapack-netlib/SRC/sgsvj1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGSVJ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGSVJ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * REAL EPS, SFMIN, TOL * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP @@ -30,7 +30,7 @@ * REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -218,12 +218,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -236,10 +236,10 @@ SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL EPS, SFMIN, TOL @@ -300,7 +300,7 @@ SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, INFO = -6 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -9 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( TOL.LE.EPS ) THEN @@ -499,7 +499,7 @@ SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, MXSINJ = MAX( MXSINJ, ABS( SN ) ) SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) - AAPP = AAPP*SQRT( MAX( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) APOAQ = D( p ) / D( q ) diff --git a/lapack-netlib/SRC/sgtcon.f b/lapack-netlib/SRC/sgtcon.f index b6b33b1bad..e053265ed9 100644 --- a/lapack-netlib/SRC/sgtcon.f +++ b/lapack-netlib/SRC/sgtcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * REAL D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTcomputational * @@ -146,10 +146,10 @@ SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/sgtrfs.f b/lapack-netlib/SRC/sgtrfs.f index 4cc05bed72..8d60da87e5 100644 --- a/lapack-netlib/SRC/sgtrfs.f +++ b/lapack-netlib/SRC/sgtrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTcomputational * @@ -209,10 +209,10 @@ SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgtsv.f b/lapack-netlib/SRC/sgtsv.f index 3cd6c9bdd7..d18f9e5e3d 100644 --- a/lapack-netlib/SRC/sgtsv.f +++ b/lapack-netlib/SRC/sgtsv.f @@ -1,32 +1,32 @@ -*> \brief SGTSV computes the solution to system of linear equations A * X = B for GT matrices +*> \brief SGTSV computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * REAL B( LDB, * ), D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTsolve * * ===================================================================== SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/sgtsvx.f b/lapack-netlib/SRC/sgtsvx.f index 64d5459f98..4f00934c2e 100644 --- a/lapack-netlib/SRC/sgtsvx.f +++ b/lapack-netlib/SRC/sgtsvx.f @@ -1,19 +1,19 @@ -*> \brief SGTSVX computes the solution to system of linear equations A * X = B for GT matrices +*> \brief SGTSVX computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, * DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,12 +279,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTsolve * @@ -293,10 +293,10 @@ SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT, TRANS diff --git a/lapack-netlib/SRC/sgttrf.f b/lapack-netlib/SRC/sgttrf.f index 19bc9b2bd7..f9846dd85d 100644 --- a/lapack-netlib/SRC/sgttrf.f +++ b/lapack-netlib/SRC/sgttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTcomputational * * ===================================================================== SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/sgttrs.f b/lapack-netlib/SRC/sgttrs.f index 117839ba4d..4f302da7a1 100644 --- a/lapack-netlib/SRC/sgttrs.f +++ b/lapack-netlib/SRC/sgttrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTcomputational * @@ -138,10 +138,10 @@ SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sgtts2.f b/lapack-netlib/SRC/sgtts2.f index 31f12f9993..0cefb29e34 100644 --- a/lapack-netlib/SRC/sgtts2.f +++ b/lapack-netlib/SRC/sgtts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SGTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER ITRANS, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGTcomputational * * ===================================================================== SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ITRANS, LDB, N, NRHS diff --git a/lapack-netlib/SRC/shgeqz.f b/lapack-netlib/SRC/shgeqz.f index 254e65fcf7..34f6a8ce0d 100644 --- a/lapack-netlib/SRC/shgeqz.f +++ b/lapack-netlib/SRC/shgeqz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SHGEQZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SHGEQZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ, JOB * INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N @@ -31,7 +31,7 @@ * $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,9 +50,9 @@ *> *> If JOB='S', then the Hessenberg-triangular pair (H,T) is *> also reduced to generalized Schur form, -*> +*> *> H = Q*S*Z**T, T = Q*P*Z**T, -*> +*> *> where Q and Z are orthogonal matrices, P is an upper triangular *> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 *> diagonal blocks. @@ -75,7 +75,7 @@ *> generalized Schur factorization of (A,B): *> *> A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. -*> +*> *> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, *> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is *> complex and beta real. @@ -86,7 +86,7 @@ *> alternate form of the GNEP *> mu*A*y = B*y. *> Real eigenvalues can be read directly from the generalized Schur -*> form: +*> form: *> alpha = S(i,i), beta = P(i,i). *> *> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix @@ -101,7 +101,7 @@ *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; -*> = 'S': Compute eigenvalues and the Schur form. +*> = 'S': Compute eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ @@ -211,12 +211,12 @@ *> \param[in,out] Q *> \verbatim *> Q is REAL array, dimension (LDQ, N) -*> On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +*> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in *> the reduction of (A,B) to generalized Hessenberg form. -*> On exit, if COMPZ = 'I', the orthogonal matrix of left Schur -*> vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +*> On exit, if COMPQ = 'I', the orthogonal matrix of left Schur +*> vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix *> of left Schur vectors of (A,B). -*> Not referenced if COMPZ = 'N'. +*> Not referenced if COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ @@ -277,12 +277,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup realGEcomputational * @@ -304,10 +304,10 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB @@ -760,7 +760,7 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ S2, WR, WR2, WI ) * IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) ) - $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) + $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) $ - H( ILAST, ILAST ) ) ) THEN TEMP = WR WR = WR2 diff --git a/lapack-netlib/SRC/shsein.f b/lapack-netlib/SRC/shsein.f index ffae353e06..53a3327a13 100644 --- a/lapack-netlib/SRC/shsein.f +++ b/lapack-netlib/SRC/shsein.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SHSEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SHSEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, * VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, * IFAILR, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EIGSRC, INITV, SIDE * INTEGER INFO, LDH, LDVL, LDVR, M, MM, N @@ -32,7 +32,7 @@ * REAL H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -263,10 +263,10 @@ SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE diff --git a/lapack-netlib/SRC/shseqr.f b/lapack-netlib/SRC/shseqr.f index 1c1f8eca69..5654a4682c 100644 --- a/lapack-netlib/SRC/shseqr.f +++ b/lapack-netlib/SRC/shseqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SHSEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, * LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * CHARACTER COMPZ, JOB @@ -29,7 +29,7 @@ * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -228,12 +228,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -316,10 +316,10 @@ SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/sisnan.f b/lapack-netlib/SRC/sisnan.f index a746da53a9..05f597439e 100644 --- a/lapack-netlib/SRC/sisnan.f +++ b/lapack-netlib/SRC/sisnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION SISNAN( SIN ) -* +* * .. Scalar Arguments .. * REAL SIN * .. -* +* * *> \par Purpose: * ============= @@ -47,22 +47,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION SISNAN( SIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL SIN diff --git a/lapack-netlib/SRC/sla_gbamv.f b/lapack-netlib/SRC/sla_gbamv.f index 91de2d646c..0798bacd3b 100644 --- a/lapack-netlib/SRC/sla_gbamv.f +++ b/lapack-netlib/SRC/sla_gbamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GBAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GBAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, * INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -185,10 +185,10 @@ SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, $ INCX, BETA, Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/sla_gbrcond.f b/lapack-netlib/SRC/sla_gbrcond.f index 11700ac0fb..36aa93dc93 100644 --- a/lapack-netlib/SRC/sla_gbrcond.f +++ b/lapack-netlib/SRC/sla_gbrcond.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GBRCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GBRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, * IPIV, CMODE, C, INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE @@ -30,7 +30,7 @@ * REAL AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), * $ C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -168,10 +168,10 @@ REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, $ IPIV, CMODE, C, INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sla_gbrfsx_extended.f b/lapack-netlib/SRC/sla_gbrfsx_extended.f index 87d509c2e7..8262002bb9 100644 --- a/lapack-netlib/SRC/sla_gbrfsx_extended.f +++ b/lapack-netlib/SRC/sla_gbrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GBRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GBRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * ERR_BNDS_COMP, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, * $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -394,12 +394,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -412,10 +412,10 @@ SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, diff --git a/lapack-netlib/SRC/sla_gbrpvgrw.f b/lapack-netlib/SRC/sla_gbrpvgrw.f index b1177bad64..77e9f26b4e 100644 --- a/lapack-netlib/SRC/sla_gbrpvgrw.f +++ b/lapack-netlib/SRC/sla_gbrpvgrw.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GBRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GBRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, * LDAFB ) -* +* * .. Scalar Arguments .. * INTEGER N, KL, KU, NCOLS, LDAB, LDAFB * .. * .. Array Arguments .. * REAL AB( LDAB, * ), AFB( LDAFB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBcomputational * @@ -117,10 +117,10 @@ REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, $ LDAFB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, KL, KU, NCOLS, LDAB, LDAFB diff --git a/lapack-netlib/SRC/sla_geamv.f b/lapack-netlib/SRC/sla_geamv.f index e6f68cfd5e..35ce8b8047 100644 --- a/lapack-netlib/SRC/sla_geamv.f +++ b/lapack-netlib/SRC/sla_geamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, * Y, INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDA, M, N, TRANS @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -174,10 +174,10 @@ SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, $ Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/sla_gercond.f b/lapack-netlib/SRC/sla_gercond.f index e241cbdd2f..349a1b5bed 100644 --- a/lapack-netlib/SRC/sla_gercond.f +++ b/lapack-netlib/SRC/sla_gercond.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GERCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GERCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, * CMODE, C, INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDA, LDAF, INFO, CMODE @@ -30,7 +30,7 @@ * REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), * $ C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -150,10 +150,10 @@ REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, $ CMODE, C, INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/sla_gerfsx_extended.f b/lapack-netlib/SRC/sla_gerfsx_extended.f index e09b3172f3..1795ea9757 100644 --- a/lapack-netlib/SRC/sla_gerfsx_extended.f +++ b/lapack-netlib/SRC/sla_gerfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ TRANS_TYPE, N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERRS_N( NRHS, * ), * $ ERRS_C( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -398,10 +398,10 @@ SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/sla_gerpvgrw.f b/lapack-netlib/SRC/sla_gerpvgrw.f index 042cff222a..a41a0351ee 100644 --- a/lapack-netlib/SRC/sla_gerpvgrw.f +++ b/lapack-netlib/SRC/sla_gerpvgrw.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_GERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_GERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) -* +* * .. Scalar Arguments .. * INTEGER N, NCOLS, LDA, LDAF * .. * .. Array Arguments .. * REAL A( LDA, * ), AF( LDAF, * ) * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * * ===================================================================== REAL FUNCTION SLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NCOLS, LDA, LDAF diff --git a/lapack-netlib/SRC/sla_lin_berr.f b/lapack-netlib/SRC/sla_lin_berr.f index 7f7a35595d..2da50cbdab 100644 --- a/lapack-netlib/SRC/sla_lin_berr.f +++ b/lapack-netlib/SRC/sla_lin_berr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_LIN_BERR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_LIN_BERR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) -* +* * .. Scalar Arguments .. * INTEGER N, NZ, NRHS * .. @@ -27,7 +27,7 @@ * REAL AYB( N, NRHS ), BERR( NRHS ) * REAL RES( N, NRHS ) * .. -* +* * *> \par Purpose: * ============= @@ -79,7 +79,7 @@ *> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B *> are from iterative refinement (see sla_gerfsx_extended.f). *> \endverbatim -*> +*> *> \param[out] BERR *> \verbatim *> BERR is REAL array, dimension (NRHS) @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NZ, NRHS diff --git a/lapack-netlib/SRC/sla_porcond.f b/lapack-netlib/SRC/sla_porcond.f index f59008651f..9dd7c587be 100644 --- a/lapack-netlib/SRC/sla_porcond.f +++ b/lapack-netlib/SRC/sla_porcond.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_PORCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_PORCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, * INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO, CMODE @@ -30,7 +30,7 @@ * .. Array Arguments .. * INTEGER IWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPOcomputational * @@ -140,10 +140,10 @@ REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, $ INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -167,8 +167,7 @@ REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ISAMAX - EXTERNAL LSAME, ISAMAX + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLACN2, SPOTRS, XERBLA diff --git a/lapack-netlib/SRC/sla_porfsx_extended.f b/lapack-netlib/SRC/sla_porfsx_extended.f index 8d0ab25f18..27baa20d1b 100644 --- a/lapack-netlib/SRC/sla_porfsx_extended.f +++ b/lapack-netlib/SRC/sla_porfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_PORFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_PORFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -369,12 +369,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPOcomputational * @@ -387,10 +387,10 @@ SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/sla_porpvgrw.f b/lapack-netlib/SRC/sla_porpvgrw.f index a6623c342e..c824d772d1 100644 --- a/lapack-netlib/SRC/sla_porpvgrw.f +++ b/lapack-netlib/SRC/sla_porpvgrw.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_PORPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_PORPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER NCOLS, LDA, LDAF @@ -27,14 +27,14 @@ * .. Array Arguments .. * REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> SLA_PORPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -128,7 +128,7 @@ REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) INTRINSIC ABS, MAX, MIN * .. * .. External Functions .. - EXTERNAL LSAME, SLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/sla_syamv.f b/lapack-netlib/SRC/sla_syamv.f index 5d44221706..962e17ac20 100644 --- a/lapack-netlib/SRC/sla_syamv.f +++ b/lapack-netlib/SRC/sla_syamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_SYAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_SYAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER INCX, INCY, LDA, N, UPLO @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -177,10 +177,10 @@ SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/sla_syrcond.f b/lapack-netlib/SRC/sla_syrcond.f index a815ad9a7f..c4b204cc66 100644 --- a/lapack-netlib/SRC/sla_syrcond.f +++ b/lapack-netlib/SRC/sla_syrcond.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_SYRCOND + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_SYRCOND + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, * C, INFO, WORK, IWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO, CMODE @@ -29,7 +29,7 @@ * INTEGER IWORK( * ), IPIV( * ) * REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -146,10 +146,10 @@ REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, $ C, INFO, WORK, IWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -173,12 +173,11 @@ REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ISAMAX REAL SLAMCH - EXTERNAL LSAME, ISAMAX, SLAMCH + EXTERNAL LSAME, SLAMCH * .. * .. External Subroutines .. - EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS + EXTERNAL SLACN2, XERBLA, SSYTRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX diff --git a/lapack-netlib/SRC/sla_syrfsx_extended.f b/lapack-netlib/SRC/sla_syrfsx_extended.f index 0e98017fba..f7b909ac0b 100644 --- a/lapack-netlib/SRC/sla_syrfsx_extended.f +++ b/lapack-netlib/SRC/sla_syrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_SYRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_SYRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,14 +41,14 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> SLA_SYRFSX_EXTENDED improves the computed solution to a system of *> linear equations by performing extra-precise iterative refinement *> and provides error bounds and backward error estimates for the solution. @@ -378,12 +378,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -396,10 +396,10 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, @@ -542,7 +542,7 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, CALL BLAS_SSYMV2_X(UPLO2, N, -1.0, A, LDA, $ Y(1, J), Y_TAIL, 1, 1.0, RES, 1, PREC_TYPE) END IF - + ! XXX: RES is no longer needed. CALL SCOPY( N, RES, 1, DY, 1 ) CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, DY, N, INFO ) @@ -554,11 +554,11 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, NORMDX = 0.0 DZ_Z = 0.0 YMIN = HUGEVAL - + DO I = 1, N YK = ABS( Y( I, J ) ) DYK = ABS( DY( I ) ) - + IF ( YK .NE. 0.0 ) THEN DZ_Z = MAX( DZ_Z, DYK / YK ) ELSE IF ( DYK .NE. 0.0 ) THEN @@ -657,7 +657,7 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, ELSE CALL SLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) END IF - + END DO * Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. 666 CONTINUE @@ -687,7 +687,7 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, * op(A) = A, A**T, or A**H depending on TRANS (and type). CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) CALL SSYMV( UPLO, N, -1.0, A, LDA, Y(1,J), 1, 1.0, RES, 1 ) - + DO I = 1, N AYB( I ) = ABS( B( I, J ) ) END DO @@ -696,7 +696,7 @@ SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, * CALL SLA_SYAMV( UPLO2, N, 1.0, $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) - + CALL SLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) * * End of loop for each RHS. diff --git a/lapack-netlib/SRC/sla_syrpvgrw.f b/lapack-netlib/SRC/sla_syrpvgrw.f index 21da411a7c..f5eb81b1fc 100644 --- a/lapack-netlib/SRC/sla_syrpvgrw.f +++ b/lapack-netlib/SRC/sla_syrpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_SYRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_SYRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -29,14 +29,14 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> SLA_SYRPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -122,10 +122,10 @@ REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, $ WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -147,7 +147,7 @@ REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, INTRINSIC ABS, MAX, MIN * .. * .. External Functions .. - EXTERNAL LSAME, SLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/sla_wwaddw.f b/lapack-netlib/SRC/sla_wwaddw.f index 081beb4422..96a7d3542e 100644 --- a/lapack-netlib/SRC/sla_wwaddw.f +++ b/lapack-netlib/SRC/sla_wwaddw.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLA_WWADDW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLA_WWADDW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLA_WWADDW( N, X, Y, W ) -* +* * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * REAL X( * ), Y( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -69,22 +69,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SLA_WWADDW( N, X, Y, W ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/SRC/slabad.f b/lapack-netlib/SRC/slabad.f index 5bf653009b..d6502bb921 100644 --- a/lapack-netlib/SRC/slabad.f +++ b/lapack-netlib/SRC/slabad.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLABAD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLABAD( SMALL, LARGE ) -* +* * .. Scalar Arguments .. * REAL LARGE, SMALL * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL LARGE, SMALL diff --git a/lapack-netlib/SRC/slabrd.f b/lapack-netlib/SRC/slabrd.f index 5006eac3fd..8073d0031a 100644 --- a/lapack-netlib/SRC/slabrd.f +++ b/lapack-netlib/SRC/slabrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. @@ -28,7 +28,7 @@ * REAL A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -210,10 +210,10 @@ SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB diff --git a/lapack-netlib/SRC/slacn2.f b/lapack-netlib/SRC/slacn2.f index 73c993e71c..78742812f1 100644 --- a/lapack-netlib/SRC/slacn2.f +++ b/lapack-netlib/SRC/slacn2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST @@ -28,7 +28,7 @@ * INTEGER ISGN( * ), ISAVE( 3 ) * REAL V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> EST is REAL *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to SLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/slacon.f b/lapack-netlib/SRC/slacon.f index 0493e069c3..45c28d50ab 100644 --- a/lapack-netlib/SRC/slacon.f +++ b/lapack-netlib/SRC/slacon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLACON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLACON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * REAL EST @@ -28,7 +28,7 @@ * INTEGER ISGN( * ) * REAL V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> EST is REAL *> On entry with KASE = 1 or 2 and JUMP = 3, EST should be *> unchanged from the previous call to SLACON. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -115,10 +115,10 @@ * ===================================================================== SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/slacpy.f b/lapack-netlib/SRC/slacpy.f index fa19989f4c..a4bcde3cc8 100644 --- a/lapack-netlib/SRC/slacpy.f +++ b/lapack-netlib/SRC/slacpy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sladiv.f b/lapack-netlib/SRC/sladiv.f index 6d26da20c2..a9a3603aae 100644 --- a/lapack-netlib/SRC/sladiv.f +++ b/lapack-netlib/SRC/sladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLADIV( A, B, C, D, P, Q ) -* +* * .. Scalar Arguments .. * REAL A, B, C, D, P, Q * .. -* +* * *> \par Purpose: * ============= @@ -79,19 +79,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date January 2013 * -*> \ingroup auxOTHERauxiliary +*> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 @@ -132,12 +132,12 @@ SUBROUTINE SLADIV( A, B, C, D, P, Q ) AB = MAX( ABS(A), ABS(B) ) CD = MAX( ABS(C), ABS(D) ) S = 1.0E0 - + OV = SLAMCH( 'Overflow threshold' ) UN = SLAMCH( 'Safe minimum' ) EPS = SLAMCH( 'Epsilon' ) BE = BS / (EPS*EPS) - + IF( AB >= HALF*OV ) THEN AA = HALF * AA BB = HALF * BB @@ -173,11 +173,12 @@ SUBROUTINE SLADIV( A, B, C, D, P, Q ) * END - +*> \ingroup realOTHERauxiliary + SUBROUTINE SLADIV1( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 @@ -213,9 +214,11 @@ SUBROUTINE SLADIV1( A, B, C, D, P, Q ) * END +*> \ingroup realOTHERauxiliary + REAL FUNCTION SLADIV2( A, B, C, D, R, T ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * January 2013 diff --git a/lapack-netlib/SRC/slae2.f b/lapack-netlib/SRC/slae2.f index 313436c1fa..2b7a28c8f2 100644 --- a/lapack-netlib/SRC/slae2.f +++ b/lapack-netlib/SRC/slae2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAE2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAE2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) -* +* * .. Scalar Arguments .. * REAL A, B, C, RT1, RT2 * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -102,10 +102,10 @@ * ===================================================================== SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL A, B, C, RT1, RT2 diff --git a/lapack-netlib/SRC/slaebz.f b/lapack-netlib/SRC/slaebz.f index 57064875af..5e230827da 100644 --- a/lapack-netlib/SRC/slaebz.f +++ b/lapack-netlib/SRC/slaebz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAEBZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, * RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, * NAB, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX * REAL ABSTOL, PIVMIN, RELTOL @@ -31,7 +31,7 @@ * REAL AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -268,14 +268,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -319,10 +319,10 @@ SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX diff --git a/lapack-netlib/SRC/slaed0.f b/lapack-netlib/SRC/slaed0.f index b05f18ecad..51aea744c3 100644 --- a/lapack-netlib/SRC/slaed0.f +++ b/lapack-netlib/SRC/slaed0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ * .. @@ -29,7 +29,7 @@ * REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -172,10 +172,10 @@ SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ diff --git a/lapack-netlib/SRC/slaed1.f b/lapack-netlib/SRC/slaed1.f index 74eeb6330b..d40cb026aa 100644 --- a/lapack-netlib/SRC/slaed1.f +++ b/lapack-netlib/SRC/slaed1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, INFO, LDQ, N * REAL RHO @@ -29,7 +29,7 @@ * INTEGER INDXQ( * ), IWORK( * ) * REAL D( * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -54,7 +54,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine SLAED2. *> @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, INFO, LDQ, N diff --git a/lapack-netlib/SRC/slaed2.f b/lapack-netlib/SRC/slaed2.f index 897eb4c543..b039a31053 100644 --- a/lapack-netlib/SRC/slaed2.f +++ b/lapack-netlib/SRC/slaed2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * REAL RHO @@ -31,7 +31,7 @@ * REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -212,10 +212,10 @@ SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 @@ -520,7 +520,7 @@ SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * into the last N - K slots of D and Q respectively. * IF( K.LT.N ) THEN - CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, + CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, $ Q( 1, K+1 ), LDQ ) CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) END IF diff --git a/lapack-netlib/SRC/slaed3.f b/lapack-netlib/SRC/slaed3.f index 334fcb27d8..3ff991d891 100644 --- a/lapack-netlib/SRC/slaed3.f +++ b/lapack-netlib/SRC/slaed3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, * CTOT, W, S, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, N, N1 * REAL RHO @@ -30,7 +30,7 @@ * REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), * $ S( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -185,10 +185,10 @@ SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, N, N1 diff --git a/lapack-netlib/SRC/slaed4.f b/lapack-netlib/SRC/slaed4.f index 6330c854a6..c65cba75a2 100644 --- a/lapack-netlib/SRC/slaed4.f +++ b/lapack-netlib/SRC/slaed4.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER I, INFO, N * REAL DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), DELTA( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N diff --git a/lapack-netlib/SRC/slaed5.f b/lapack-netlib/SRC/slaed5.f index d5573b4ce7..29551daa72 100644 --- a/lapack-netlib/SRC/slaed5.f +++ b/lapack-netlib/SRC/slaed5.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM ) -* +* * .. Scalar Arguments .. * INTEGER I * REAL DLAM, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( 2 ), DELTA( 2 ), Z( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -108,10 +108,10 @@ * ===================================================================== SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I diff --git a/lapack-netlib/SRC/slaed6.f b/lapack-netlib/SRC/slaed6.f index 96ab9de335..69b94d4974 100644 --- a/lapack-netlib/SRC/slaed6.f +++ b/lapack-netlib/SRC/slaed6.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL ORGATI * INTEGER INFO, KNITER @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL D( 3 ), Z( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL ORGATI @@ -175,7 +175,7 @@ SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) INTEGER I, ITER, NITER REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, - $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, $ LBD, UBD * .. * .. Intrinsic Functions .. @@ -195,7 +195,7 @@ SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) IF( FINIT .LT. ZERO )THEN LBD = ZERO ELSE - UBD = ZERO + UBD = ZERO END IF * NITER = 1 @@ -363,7 +363,7 @@ SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * TAU = TAU + ETA IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD + UBD )/TWO + $ TAU = ( LBD + UBD )/TWO * FC = ZERO ERRETM = ZERO diff --git a/lapack-netlib/SRC/slaed7.f b/lapack-netlib/SRC/slaed7.f index 3d3d629286..55e6e6325c 100644 --- a/lapack-netlib/SRC/slaed7.f +++ b/lapack-netlib/SRC/slaed7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, * PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, * $ QSIZ, TLVLS @@ -34,7 +34,7 @@ * REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ), * $ QSTORE( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine SLAED8. *> @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -260,10 +260,10 @@ SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, diff --git a/lapack-netlib/SRC/slaed8.f b/lapack-netlib/SRC/slaed8.f index c9446d2e6a..5ec117cb50 100644 --- a/lapack-netlib/SRC/slaed8.f +++ b/lapack-netlib/SRC/slaed8.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, * CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, * GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, * $ QSIZ @@ -33,7 +33,7 @@ * REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ), * $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -243,10 +243,10 @@ SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, @@ -308,8 +308,8 @@ SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, END IF * * Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 diff --git a/lapack-netlib/SRC/slaed9.f b/lapack-netlib/SRC/slaed9.f index 7828434ef2..780d265506 100644 --- a/lapack-netlib/SRC/slaed9.f +++ b/lapack-netlib/SRC/slaed9.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAED9 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAED9 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, * S, LDS, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N * REAL RHO @@ -29,7 +29,7 @@ * REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), * $ W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -156,10 +156,10 @@ SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N diff --git a/lapack-netlib/SRC/slaeda.f b/lapack-netlib/SRC/slaeda.f index 70d1aa22d9..30d7a2bf0e 100644 --- a/lapack-netlib/SRC/slaeda.f +++ b/lapack-netlib/SRC/slaeda.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAEDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAEDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, * GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, INFO, N, TLVLS * .. @@ -29,7 +29,7 @@ * $ PRMPTR( * ), QPTR( * ) * REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -166,10 +166,10 @@ SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, INFO, N, TLVLS diff --git a/lapack-netlib/SRC/slaein.f b/lapack-netlib/SRC/slaein.f index 8c8ed6fb51..e9defea2a8 100644 --- a/lapack-netlib/SRC/slaein.f +++ b/lapack-netlib/SRC/slaein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, * LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL NOINIT, RIGHTV * INTEGER INFO, LDB, LDH, N @@ -30,7 +30,7 @@ * REAL B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -172,10 +172,10 @@ SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL NOINIT, RIGHTV diff --git a/lapack-netlib/SRC/slaev2.f b/lapack-netlib/SRC/slaev2.f index f6b81caa2b..f4028e11b7 100644 --- a/lapack-netlib/SRC/slaev2.f +++ b/lapack-netlib/SRC/slaev2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* +* * .. Scalar Arguments .. * REAL A, B, C, CS1, RT1, RT2, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -89,14 +89,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -120,10 +120,10 @@ * ===================================================================== SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL A, B, C, CS1, RT1, RT2, SN1 diff --git a/lapack-netlib/SRC/slaexc.f b/lapack-netlib/SRC/slaexc.f index db479cdc4a..7e3c6c4839 100644 --- a/lapack-netlib/SRC/slaexc.f +++ b/lapack-netlib/SRC/slaexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, * INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ * INTEGER INFO, J1, LDQ, LDT, N, N1, N2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -138,10 +138,10 @@ SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ diff --git a/lapack-netlib/SRC/slag2.f b/lapack-netlib/SRC/slag2.f index ad04333a08..ac16fb1b5a 100644 --- a/lapack-netlib/SRC/slag2.f +++ b/lapack-netlib/SRC/slag2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAG2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAG2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, * WR2, WI ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB * REAL SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,7 +99,7 @@ *> will always be positive. If the eigenvalues are real, then *> the first (real) eigenvalue is WR1 / SCALE1 , but this may *> overflow or underflow, and in fact, SCALE1 may be zero or -*> less than the underflow threshhold if the exact eigenvalue +*> less than the underflow threshold if the exact eigenvalue *> is sufficiently large. *> \endverbatim *> @@ -112,7 +112,7 @@ *> eigenvalues are real, then the second (real) eigenvalue is *> WR2 / SCALE2 , but this may overflow or underflow, and in *> fact, SCALE2 may be zero or less than the underflow -*> threshhold if the exact eigenvalue is sufficiently large. +*> threshold if the exact eigenvalue is sufficiently large. *> \endverbatim *> *> \param[out] WR1 @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realOTHERauxiliary * @@ -156,10 +156,10 @@ SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB @@ -266,8 +266,8 @@ SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, * Note: the test of R in the following IF is to cover the case when * DISCR is small and negative and is flushed to zero during * the calculation of R. On machines which have a consistent -* flush-to-zero threshhold and handle numbers above that -* threshhold correctly, it would not be necessary. +* flush-to-zero threshold and handle numbers above that +* threshold correctly, it would not be necessary. * IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN SUM = PP + SIGN( R, PP ) diff --git a/lapack-netlib/SRC/slag2d.f b/lapack-netlib/SRC/slag2d.f index e515fa6351..01515eb672 100644 --- a/lapack-netlib/SRC/slag2d.f +++ b/lapack-netlib/SRC/slag2d.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAG2D + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAG2D + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. @@ -27,7 +27,7 @@ * REAL SA( LDSA, * ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDSA, M, N diff --git a/lapack-netlib/SRC/slags2.f b/lapack-netlib/SRC/slags2.f index a78c00d825..4076f39827 100644 --- a/lapack-netlib/SRC/slags2.f +++ b/lapack-netlib/SRC/slags2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, * SNV, CSQ, SNQ ) -* +* * .. Scalar Arguments .. * LOGICAL UPPER * REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, * $ SNU, SNV * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -152,10 +152,10 @@ SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL UPPER diff --git a/lapack-netlib/SRC/slagtf.f b/lapack-netlib/SRC/slagtf.f index a2f2e6d9c7..d3f0b6813f 100644 --- a/lapack-netlib/SRC/slagtf.f +++ b/lapack-netlib/SRC/slagtf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAGTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAGTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * REAL LAMBDA, TOL @@ -28,7 +28,7 @@ * INTEGER IN( * ) * REAL A( * ), B( * ), C( * ), D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,22 +144,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/slagtm.f b/lapack-netlib/SRC/slagtm.f index 41f4ace95c..e423dc91cd 100644 --- a/lapack-netlib/SRC/slagtm.f +++ b/lapack-netlib/SRC/slagtm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAGTM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAGTM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -145,10 +145,10 @@ SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/slagts.f b/lapack-netlib/SRC/slagts.f index 7d579b8502..0c3c5239f0 100644 --- a/lapack-netlib/SRC/slagts.f +++ b/lapack-netlib/SRC/slagts.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAGTS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAGTS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, JOB, N * REAL TOL @@ -28,7 +28,7 @@ * INTEGER IN( * ) * REAL A( * ), B( * ), C( * ), D( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,22 +149,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, JOB, N diff --git a/lapack-netlib/SRC/slagv2.f b/lapack-netlib/SRC/slagv2.f index cbdf00cc97..638c7dfbc2 100644 --- a/lapack-netlib/SRC/slagv2.f +++ b/lapack-netlib/SRC/slagv2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAGV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAGV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, * CSR, SNR ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB * REAL CSL, CSR, SNL, SNR @@ -29,7 +29,7 @@ * REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), * $ B( LDB, * ), BETA( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -157,10 +157,10 @@ SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB diff --git a/lapack-netlib/SRC/slahqr.f b/lapack-netlib/SRC/slahqr.f index 7783da0247..d91826e61f 100644 --- a/lapack-netlib/SRC/slahqr.f +++ b/lapack-netlib/SRC/slahqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAHQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -178,12 +178,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -207,10 +207,10 @@ SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N @@ -292,7 +292,7 @@ SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * * ITMAX is the total number of QR iterations allowed. * - ITMAX = 30 * MAX( 10, NH ) + ITMAX = 30 * MAX( 10, NH ) * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works diff --git a/lapack-netlib/SRC/slahr2.f b/lapack-netlib/SRC/slahr2.f index c0b72dd6ab..656d679898 100644 --- a/lapack-netlib/SRC/slahr2.f +++ b/lapack-netlib/SRC/slahr2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAHR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * REAL A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -198,7 +198,7 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Parameters .. REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E+0, + PARAMETER ( ZERO = 0.0E+0, $ ONE = 1.0E+0 ) * .. * .. Local Scalars .. @@ -240,31 +240,31 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * w := V1**T * b1 * CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL STRMV( 'Lower', 'Transpose', 'UNIT', + CALL STRMV( 'Lower', 'Transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**T * b2 * - CALL SGEMV( 'Transpose', N-K-I+1, I-1, + CALL SGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**T * w * - CALL STRMV( 'Upper', 'Transpose', 'NON-UNIT', + CALL STRMV( 'Upper', 'Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * - CALL SGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + CALL SGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * - CALL STRMV( 'Lower', 'NO TRANSPOSE', + CALL STRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL SAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) @@ -282,13 +282,13 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Compute Y(K+1:N,I) * - CALL SGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + CALL SGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL SGEMV( 'Transpose', N-K-I+1, I-1, + CALL SGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL SSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) @@ -296,7 +296,7 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute T(1:I,I) * CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL STRMV( 'Upper', 'No Transpose', 'NON-UNIT', + CALL STRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) @@ -307,15 +307,15 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute Y(1:K,1:NB) * CALL SLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL STRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + CALL STRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) - $ CALL SGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ CALL SGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) - CALL STRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + CALL STRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * diff --git a/lapack-netlib/SRC/slaic1.f b/lapack-netlib/SRC/slaic1.f index edbfcdf305..44ab4b0384 100644 --- a/lapack-netlib/SRC/slaic1.f +++ b/lapack-netlib/SRC/slaic1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAIC1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAIC1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) -* +* * .. Scalar Arguments .. * INTEGER J, JOB * REAL C, GAMMA, S, SEST, SESTPR @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL W( J ), X( J ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER J, JOB diff --git a/lapack-netlib/SRC/slaisnan.f b/lapack-netlib/SRC/slaisnan.f index 0cf4117d85..32f723d550 100644 --- a/lapack-netlib/SRC/slaisnan.f +++ b/lapack-netlib/SRC/slaisnan.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) -* +* * .. Scalar Arguments .. * REAL SIN1, SIN2 * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL SIN1, SIN2 diff --git a/lapack-netlib/SRC/slaln2.f b/lapack-netlib/SRC/slaln2.f index 14468c0c80..f9ceee7b72 100644 --- a/lapack-netlib/SRC/slaln2.f +++ b/lapack-netlib/SRC/slaln2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLALN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLALN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, * LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LTRANS * INTEGER INFO, LDA, LDB, LDX, NA, NW @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,7 +127,7 @@ *> \param[in] D2 *> \verbatim *> D2 is REAL -*> The 2,2 element in the diagonal matrix D. Not used if NW=1. +*> The 2,2 element in the diagonal matrix D. Not used if NA=1. *> \endverbatim *> *> \param[in] B @@ -205,12 +205,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -218,10 +218,10 @@ SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL LTRANS diff --git a/lapack-netlib/SRC/slals0.f b/lapack-netlib/SRC/slals0.f index 869a3b64a8..bb1c2d7c98 100644 --- a/lapack-netlib/SRC/slals0.f +++ b/lapack-netlib/SRC/slals0.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLALS0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, * $ LDGNUM, NL, NR, NRHS, SQRE @@ -33,7 +33,7 @@ * $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), * $ POLES( LDGNUM, * ), WORK( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -247,12 +247,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -268,10 +268,10 @@ SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, diff --git a/lapack-netlib/SRC/slalsa.f b/lapack-netlib/SRC/slalsa.f index ad225d0240..65707a15bb 100644 --- a/lapack-netlib/SRC/slalsa.f +++ b/lapack-netlib/SRC/slalsa.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLALSA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, * GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, * $ SMLSIZ @@ -36,7 +36,7 @@ * $ U( LDU, * ), VT( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -247,12 +247,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -269,10 +269,10 @@ SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, diff --git a/lapack-netlib/SRC/slalsd.f b/lapack-netlib/SRC/slalsd.f index fe1f0c5815..a669660795 100644 --- a/lapack-netlib/SRC/slalsd.f +++ b/lapack-netlib/SRC/slalsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLALSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, * RANK, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL B( LDB, * ), D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/slamrg.f b/lapack-netlib/SRC/slamrg.f index 6229abd6a8..649d2c54e3 100644 --- a/lapack-netlib/SRC/slamrg.f +++ b/lapack-netlib/SRC/slamrg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAMRG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAMRG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX ) -* +* * .. Scalar Arguments .. * INTEGER N1, N2, STRD1, STRD2 * .. @@ -27,7 +27,7 @@ * INTEGER INDEX( * ) * REAL A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> \param[in] N2 *> \verbatim *> N2 is INTEGER -*> These arguements contain the respective lengths of the two +*> These arguments contain the respective lengths of the two *> sorted lists to be merged. *> \endverbatim *> @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER N1, N2, STRD1, STRD2 diff --git a/lapack-netlib/SRC/slamswlq.f b/lapack-netlib/SRC/slamswlq.f new file mode 100644 index 0000000000..ccdddbb3d4 --- /dev/null +++ b/lapack-netlib/SRC/slamswlq.f @@ -0,0 +1,416 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMQRTS overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product of blocked +*> elementary reflectors computed by short wide LQ +*> factorization (DLASWLQ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> M >= K >= 0; +*> +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > M. +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the blocked +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DLASWLQ in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension +*> ( M * Number of blocks(CEIL(N-K/NB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,NB) * MB; +*> if SIDE = 'R', LWORK >= max(1,M) * MB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL STPMLQT, SGEMLQT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * MB + ELSE + LW = M * MB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, MB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAMSWLQ', -INFO ) + WORK(1) = LW + RETURN + ELSE IF (LQUERY) THEN + WORK(1) = LW + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN + CALL DGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(NB-K)) + CTR = (M-K)/(NB-K) +* + IF (KK.GT.0) THEN + II=M-KK+1 + CALL STPMLQT('L','T',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+NB) +* + CTR = CTR - 1 + CALL STPMLQT('L','T',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + END DO +* +* Multiply Q to the first block of C (1:M,1:NB) +* + CALL SGEMLQT('L','T',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(NB-K)) + II=M-KK+1 + CTR = 1 + CALL SGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (I:I+NB,1:N) +* + CALL STPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR * K+1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL STPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(NB-K)) + CTR = (N-K)/(NB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL STPMLQT('R','N',M , KK, K, 0, MB, A(1, II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL STPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL SGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(NB-K)) + II=N-KK+1 + CTR = 1 + CALL SGEMLQT('R','T',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL STPMLQT('R','T',M , NB-K, K, 0,MB, A(1,I), LDA, + $ T(1, CTR*K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL STPMLQT('R','T',M , KK, K, 0,MB, A(1,II), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of SLAMSWLQ +* + END diff --git a/lapack-netlib/SRC/slamtsqr.f b/lapack-netlib/SRC/slamtsqr.f new file mode 100644 index 0000000000..747481da97 --- /dev/null +++ b/lapack-netlib/SRC/slamtsqr.f @@ -0,0 +1,415 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* DOUBLE A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAMTSQR overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (DLATSQR) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> N >= K >= 0; +*> +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > N. (must be the same as DLATSQR) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> blockedelementary reflector H(i), for i = 1,2,...,k, as +*> returned by DLATSQR in the first k columns of +*> its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension +*> ( N * Number of blocks(CEIL(M-K/MB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If SIDE = 'L', LWORK >= max(1,N)*NB; +*> if SIDE = 'R', LWORK >= max(1,MB)*NB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL SGEMQRT, STPMQRT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'T' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * NB + ELSE + LW = MB * NB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, NB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* +* Determine the block size if it is tall skinny or short and wide +* + IF( INFO.EQ.0) THEN + WORK(1) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAMTSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN + CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(MB-K)) + CTR = (M-K)/(MB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL STPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA, + $ T(1,CTR*K+1),LDT , C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CTR = CTR - 1 + CALL STPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:MB,1:N) +* + CALL SGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(MB-K)) + II=M-KK+1 + CTR = 1 + CALL SGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CALL STPMQRT('L','T',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL STPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(MB-K)) + CTR = (N-K)/(MB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL STPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL STPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) +* + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL SGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(MB-K)) + II=N-KK+1 + CTR = 1 + CALL SGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL STPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL STPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of SLAMTSQR +* + END diff --git a/lapack-netlib/SRC/slaneg.f b/lapack-netlib/SRC/slaneg.f index f17068c38b..dcb11df1f7 100644 --- a/lapack-netlib/SRC/slaneg.f +++ b/lapack-netlib/SRC/slaneg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANEG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANEG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R ) -* +* * .. Scalar Arguments .. * INTEGER N, R * REAL PIVMIN, SIGMA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), LLD( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,14 +99,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -118,10 +118,10 @@ * ===================================================================== INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, R diff --git a/lapack-netlib/SRC/slangb.f b/lapack-netlib/SRC/slangb.f index 27c6fe6433..fd538b1b70 100644 --- a/lapack-netlib/SRC/slangb.f +++ b/lapack-netlib/SRC/slangb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER KL, KU, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBauxiliary * @@ -124,10 +124,10 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -169,7 +169,7 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, VALUE = ZERO DO 20 J = 1, N DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) - TEMP = ABS( AB( I, J ) ) + TEMP = ABS( AB( I, J ) ) IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 10 CONTINUE 20 CONTINUE diff --git a/lapack-netlib/SRC/slange.f b/lapack-netlib/SRC/slange.f index f2fe0e4bf9..2eb8d7d140 100644 --- a/lapack-netlib/SRC/slange.f +++ b/lapack-netlib/SRC/slange.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEauxiliary * * ===================================================================== REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -158,7 +158,7 @@ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M - TEMP = ABS( A( I, J ) ) + TEMP = ABS( A( I, J ) ) IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 10 CONTINUE 20 CONTINUE diff --git a/lapack-netlib/SRC/slangt.f b/lapack-netlib/SRC/slangt.f index 150eb9780f..6f3202131d 100644 --- a/lapack-netlib/SRC/slangt.f +++ b/lapack-netlib/SRC/slangt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANGT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANGT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -149,11 +149,11 @@ REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 - IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) + IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) $ ANORM = ABS(DL(I)) - IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) + IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) $ ANORM = ABS(D(I)) - IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) + IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) $ ANORM = ABS(DU(I)) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN @@ -164,7 +164,7 @@ REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) - TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) + TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP DO 20 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) diff --git a/lapack-netlib/SRC/slanhs.f b/lapack-netlib/SRC/slanhs.f index fe166cf72e..c5a077fbf1 100644 --- a/lapack-netlib/SRC/slanhs.f +++ b/lapack-netlib/SRC/slanhs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANHS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANHS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/slansb.f b/lapack-netlib/SRC/slansb.f index e36182472d..8f3fe1eb95 100644 --- a/lapack-netlib/SRC/slansb.f +++ b/lapack-netlib/SRC/slansb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -129,10 +129,10 @@ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/slansf.f b/lapack-netlib/SRC/slansf.f index 5c3cdacb0b..eab99a9c47 100644 --- a/lapack-netlib/SRC/slansf.f +++ b/lapack-netlib/SRC/slansf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANSF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANSF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, TRANSR, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( 0: * ), WORK( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -209,10 +209,10 @@ * ===================================================================== REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, TRANSR, UPLO @@ -300,7 +300,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, K - 1 DO I = 0, N - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -309,7 +309,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, N - 1 DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -321,7 +321,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, K - 1 DO I = 0, N TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -330,7 +330,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) DO J = 0, N DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO @@ -380,7 +380,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -422,7 +422,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF @@ -460,7 +460,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -498,7 +498,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF @@ -564,7 +564,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE @@ -629,7 +629,7 @@ REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF diff --git a/lapack-netlib/SRC/slansp.f b/lapack-netlib/SRC/slansp.f index 67c7fd757e..35390cd1ca 100644 --- a/lapack-netlib/SRC/slansp.f +++ b/lapack-netlib/SRC/slansp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO @@ -196,7 +196,7 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) 60 CONTINUE DO 70 I = 1, N SUM = WORK( I ) - IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 70 CONTINUE ELSE DO 80 I = 1, N @@ -211,7 +211,7 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE - IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN diff --git a/lapack-netlib/SRC/slanst.f b/lapack-netlib/SRC/slanst.f index 56db9969dc..4b589bac94 100644 --- a/lapack-netlib/SRC/slanst.f +++ b/lapack-netlib/SRC/slanst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANST( NORM, N, D, E ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,22 +88,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/slansy.f b/lapack-netlib/SRC/slansy.f index f03d721488..c8400e5308 100644 --- a/lapack-netlib/SRC/slansy.f +++ b/lapack-netlib/SRC/slansy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYauxiliary * * ===================================================================== REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/slantb.f b/lapack-netlib/SRC/slantb.f index 9d87539f47..3588779cb6 100644 --- a/lapack-netlib/SRC/slantb.f +++ b/lapack-netlib/SRC/slantb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANTB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANTB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, * LDAB, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER K, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -140,10 +140,10 @@ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/slantp.f b/lapack-netlib/SRC/slantp.f index 129d7a6dce..1423f5ca36 100644 --- a/lapack-netlib/SRC/slantp.f +++ b/lapack-netlib/SRC/slantp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/slantr.f b/lapack-netlib/SRC/slantr.f index 50c896d9bb..63b8558926 100644 --- a/lapack-netlib/SRC/slantr.f +++ b/lapack-netlib/SRC/slantr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -141,10 +141,10 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/slanv2.f b/lapack-netlib/SRC/slanv2.f index e535e20df3..e73e5455c1 100644 --- a/lapack-netlib/SRC/slanv2.f +++ b/lapack-netlib/SRC/slanv2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLANV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLANV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) -* +* * .. Scalar Arguments .. * REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN diff --git a/lapack-netlib/SRC/slapll.f b/lapack-netlib/SRC/slapll.f index 05a4607aa7..498fe85333 100644 --- a/lapack-netlib/SRC/slapll.f +++ b/lapack-netlib/SRC/slapll.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAPLL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAPLL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * REAL SSMIN @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/slapmr.f b/lapack-netlib/SRC/slapmr.f index e496f63030..0473cd3f95 100644 --- a/lapack-netlib/SRC/slapmr.f +++ b/lapack-netlib/SRC/slapmr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAPMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAPMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * REAL X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/slapmt.f b/lapack-netlib/SRC/slapmt.f index c55c1bc30e..67e8aabe18 100644 --- a/lapack-netlib/SRC/slapmt.f +++ b/lapack-netlib/SRC/slapmt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAPMT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAPMT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * REAL X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/slapy2.f b/lapack-netlib/SRC/slapy2.f index 85f502bd1d..13e21981ac 100644 --- a/lapack-netlib/SRC/slapy2.f +++ b/lapack-netlib/SRC/slapy2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAPY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLAPY2( X, Y ) -* +* * .. Scalar Arguments .. * REAL X, Y * .. -* +* * *> \par Purpose: * ============= @@ -51,22 +51,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL X, Y diff --git a/lapack-netlib/SRC/slapy3.f b/lapack-netlib/SRC/slapy3.f index 34bf5e15e5..04a847f997 100644 --- a/lapack-netlib/SRC/slapy3.f +++ b/lapack-netlib/SRC/slapy3.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAPY3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * REAL FUNCTION SLAPY3( X, Y, Z ) -* +* * .. Scalar Arguments .. * REAL X, Y, Z * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== REAL FUNCTION SLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL X, Y, Z diff --git a/lapack-netlib/SRC/slaqgb.f b/lapack-netlib/SRC/slaqgb.f index 5346166ec1..633befa312 100644 --- a/lapack-netlib/SRC/slaqgb.f +++ b/lapack-netlib/SRC/slaqgb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER KL, KU, LDAB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGBauxiliary * @@ -159,10 +159,10 @@ SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/slaqge.f b/lapack-netlib/SRC/slaqge.f index d3fd5c6d2d..0622ff6c45 100644 --- a/lapack-netlib/SRC/slaqge.f +++ b/lapack-netlib/SRC/slaqge.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER LDA, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( * ), R( * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realGEauxiliary * @@ -142,10 +142,10 @@ SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/slaqp2.f b/lapack-netlib/SRC/slaqp2.f index 2aa54b2546..e99324b7ca 100644 --- a/lapack-netlib/SRC/slaqp2.f +++ b/lapack-netlib/SRC/slaqp2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. @@ -29,7 +29,7 @@ * REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -67,9 +67,9 @@ *> \verbatim *> A is REAL array, dimension (LDA,N) *> On entry, the M-by-N matrix A. -*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is -*> the triangular factor obtained; the elements in block -*> A(OFFSET+1:M,1:N) below the diagonal, together with the +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> the triangular factor obtained; the elements in block +*> A(OFFSET+1:M,1:N) below the diagonal, together with the *> array TAU, represent the orthogonal matrix Q as a product of *> elementary reflectors. Block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -142,17 +142,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET diff --git a/lapack-netlib/SRC/slaqps.f b/lapack-netlib/SRC/slaqps.f index 7983147cb1..9c62ec8b6b 100644 --- a/lapack-netlib/SRC/slaqps.f +++ b/lapack-netlib/SRC/slaqps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, * VN2, AUXV, F, LDF ) -* +* * .. Scalar Arguments .. * INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. @@ -29,7 +29,7 @@ * REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), * $ VN1( * ), VN2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -171,17 +171,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET @@ -343,9 +343,9 @@ SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = SNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * -* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) +* SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP diff --git a/lapack-netlib/SRC/slaqr0.f b/lapack-netlib/SRC/slaqr0.f index 80dfb6075d..1dcd3d1765 100644 --- a/lapack-netlib/SRC/slaqr0.f +++ b/lapack-netlib/SRC/slaqr0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -29,7 +29,7 @@ * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -225,12 +225,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -256,10 +256,10 @@ SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/slaqr1.f b/lapack-netlib/SRC/slaqr1.f index 336d545da1..7e35b804ad 100644 --- a/lapack-netlib/SRC/slaqr1.f +++ b/lapack-netlib/SRC/slaqr1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) -* +* * .. Scalar Arguments .. * REAL SI1, SI2, SR1, SR2 * INTEGER LDH, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL SI1, SI2, SR1, SR2 diff --git a/lapack-netlib/SRC/slaqr2.f b/lapack-netlib/SRC/slaqr2.f index 6b9775b3a1..1bcb138c26 100644 --- a/lapack-netlib/SRC/slaqr2.f +++ b/lapack-netlib/SRC/slaqr2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -32,7 +32,7 @@ * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,7 +141,7 @@ *> Z is REAL array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -258,12 +258,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -278,10 +278,10 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/slaqr3.f b/lapack-netlib/SRC/slaqr3.f index 150febd433..2fabacf4ae 100644 --- a/lapack-netlib/SRC/slaqr3.f +++ b/lapack-netlib/SRC/slaqr3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -32,7 +32,7 @@ * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,7 +138,7 @@ *> Z is REAL array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realOTHERauxiliary * @@ -275,10 +275,10 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/slaqr4.f b/lapack-netlib/SRC/slaqr4.f index f918a9c404..12b6b2fb16 100644 --- a/lapack-netlib/SRC/slaqr4.f +++ b/lapack-netlib/SRC/slaqr4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -29,7 +29,7 @@ * REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -234,12 +234,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -265,10 +265,10 @@ SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/slaqr5.f b/lapack-netlib/SRC/slaqr5.f index 6a29974178..ea3910a5d3 100644 --- a/lapack-netlib/SRC/slaqr5.f +++ b/lapack-netlib/SRC/slaqr5.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQR5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, * LDU, NV, WV, LDWV, NH, WH, LDWH ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, * $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV @@ -32,7 +32,7 @@ * $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,10 +150,10 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is REAL array of size (LDZ,IHI) +*> Z is REAL array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep orthogonal *> similarity transformation is accumulated into -*> Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -231,12 +231,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realOTHERauxiliary * @@ -259,10 +259,10 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, $ LDU, NV, WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, diff --git a/lapack-netlib/SRC/slaqsb.f b/lapack-netlib/SRC/slaqsb.f index 42a117f224..747d32df8e 100644 --- a/lapack-netlib/SRC/slaqsb.f +++ b/lapack-netlib/SRC/slaqsb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,22 +128,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/slaqsp.f b/lapack-netlib/SRC/slaqsp.f index ac5842e9bd..a88206dd8e 100644 --- a/lapack-netlib/SRC/slaqsp.f +++ b/lapack-netlib/SRC/slaqsp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AP( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,22 +113,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/slaqsy.f b/lapack-netlib/SRC/slaqsy.f index 86d21d71f5..fc66aae320 100644 --- a/lapack-netlib/SRC/slaqsy.f +++ b/lapack-netlib/SRC/slaqsy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,22 +121,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYauxiliary * * ===================================================================== SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/slaqtr.f b/lapack-netlib/SRC/slaqtr.f index e2dc607edd..9d3e592f8f 100644 --- a/lapack-netlib/SRC/slaqtr.f +++ b/lapack-netlib/SRC/slaqtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAQTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAQTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, * INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LREAL, LTRAN * INTEGER INFO, LDT, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL B( * ), T( LDT, * ), WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -165,10 +165,10 @@ SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL LREAL, LTRAN diff --git a/lapack-netlib/SRC/slar1v.f b/lapack-netlib/SRC/slar1v.f index d813f68c46..d2423287c5 100644 --- a/lapack-netlib/SRC/slar1v.f +++ b/lapack-netlib/SRC/slar1v.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAR1V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAR1V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, * PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, * R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) -* +* * .. Scalar Arguments .. * LOGICAL WANTNC * INTEGER B1, BN, N, NEGCNT, R @@ -34,7 +34,7 @@ * $ WORK( * ) * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -207,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -230,10 +230,10 @@ SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTNC diff --git a/lapack-netlib/SRC/slar2v.f b/lapack-netlib/SRC/slar2v.f index 20c119bbfa..583f2e689e 100644 --- a/lapack-netlib/SRC/slar2v.f +++ b/lapack-netlib/SRC/slar2v.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAR2V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAR2V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, N * .. * .. Array Arguments .. * REAL C( * ), S( * ), X( * ), Y( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, N diff --git a/lapack-netlib/SRC/slarf.f b/lapack-netlib/SRC/slarf.f index 2747561e6d..d66c7bf397 100644 --- a/lapack-netlib/SRC/slarf.f +++ b/lapack-netlib/SRC/slarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/slarfb.f b/lapack-netlib/SRC/slarfb.f index 78b121d245..c51f695343 100644 --- a/lapack-netlib/SRC/slarfb.f +++ b/lapack-netlib/SRC/slarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, * T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,10 +154,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date June 2013 * @@ -195,7 +195,7 @@ SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * June 2013 diff --git a/lapack-netlib/SRC/slarfg.f b/lapack-netlib/SRC/slarfg.f index d44f8b1734..638b9ab8f0 100644 --- a/lapack-netlib/SRC/slarfg.f +++ b/lapack-netlib/SRC/slarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/slarfgp.f b/lapack-netlib/SRC/slarfgp.f index 82b575f5c0..59038dfcea 100644 --- a/lapack-netlib/SRC/slarfgp.f +++ b/lapack-netlib/SRC/slarfgp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARFGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARFGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N @@ -203,7 +203,7 @@ SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU ) IF ( ABS(TAU).LE.SMLNUM ) THEN * * In the case where the computed TAU ends up being a denormalized number, -* it loses relative accuracy. This is a BIG problem. Solution: flush TAU +* it loses relative accuracy. This is a BIG problem. Solution: flush TAU * to ZERO. This explains the next IF statement. * * (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) @@ -219,7 +219,7 @@ SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU ) BETA = -SAVEALPHA END IF * - ELSE + ELSE * * This is the general case. * diff --git a/lapack-netlib/SRC/slarft.f b/lapack-netlib/SRC/slarft.f index bc3521d157..05ee8b2efc 100644 --- a/lapack-netlib/SRC/slarft.f +++ b/lapack-netlib/SRC/slarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -221,7 +221,7 @@ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) @@ -236,13 +236,13 @@ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T * CALL SGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, + $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, $ ONE, T( 1, I ), 1 ) END IF * @@ -280,7 +280,7 @@ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) @@ -295,7 +295,7 @@ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T diff --git a/lapack-netlib/SRC/slarfx.f b/lapack-netlib/SRC/slarfx.f index c4bb71bf50..590e99e707 100644 --- a/lapack-netlib/SRC/slarfx.f +++ b/lapack-netlib/SRC/slarfx.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARFX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/slarfy.f b/lapack-netlib/SRC/slarfy.f new file mode 100644 index 0000000000..340c544130 --- /dev/null +++ b/lapack-netlib/SRC/slarfy.f @@ -0,0 +1,161 @@ +*> \brief \b SLARFY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* REAL TAU +* .. +* .. Array Arguments .. +* REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLARFY applies an elementary reflector, or Householder matrix, H, +*> to an n x n symmetric matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER INCV, LDC, N + REAL TAU +* .. +* .. Array Arguments .. + REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO, HALF + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + REAL ALPHA +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SSYMV, SSYR2 +* .. +* .. External Functions .. + REAL SDOT + EXTERNAL SDOT +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL SSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*SDOT( N, WORK, 1, V, INCV ) + CALL SAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL SSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of SLARFY +* + END diff --git a/lapack-netlib/SRC/slargv.f b/lapack-netlib/SRC/slargv.f index a587e083fa..694eccc49a 100644 --- a/lapack-netlib/SRC/slargv.f +++ b/lapack-netlib/SRC/slargv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * REAL C( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/slarnv.f b/lapack-netlib/SRC/slarnv.f index eede7fc63f..44fdeb93b6 100644 --- a/lapack-netlib/SRC/slarnv.f +++ b/lapack-netlib/SRC/slarnv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARNV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARNV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARNV( IDIST, ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * REAL X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,14 +74,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -97,10 +97,10 @@ * ===================================================================== SUBROUTINE SLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, N diff --git a/lapack-netlib/SRC/slarra.f b/lapack-netlib/SRC/slarra.f index ffc7c40fea..fd248c9d6a 100644 --- a/lapack-netlib/SRC/slarra.f +++ b/lapack-netlib/SRC/slarra.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, * NSPLIT, ISPLIT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N, NSPLIT * REAL SPLTOL, TNRM @@ -29,7 +29,7 @@ * INTEGER ISPLIT( * ) * REAL D( * ), E( * ), E2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,14 +114,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -136,10 +136,10 @@ SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, $ NSPLIT, ISPLIT, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N, NSPLIT diff --git a/lapack-netlib/SRC/slarrb.f b/lapack-netlib/SRC/slarrb.f index d39c32d2de..c2d130b5ef 100644 --- a/lapack-netlib/SRC/slarrb.f +++ b/lapack-netlib/SRC/slarrb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, * RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, * PIVMIN, SPDIAM, TWIST, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST * REAL PIVMIN, RTOL1, RTOL2, SPDIAM @@ -31,7 +31,7 @@ * REAL D( * ), LLD( * ), W( * ), * $ WERR( * ), WGAP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,7 +107,7 @@ *> \verbatim *> W is REAL array, dimension (N) *> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are -*> estimates of the eigenvalues of L D L^T indexed IFIRST throug +*> estimates of the eigenvalues of L D L^T indexed IFIRST through *> ILAST. *> On output, these estimates are refined. *> \endverbatim @@ -173,14 +173,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -196,10 +196,10 @@ SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, TWIST, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST diff --git a/lapack-netlib/SRC/slarrc.f b/lapack-netlib/SRC/slarrc.f index 7812ca5537..8469660a20 100644 --- a/lapack-netlib/SRC/slarrc.f +++ b/lapack-netlib/SRC/slarrc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, * EIGCNT, LCNT, RCNT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBT * INTEGER EIGCNT, INFO, LCNT, N, RCNT @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,25 +59,26 @@ *> *> \param[in] VL *> \verbatim -*> VL is DOUBLE PRECISION +*> VL is REAL +*> The lower bound for the eigenvalues. *> \endverbatim *> *> \param[in] VU *> \verbatim -*> VU is DOUBLE PRECISION -*> The lower and upper bounds for the eigenvalues. +*> VU is REAL +*> The upper bound for the eigenvalues. *> \endverbatim *> *> \param[in] D *> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) +*> D is REAL array, dimension (N) *> JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. *> JOBT = 'L': The N diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] E *> \verbatim -*> E is DOUBLE PRECISION array, dimension (N) +*> E is REAL array, dimension (N) *> JOBT = 'T': The N-1 offdiagonal elements of the matrix T. *> JOBT = 'L': The N-1 offdiagonal elements of the matrix L. *> \endverbatim @@ -114,14 +115,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -136,10 +137,10 @@ SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, $ EIGCNT, LCNT, RCNT, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBT diff --git a/lapack-netlib/SRC/slarrd.f b/lapack-netlib/SRC/slarrd.f index 7d17210c33..8da31a999b 100644 --- a/lapack-netlib/SRC/slarrd.f +++ b/lapack-netlib/SRC/slarrd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, * M, W, WERR, WL, WU, IBLOCK, INDEXW, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -34,7 +34,7 @@ * REAL D( * ), E( * ), E2( * ), * $ GERS( * ), W( * ), WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,16 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. @@ -106,13 +110,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -306,14 +314,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, @@ -321,10 +329,10 @@ SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, $ M, W, WERR, WL, WU, IBLOCK, INDEXW, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE diff --git a/lapack-netlib/SRC/slarre.f b/lapack-netlib/SRC/slarre.f index a5b9f2fd69..3c1b511363 100644 --- a/lapack-netlib/SRC/slarre.f +++ b/lapack-netlib/SRC/slarre.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, * W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -34,7 +34,7 @@ * REAL D( * ), E( * ), E2( * ), GERS( * ), * $ W( * ),WERR( * ), WGAP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,17 @@ *> \param[in,out] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound for the eigenvalues. +*> Eigenvalues less than or equal to VL, or greater than VU, +*> will not be returned. VL < VU. +*> If RANGE='I' or ='A', SLARRE computes bounds on the desired +*> part of the spectrum. *> \endverbatim *> *> \param[in,out] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds for the eigenvalues. +*> If RANGE='V', the upper bound for the eigenvalues. *> Eigenvalues less than or equal to VL, or greater than VU, *> will not be returned. VL < VU. *> If RANGE='I' or ='A', SLARRE computes bounds on the desired @@ -93,13 +98,16 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N. *> \endverbatim *> @@ -244,7 +252,7 @@ *> \verbatim *> INFO is INTEGER *> = 0: successful exit -*> > 0: A problem occured in SLARRE. +*> > 0: A problem occurred in SLARRE. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -263,14 +271,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -297,10 +305,10 @@ SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER RANGE diff --git a/lapack-netlib/SRC/slarrf.f b/lapack-netlib/SRC/slarrf.f index 058e5027c2..ee8af8c2ab 100644 --- a/lapack-netlib/SRC/slarrf.f +++ b/lapack-netlib/SRC/slarrf.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * W, WGAP, WERR, * SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, * DPLUS, LPLUS, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CLSTRT, CLEND, INFO, N * REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM @@ -31,7 +31,7 @@ * REAL D( * ), DPLUS( * ), L( * ), LD( * ), * $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -51,7 +51,7 @@ *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix (subblock, if the matrix splitted). +*> The order of the matrix (subblock, if the matrix split). *> \endverbatim *> *> \param[in] D @@ -169,14 +169,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -193,10 +193,10 @@ SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, $ DPLUS, LPLUS, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER CLSTRT, CLEND, INFO, N diff --git a/lapack-netlib/SRC/slarrj.f b/lapack-netlib/SRC/slarrj.f index 5b7abcf47e..6ce15164dc 100644 --- a/lapack-netlib/SRC/slarrj.f +++ b/lapack-netlib/SRC/slarrj.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, * RTOL, OFFSET, W, WERR, WORK, IWORK, * PIVMIN, SPDIAM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET * REAL PIVMIN, RTOL, SPDIAM @@ -31,7 +31,7 @@ * REAL D( * ), E2( * ), W( * ), * $ WERR( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,14 +145,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -168,10 +168,10 @@ SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, $ RTOL, OFFSET, W, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET diff --git a/lapack-netlib/SRC/slarrk.f b/lapack-netlib/SRC/slarrk.f index 66dd09184b..4d625c5ed9 100644 --- a/lapack-netlib/SRC/slarrk.f +++ b/lapack-netlib/SRC/slarrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARRK( N, IW, GL, GU, * D, E2, PIVMIN, RELTOL, W, WERR, INFO) -* +* * .. Scalar Arguments .. * INTEGER INFO, IW, N * REAL PIVMIN, RELTOL, GL, GU, W, WERR @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL D( * ), E2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,23 +132,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLARRK( N, IW, GL, GU, $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, IW, N diff --git a/lapack-netlib/SRC/slarrr.f b/lapack-netlib/SRC/slarrr.f index 5e2230d1a7..e4181ea5e9 100644 --- a/lapack-netlib/SRC/slarrr.f +++ b/lapack-netlib/SRC/slarrr.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARRR( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER N, INFO * .. * .. Array Arguments .. * REAL D( * ), E( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -94,10 +94,10 @@ * ===================================================================== SUBROUTINE SLARRR( N, D, E, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, INFO diff --git a/lapack-netlib/SRC/slarrv.f b/lapack-netlib/SRC/slarrv.f index 73847f3942..e574da5167 100644 --- a/lapack-netlib/SRC/slarrv.f +++ b/lapack-netlib/SRC/slarrv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARRV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARRV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RTOL1, RTOL2, W, WERR, WGAP, * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER DOL, DOU, INFO, LDZ, M, N * REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU @@ -35,7 +35,7 @@ * $ WGAP( * ), WORK( * ) * REAL Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,12 +59,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> Lower bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> Lower and upper bounds of the interval that contains the desired +*> Upper bound of the interval that contains the desired *> eigenvalues. VL < VU. Needed to compute gaps on the left or right *> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim @@ -81,7 +84,7 @@ *> L is REAL array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the unit *> bidiagonal matrix L are in elements 1 to N-1 of L -*> (if the matrix is not splitted.) At the end of each block +*> (if the matrix is not split.) At the end of each block *> is stored the corresponding shift as given by SLARRE. *> On exit, L is overwritten. *> \endverbatim @@ -236,7 +239,7 @@ *> INFO is INTEGER *> = 0: successful exit *> -*> > 0: A problem occured in SLARRV. +*> > 0: A problem occurred in SLARRV. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -258,12 +261,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHERauxiliary * @@ -283,10 +286,10 @@ SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER DOL, DOU, INFO, LDZ, M, N diff --git a/lapack-netlib/SRC/slarscl2.f b/lapack-netlib/SRC/slarscl2.f index df7ede2c8b..5f57d33718 100644 --- a/lapack-netlib/SRC/slarscl2.f +++ b/lapack-netlib/SRC/slarscl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARSCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARSCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARSCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * REAL D( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,28 +72,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SLARSCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/slartg.f b/lapack-netlib/SRC/slartg.f index fd7d9dd1e8..784d4bc365 100644 --- a/lapack-netlib/SRC/slartg.f +++ b/lapack-netlib/SRC/slartg.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * REAL CS, F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL CS, F, G, R, SN diff --git a/lapack-netlib/SRC/slartgp.f b/lapack-netlib/SRC/slartgp.f index bd518bc4b4..ad76c94b4c 100644 --- a/lapack-netlib/SRC/slartgp.f +++ b/lapack-netlib/SRC/slartgp.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARTGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARTGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARTGP( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * REAL CS, F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLARTGP( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL CS, F, G, R, SN diff --git a/lapack-netlib/SRC/slartgs.f b/lapack-netlib/SRC/slartgs.f index 2d39413170..fbff9c0e65 100644 --- a/lapack-netlib/SRC/slartgs.f +++ b/lapack-netlib/SRC/slartgs.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARTGS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARTGS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN ) -* +* * .. Scalar Arguments .. * REAL CS, SIGMA, SN, X, Y * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL CS, SIGMA, SN, X, Y diff --git a/lapack-netlib/SRC/slartv.f b/lapack-netlib/SRC/slartv.f index 5d3187e0ba..4cdb93dbe8 100644 --- a/lapack-netlib/SRC/slartv.f +++ b/lapack-netlib/SRC/slartv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARTV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARTV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * REAL C( * ), S( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/slaruv.f b/lapack-netlib/SRC/slaruv.f index 97cae10d2c..ed84200178 100644 --- a/lapack-netlib/SRC/slaruv.f +++ b/lapack-netlib/SRC/slaruv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARUV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARUV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARUV( ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * REAL X( N ) * .. -* +* * *> \par Purpose: * ============= @@ -67,14 +67,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -95,10 +95,10 @@ * ===================================================================== SUBROUTINE SLARUV( ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N @@ -414,7 +414,7 @@ SUBROUTINE SLARUV( ISEED, N, X ) * X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R* $ REAL( IT4 ) ) ) ) -* +* IF (X( I ).EQ.1.0) THEN * If a real number has n bits of precision, and the first * n bits of the 48-bit integer above happen to be all 1 (which @@ -424,7 +424,7 @@ SUBROUTINE SLARUV( ISEED, N, X ) * Since X( I ) is not supposed to return exactly 0.0 or 1.0, * the statistically correct thing to do in this situation is * simply to iterate again. -* N.B. the case X( I ) = 0.0 should not be possible. +* N.B. the case X( I ) = 0.0 should not be possible. I1 = I1 + 2 I2 = I2 + 2 I3 = I3 + 2 diff --git a/lapack-netlib/SRC/slarz.f b/lapack-netlib/SRC/slarz.f index 3158a4c0a9..9c9d831161 100644 --- a/lapack-netlib/SRC/slarz.f +++ b/lapack-netlib/SRC/slarz.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, L, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/slarzb.f b/lapack-netlib/SRC/slarzb.f index 9252f31b17..3e5aab6c33 100644 --- a/lapack-netlib/SRC/slarzb.f +++ b/lapack-netlib/SRC/slarzb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARZB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARZB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * LDV, T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -183,10 +183,10 @@ SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff --git a/lapack-netlib/SRC/slarzt.f b/lapack-netlib/SRC/slarzt.f index a8a1901cca..d6428d097c 100644 --- a/lapack-netlib/SRC/slarzt.f +++ b/lapack-netlib/SRC/slarzt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLARZT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLARZT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff --git a/lapack-netlib/SRC/slas2.f b/lapack-netlib/SRC/slas2.f index 36431d58f6..906c8bd519 100644 --- a/lapack-netlib/SRC/slas2.f +++ b/lapack-netlib/SRC/slas2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX ) -* +* * .. Scalar Arguments .. * REAL F, G, H, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -73,14 +73,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -107,10 +107,10 @@ * ===================================================================== SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL F, G, H, SSMAX, SSMIN diff --git a/lapack-netlib/SRC/slascl.f b/lapack-netlib/SRC/slascl.f index bacf86ed49..d3257147d9 100644 --- a/lapack-netlib/SRC/slascl.f +++ b/lapack-netlib/SRC/slascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lapack-netlib/SRC/slascl2.f b/lapack-netlib/SRC/slascl2.f index a44a3c8fdd..dbe7783c9a 100644 --- a/lapack-netlib/SRC/slascl2.f +++ b/lapack-netlib/SRC/slascl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * REAL D( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,28 +72,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SLASCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/slasd0.f b/lapack-netlib/SRC/slasd0.f index 07c06dbdcb..b3eb073582 100644 --- a/lapack-netlib/SRC/slasd0.f +++ b/lapack-netlib/SRC/slasd0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, * WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE * .. @@ -29,7 +29,7 @@ * REAL D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,7 +72,7 @@ *> On exit D, if INFO = 0, contains its singular values. *> \endverbatim *> -*> \param[in] E +*> \param[in,out] E *> \verbatim *> E is REAL array, dimension (M-1) *> Contains the subdiagonal entries of the bidiagonal matrix. @@ -131,14 +131,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -150,10 +150,10 @@ SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, $ WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE diff --git a/lapack-netlib/SRC/slasd1.f b/lapack-netlib/SRC/slasd1.f index ae076a0f50..be93870e2e 100644 --- a/lapack-netlib/SRC/slasd1.f +++ b/lapack-netlib/SRC/slasd1.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, * IDXQ, IWORK, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, NL, NR, SQRE * REAL ALPHA, BETA @@ -29,7 +29,7 @@ * INTEGER IDXQ( * ), IWORK( * ) * REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or when there are zeros in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine SLASD2. *> @@ -156,7 +156,7 @@ *> The leading dimension of the array VT. LDVT >= max( 1, M ). *> \endverbatim *> -*> \param[out] IDXQ +*> \param[in,out] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension (N) *> This contains the permutation which will reintegrate the @@ -185,14 +185,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -204,10 +204,10 @@ SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, $ IDXQ, IWORK, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, NL, NR, SQRE diff --git a/lapack-netlib/SRC/slasd2.f b/lapack-netlib/SRC/slasd2.f index 500eedb868..5f414f105e 100644 --- a/lapack-netlib/SRC/slasd2.f +++ b/lapack-netlib/SRC/slasd2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, * LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, * IDXC, IDXQ, COLTYP, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE * REAL ALPHA, BETA @@ -33,7 +33,7 @@ * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -249,14 +249,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -269,10 +269,10 @@ SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE diff --git a/lapack-netlib/SRC/slasd3.f b/lapack-netlib/SRC/slasd3.f index 740251a603..6b1d0f00e1 100644 --- a/lapack-netlib/SRC/slasd3.f +++ b/lapack-netlib/SRC/slasd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, * LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, * $ SQRE @@ -32,7 +32,7 @@ * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -205,14 +205,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -225,10 +225,10 @@ SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, diff --git a/lapack-netlib/SRC/slasd4.f b/lapack-netlib/SRC/slasd4.f index 0c5daca031..31d5f7f6c3 100644 --- a/lapack-netlib/SRC/slasd4.f +++ b/lapack-netlib/SRC/slasd4.f @@ -140,9 +140,9 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N @@ -331,7 +331,7 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -400,7 +400,7 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -470,7 +470,7 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI @@ -622,8 +622,8 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = W + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * * Test for convergence @@ -703,7 +703,7 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * IF( INFO.NE.0 ) THEN * -* If INFO is not 0, i.e., SLAED6 failed, switch back +* If INFO is not 0, i.e., SLAED6 failed, switch back * to 2 pole interpolation. * SWTCH3 = .FALSE. @@ -803,8 +803,8 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * SWTCH = .FALSE. @@ -922,7 +922,7 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * IF( INFO.NE.0 ) THEN * -* If INFO is not 0, i.e., SLAED6 failed, switch +* If INFO is not 0, i.e., SLAED6 failed, switch * back to two pole interpolation * SWTCH3 = .FALSE. @@ -1038,8 +1038,8 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) DW = DPSI + DPHI + TEMP*TEMP TEMP = Z( II )*TEMP W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + $ + THREE*ABS( TEMP ) * $ + ABS( TAU2 )*DW * IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) diff --git a/lapack-netlib/SRC/slasd5.f b/lapack-netlib/SRC/slasd5.f index 6c2535ba38..a362b86c78 100644 --- a/lapack-netlib/SRC/slasd5.f +++ b/lapack-netlib/SRC/slasd5.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) -* +* * .. Scalar Arguments .. * INTEGER I * REAL DSIGMA, RHO @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -98,14 +98,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -116,10 +116,10 @@ * ===================================================================== SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I diff --git a/lapack-netlib/SRC/slasd6.f b/lapack-netlib/SRC/slasd6.f index f79a06d03f..ae37de00f3 100644 --- a/lapack-netlib/SRC/slasd6.f +++ b/lapack-netlib/SRC/slasd6.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, * LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE @@ -35,7 +35,7 @@ * $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), * $ VF( * ), VL( * ), WORK( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,7 +74,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or if there is a zero -*> in the Z vector. For each such occurence the dimension of the +*> in the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine SLASD7. *> @@ -232,14 +232,13 @@ *> \param[out] DIFR *> \verbatim *> DIFR is REAL array, -*> dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and -*> dimension ( N ) if ICOMPQ = 0. -*> On exit, DIFR(I, 1) is the distance between I-th updated -*> (undeflated) singular value and the I+1-th (undeflated) old -*> singular value. +*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and +*> dimension ( K ) if ICOMPQ = 0. +*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not +*> defined and will not be referenced. *> -*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the -*> normalizing factors for the right singular vector matrix. +*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the +*> normalizing factors for the right singular vector matrix. *> *> See SLASD8 for details on DIFL and DIFR. *> \endverbatim @@ -293,14 +292,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -314,10 +313,10 @@ SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, diff --git a/lapack-netlib/SRC/slasd7.f b/lapack-netlib/SRC/slasd7.f index f32bd47e48..2adaa5ee75 100644 --- a/lapack-netlib/SRC/slasd7.f +++ b/lapack-netlib/SRC/slasd7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * C, S, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE @@ -35,7 +35,7 @@ * $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), * $ ZW( * ) * .. -* +* * *> \par Purpose: * ============= @@ -259,14 +259,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -280,10 +280,10 @@ SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ C, S, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, diff --git a/lapack-netlib/SRC/slasd8.f b/lapack-netlib/SRC/slasd8.f index ca77184771..81a8625ae6 100644 --- a/lapack-netlib/SRC/slasd8.f +++ b/lapack-netlib/SRC/slasd8.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASD8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASD8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, * DSIGMA, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, K, LDDIFR * .. @@ -29,7 +29,7 @@ * $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), * $ Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,14 +147,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -166,10 +166,10 @@ SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, $ DSIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, K, LDDIFR diff --git a/lapack-netlib/SRC/slasda.f b/lapack-netlib/SRC/slasda.f index c6d69cb747..6e02260f8c 100644 --- a/lapack-netlib/SRC/slasda.f +++ b/lapack-netlib/SRC/slasda.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASDA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, * DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, * PERM, GIVNUM, C, S, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE * .. @@ -33,7 +33,7 @@ * $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -253,14 +253,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -273,10 +273,10 @@ SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE diff --git a/lapack-netlib/SRC/slasdq.f b/lapack-netlib/SRC/slasdq.f index 289ed855c0..434d373ba5 100644 --- a/lapack-netlib/SRC/slasdq.f +++ b/lapack-netlib/SRC/slasdq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASDQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASDQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, * U, LDU, C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE @@ -29,7 +29,7 @@ * REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the input bidiagonal matrix -*> is upper or lower bidiagonal, and wether it is square are +*> is upper or lower bidiagonal, and whether it is square are *> not. *> UPLO = 'U' or 'u' B is upper bidiagonal. *> UPLO = 'L' or 'l' B is lower bidiagonal. @@ -192,14 +192,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -211,10 +211,10 @@ SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, $ U, LDU, C, LDC, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/slasdt.f b/lapack-netlib/SRC/slasdt.f index f67475ef00..fe5aaa6426 100644 --- a/lapack-netlib/SRC/slasdt.f +++ b/lapack-netlib/SRC/slasdt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASDT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASDT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) -* +* * .. Scalar Arguments .. * INTEGER LVL, MSUB, N, ND * .. * .. Array Arguments .. * INTEGER INODE( * ), NDIML( * ), NDIMR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,14 +87,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Contributors: * ================== @@ -105,10 +105,10 @@ * ===================================================================== SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LVL, MSUB, N, ND diff --git a/lapack-netlib/SRC/slaset.f b/lapack-netlib/SRC/slaset.f index 23a4175efd..3a87e086b2 100644 --- a/lapack-netlib/SRC/slaset.f +++ b/lapack-netlib/SRC/slaset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/slasq1.f b/lapack-netlib/SRC/slasq1.f index b5a8a3be95..458aecea6c 100644 --- a/lapack-netlib/SRC/slasq1.f +++ b/lapack-netlib/SRC/slasq1.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASQ1( N, D, E, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,29 +89,29 @@ *> represent a matrix with the same singular values *> which the calling subroutine could use to finish the *> computation, or even feed back into SLASQ1 -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -189,7 +189,7 @@ SUBROUTINE SLASQ1( N, D, E, WORK, INFO ) CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 ) CALL SLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, $ IINFO ) -* +* * Compute the q's and e's. * DO 30 I = 1, 2*N - 1 diff --git a/lapack-netlib/SRC/slasq2.f b/lapack-netlib/SRC/slasq2.f index b97451fc62..6e5f864474 100644 --- a/lapack-netlib/SRC/slasq2.f +++ b/lapack-netlib/SRC/slasq2.f @@ -2,38 +2,38 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASQ2( N, Z, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SLASQ2 computes all the eigenvalues of the symmetric positive +*> SLASQ2 computes all the eigenvalues of the symmetric positive *> definite tridiagonal matrix associated with the qd array Z to high *> relative accuracy are computed to high relative accuracy, in the *> absence of denormalization, underflow and overflow. @@ -83,19 +83,19 @@ *> = 2, current block of Z not diagonalized after 100*N *> iterations (in inner while loop). On exit Z holds *> a qd array with the same eigenvalues as the given Z. -*> = 3, termination criterion of outer while loop not met +*> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -112,10 +112,10 @@ * ===================================================================== SUBROUTINE SLASQ2( N, Z, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -147,15 +147,14 @@ SUBROUTINE SLASQ2( N, Z, INFO ) EXTERNAL SLASQ3, SLASRT, XERBLA * .. * .. External Functions .. - INTEGER ILAENV REAL SLAMCH - EXTERNAL ILAENV, SLAMCH + EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT * .. * .. Executable Statements .. -* +* * Test the input arguments. * (in case SLASQ2 is not called by SLASQ1) * @@ -195,7 +194,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) END IF Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN - T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) + T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) S = Z( 3 )*( Z( 2 ) / T ) IF( S.LE.T ) THEN S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) @@ -264,24 +263,24 @@ SUBROUTINE SLASQ2( N, Z, INFO ) Z( 2*N-1 ) = ZERO RETURN END IF -* +* * Check whether the machine is IEEE conformable. -* +* * IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. -* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 * * [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with * some the test matrices of type 16. The double precision code is fine. * IEEE = .FALSE. -* +* * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) + Z( 2*K ) = ZERO + Z( 2*K-1 ) = Z( K ) + Z( 2*K-2 ) = ZERO + Z( 2*K-3 ) = Z( K-1 ) 30 CONTINUE * I0 = 1 @@ -338,7 +337,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) END IF EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE + 60 CONTINUE Z( 4*N0-PP-2 ) = D * * Now find qmax. @@ -369,14 +368,14 @@ SUBROUTINE SLASQ2( N, Z, INFO ) NDIV = 2*( N0-I0 ) * DO 160 IWHILA = 1, N + 1 - IF( N0.LT.1 ) + IF( N0.LT.1 ) $ GO TO 170 * -* While array unfinished do +* While array unfinished do * * E(N0) holds the value of SIGMA when submatrix in I0:N0 * splits from the rest of the array, but is negated. -* +* DESIG = ZERO IF( N0.EQ.N ) THEN SIGMA = ZERO @@ -391,7 +390,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) * Find last unreduced submatrix's top index I0, find QMAX and * EMIN. Find Gershgorin-type bound if Q's much greater than E's. * - EMAX = ZERO + EMAX = ZERO IF( N0.GT.I0 ) THEN EMIN = ABS( Z( 4*N0-5 ) ) ELSE @@ -409,7 +408,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) EMIN = MIN( EMIN, Z( I4-5 ) ) 90 CONTINUE - I4 = 4 + I4 = 4 * 100 CONTINUE I0 = I4 / 4 @@ -426,7 +425,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) KMIN = ( I4+3 )/4 END IF 110 CONTINUE - IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN IPN4 = 4*( I0+N0 ) PP = 2 @@ -451,15 +450,15 @@ SUBROUTINE SLASQ2( N, Z, INFO ) * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * -* Now I0:N0 is unreduced. +* Now I0:N0 is unreduced. * PP = 0 for ping, PP = 1 for pong. * PP = 2 indicates that flipping was applied to the Z array and -* and that the tests for deflation upon entry in SLASQ3 +* and that the tests for deflation upon entry in SLASQ3 * should not be performed. * NBIG = 100*( N0-I0+1 ) DO 140 IWHILB = 1, NBIG - IF( I0.GT.N0 ) + IF( I0.GT.N0 ) $ GO TO 150 * * While submatrix unfinished take a good dqds step. @@ -502,8 +501,8 @@ SUBROUTINE SLASQ2( N, Z, INFO ) 140 CONTINUE * INFO = 2 -* -* Maximum number of iterations exceeded, restore the shift +* +* Maximum number of iterations exceeded, restore the shift * SIGMA and place the new d's and e's in a qd array. * This might need to be done for several blocks * @@ -556,16 +555,16 @@ SUBROUTINE SLASQ2( N, Z, INFO ) INFO = 3 RETURN * -* end IWHILA +* end IWHILA * 170 CONTINUE -* +* * Move q's to the front. -* +* DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) 180 CONTINUE -* +* * Sort and compute sum of eigenvalues. * CALL SLASRT( 'D', N, Z, IINFO ) @@ -577,7 +576,7 @@ SUBROUTINE SLASQ2( N, Z, INFO ) * * Store trace, sum(eigenvalues) and information on performance. * - Z( 2*N+1 ) = TRACE + Z( 2*N+1 ) = TRACE Z( 2*N+2 ) = E Z( 2*N+3 ) = REAL( ITER ) Z( 2*N+4 ) = REAL( NDIV ) / REAL( N**2 ) diff --git a/lapack-netlib/SRC/slasq3.f b/lapack-netlib/SRC/slasq3.f index 4187a943e9..4bc06475eb 100644 --- a/lapack-netlib/SRC/slasq3.f +++ b/lapack-netlib/SRC/slasq3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, * DN2, G, TAU ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, ITER, N0, NDIV, NFAIL, PP @@ -31,7 +31,7 @@ * .. Array Arguments .. * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is REAL array, dimension ( 4*N ) +*> Z is REAL array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -68,8 +68,8 @@ *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. -*> PP=2 indicates that flipping was applied to the Z array -*> and that the initial tests for deflation should not be +*> PP=2 indicates that flipping was applied to the Z array +*> and that the initial tests for deflation should not be *> performed. *> \endverbatim *> @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, G, TAU ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. LOGICAL IEEE @@ -286,7 +286,7 @@ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, GO TO 10 * 50 CONTINUE - IF( PP.EQ.2 ) + IF( PP.EQ.2 ) $ PP = 0 * * Reverse the qd-array, if warranted. @@ -345,7 +345,7 @@ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * GO TO 90 * - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. $ ABS( DN ).LT.TOL*SIGMA ) THEN * @@ -389,7 +389,7 @@ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, GO TO 70 END IF ELSE -* +* * Possible underflow. Play it safe. * GO TO 80 diff --git a/lapack-netlib/SRC/slasq4.f b/lapack-netlib/SRC/slasq4.f index bdd24f32c9..32496a245b 100644 --- a/lapack-netlib/SRC/slasq4.f +++ b/lapack-netlib/SRC/slasq4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * DN1, DN2, TAU, TTYPE, G ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, N0IN, PP, TTYPE * REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,7 +56,7 @@ *> *> \param[in] Z *> \verbatim -*> Z is REAL array, dimension ( 4*N ) +*> Z is REAL array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -151,10 +151,10 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE, G ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE @@ -192,7 +192,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, TTYPE = -1 RETURN END IF -* +* NN = 4*N0 + PP IF( N0IN.EQ.N0 ) THEN * @@ -262,7 +262,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 20 10 CONTINUE 20 CONTINUE @@ -303,7 +303,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 40 30 CONTINUE 40 CONTINUE @@ -331,7 +331,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. * - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN * * Cases 7 and 8. * @@ -349,7 +349,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) $ GO TO 60 50 CONTINUE 60 CONTINUE @@ -358,7 +358,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, GAP2 = HALF*DMIN2 - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) TTYPE = -8 END IF @@ -378,7 +378,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * Cases 10 and 11. * - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN TTYPE = -10 S = THIRD*DMIN2 IF( Z( NN-5 ).GT.Z( NN-7 ) ) @@ -402,7 +402,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE + ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) END IF ELSE @@ -413,7 +413,7 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * * Case 12, more than two eigenvalues deflated. No information. * - S = ZERO + S = ZERO TTYPE = -12 END IF * diff --git a/lapack-netlib/SRC/slasq5.f b/lapack-netlib/SRC/slasq5.f index c24d302c0a..967e0a846f 100644 --- a/lapack-netlib/SRC/slasq5.f +++ b/lapack-netlib/SRC/slasq5.f @@ -1,26 +1,26 @@ -*> \brief \b SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. +*> \brief SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2, IEEE, EPS ) -* +* * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, N0, PP @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,6 +75,7 @@ *> \endverbatim *> *> \param[in] SIGMA +*> \verbatim *> SIGMA is REAL *> This is the accumulated shift up to this step. *> \endverbatim @@ -130,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -143,10 +144,10 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, $ DN, DNM1, DNM2, IEEE, EPS ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL IEEE @@ -184,11 +185,11 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) -* +* IF( IEEE ) THEN -* +* * Code for IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) @@ -208,9 +209,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( Z( J4-1 ), EMIN ) 20 CONTINUE END IF -* +* * Unroll last two steps. -* +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -219,7 +220,7 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -227,11 +228,11 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) -* +* ELSE -* +* * Code for non IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) @@ -257,9 +258,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( EMIN, Z( J4-1 ) ) 40 CONTINUE END IF -* +* * Unroll last two steps. -* +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -272,7 +273,7 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -284,7 +285,7 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) -* +* END IF * ELSE @@ -295,9 +296,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DMIN = D DMIN1 = -Z( J4 ) IF( IEEE ) THEN -* +* * Code for IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 50 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) @@ -319,9 +320,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( Z( J4-1 ), EMIN ) 60 CONTINUE END IF -* +* * Unroll last two steps. -* +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -330,7 +331,7 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -338,11 +339,11 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) -* +* ELSE -* +* * Code for non IEEE arithmetic. -* +* IF( PP.EQ.0 ) THEN DO 70 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) @@ -370,9 +371,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, EMIN = MIN( EMIN, Z( J4-1 ) ) 80 CONTINUE END IF -* +* * Unroll last two steps. -* +* DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP @@ -385,7 +386,7 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) -* +* DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 @@ -397,9 +398,9 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) -* +* END IF -* +* END IF Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN diff --git a/lapack-netlib/SRC/slasq6.f b/lapack-netlib/SRC/slasq6.f index e56813bb17..afb9b81efb 100644 --- a/lapack-netlib/SRC/slasq6.f +++ b/lapack-netlib/SRC/slasq6.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASQ6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASQ6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2 ) -* +* * .. Scalar Arguments .. * INTEGER I0, N0, PP * REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -119,10 +119,10 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER I0, N0, PP @@ -156,13 +156,13 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * SAFMIN = SLAMCH( 'Safe minimum' ) J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) DMIN = D * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO D = Z( J4+1 ) @@ -173,7 +173,7 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, TEMP = Z( J4+1 ) / Z( J4-2 ) Z( J4 ) = Z( J4-1 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) END IF @@ -182,7 +182,7 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( Z( J4-3 ).EQ.ZERO ) THEN Z( J4-1 ) = ZERO D = Z( J4+2 ) @@ -193,7 +193,7 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, TEMP = Z( J4+2 ) / Z( J4-3 ) Z( J4-1 ) = Z( J4 )*TEMP D = D*TEMP - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) END IF @@ -202,7 +202,7 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN diff --git a/lapack-netlib/SRC/slasr.f b/lapack-netlib/SRC/slasr.f index 5f8cbaa5ef..6e18337893 100644 --- a/lapack-netlib/SRC/slasr.f +++ b/lapack-netlib/SRC/slasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,35 +36,35 @@ *> *> SLASR applies a sequence of plane rotations to a real matrix A, *> from either the left or the right. -*> +*> *> When SIDE = 'L', the transformation takes the form -*> +*> *> A := P*A -*> +*> *> and when SIDE = 'R', the transformation takes the form -*> +*> *> A := A*P**T -*> +*> *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -73,13 +73,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -88,12 +88,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -102,7 +102,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -187,22 +187,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lapack-netlib/SRC/slasrt.f b/lapack-netlib/SRC/slasrt.f index e93c0d6db1..ef6aa4df7b 100644 --- a/lapack-netlib/SRC/slasrt.f +++ b/lapack-netlib/SRC/slasrt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASRT( ID, N, D, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -76,22 +76,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SLASRT( ID, N, D, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER ID @@ -123,7 +123,7 @@ SUBROUTINE SLASRT( ID, N, D, INFO ) * .. * .. Executable Statements .. * -* Test the input paramters. +* Test the input parameters. * INFO = 0 DIR = -1 diff --git a/lapack-netlib/SRC/slassq.f b/lapack-netlib/SRC/slassq.f index 0776bb31cf..35b40f07f8 100644 --- a/lapack-netlib/SRC/slassq.f +++ b/lapack-netlib/SRC/slassq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/slasv2.f b/lapack-netlib/SRC/slasv2.f index 24ae12c685..3cd556e33d 100644 --- a/lapack-netlib/SRC/slasv2.f +++ b/lapack-netlib/SRC/slasv2.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* +* * .. Scalar Arguments .. * REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. -* +* * *> \par Purpose: * ============= @@ -102,14 +102,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN diff --git a/lapack-netlib/SRC/slaswlq.f b/lapack-netlib/SRC/slaswlq.f new file mode 100644 index 0000000000..efd28a6b10 --- /dev/null +++ b/lapack-netlib/SRC/slaswlq.f @@ -0,0 +1,258 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLASWLQ computes a blocked Short-Wide LQ factorization of a +*> M-by-N matrix A, where N >= M: +*> A = L * Q +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and bleow the diagonal +*> of the array contain the N-by-N lower triangular matrix L; +*> the elements above the diagonal represent Q by the rows +*> of blocked V (see Further Details). +*> +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((N-M)/(NB-M)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= MB * M. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, + $ INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( * ), T( LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL SGEQRT, STPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.LT.M ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN + INFO = -3 + ELSE IF( NB.LE.M ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -8 + ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = MB*M + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLASWLQ', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN + CALL SGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((N-M),(NB-M)) + II=N-KK+1 +* +* Compute the LQ factorization of the first block A(1:M,1:NB) +* + CALL SGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO) + CTR = 1 +* + DO I = NB+1, II-NB+M , (NB-M) +* +* Compute the QR factorization of the current block A(1:M,I:I+NB-M) +* + CALL STPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ), + $ LDA, T(1, CTR * M + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(1:M,II:N) +* + IF (II.LE.N) THEN + CALL STPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ), + $ LDA, T(1, CTR * M + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = M * MB + RETURN +* +* End of SLASWLQ +* + END diff --git a/lapack-netlib/SRC/slaswp.f b/lapack-netlib/SRC/slaswp.f index fb6f27d411..ad12a3a3a7 100644 --- a/lapack-netlib/SRC/slaswp.f +++ b/lapack-netlib/SRC/slaswp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,15 +71,15 @@ *> \param[in] K2 *> \verbatim *> K2 is INTEGER -*> The last element of IPIV for which a row interchange will -*> be done. +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*INCX of IPIV are accessed. *> IPIV(K) = L implies rows K and L are to be interchanged. *> \endverbatim *> @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -143,7 +143,7 @@ SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX + IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 diff --git a/lapack-netlib/SRC/slasy2.f b/lapack-netlib/SRC/slasy2.f index 5684a119f2..72b835e109 100644 --- a/lapack-netlib/SRC/slasy2.f +++ b/lapack-netlib/SRC/slasy2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, * LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL LTRANL, LTRANR * INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 @@ -30,7 +30,7 @@ * REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realSYauxiliary * @@ -174,10 +174,10 @@ SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR @@ -438,8 +438,10 @@ SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, 80 CONTINUE 90 CONTINUE 100 CONTINUE - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) THEN + INFO = 1 + T16( 4, 4 ) = SMIN + END IF SCALE = ONE IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. diff --git a/lapack-netlib/SRC/slasyf_aa.f b/lapack-netlib/SRC/slasyf_aa.f new file mode 100644 index 0000000000..5fb3cc9aa9 --- /dev/null +++ b/lapack-netlib/SRC/slasyf_aa.f @@ -0,0 +1,506 @@ +*> \brief \b SLASYF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AA factorizes a panel of a real symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by SSYTRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is REAL workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYcomputational +* +* ===================================================================== + SUBROUTINE SLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + REAL PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX, ILAENV + EXTERNAL LSAME, ILAENV, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from SSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL SGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL SCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL SAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL SAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ISAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL SSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL SSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL SSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL SSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL SCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL SCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL SSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL SLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from SSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL SGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL SCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL SAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL SAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ISAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL SSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL SSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL SSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL SSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL SCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL SCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL SSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL SLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of SLASYF_AA +* + END diff --git a/lapack-netlib/SRC/slasyf_rk.f b/lapack-netlib/SRC/slasyf_rk.f new file mode 100644 index 0000000000..b1b37177f2 --- /dev/null +++ b/lapack-netlib/SRC/slasyf_rk.f @@ -0,0 +1,965 @@ +*> \brief \b SLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SLASYF_RK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> SLASYF_RK is an auxiliary routine called by SSYTRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, + $ KP, KSTEP, P, II + REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ STEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + REAL SLAMCH + EXTERNAL LSAME, ISAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ISAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = ABS( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL SCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL SCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL SSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL SSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL SSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = ZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL SGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), + $ LDW, ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = ABS( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL SCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL SCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL SSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL SSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL SSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = ZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF +* + RETURN +* +* End of SLASYF_RK +* + END diff --git a/lapack-netlib/SRC/slatbs.f b/lapack-netlib/SRC/slatbs.f index 1cd7cb78e3..a06838cb01 100644 --- a/lapack-netlib/SRC/slatbs.f +++ b/lapack-netlib/SRC/slatbs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATBS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATBS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, * SCALE, CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, KD, LDAB, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -157,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -242,10 +242,10 @@ SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/slatdf.f b/lapack-netlib/SRC/slatdf.f index 51773d4e5c..5496f9db49 100644 --- a/lapack-netlib/SRC/slatdf.f +++ b/lapack-netlib/SRC/slatdf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATDF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATDF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * REAL RDSCAL, RDSUM @@ -29,7 +29,7 @@ * INTEGER IPIV( * ), JPIV( * ) * REAL RHS( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> Zx = +-e - f with the sign giving the greater value *> of 2-norm(x). About 5 times as expensive as Default. *> IJOB .ne. 2: Local look ahead strategy where all entries of -*> the r.h.s. b is choosen as either +1 or -1 (Default). +*> the r.h.s. b is chosen as either +1 or -1 (Default). *> \endverbatim *> *> \param[in] N @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realOTHERauxiliary * @@ -171,10 +171,10 @@ SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IJOB, LDZ, N diff --git a/lapack-netlib/SRC/slatps.f b/lapack-netlib/SRC/slatps.f index 4ce411ff13..83151c196a 100644 --- a/lapack-netlib/SRC/slatps.f +++ b/lapack-netlib/SRC/slatps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL AP( * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -229,10 +229,10 @@ SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/slatrd.f b/lapack-netlib/SRC/slatrd.f index 48bd4cf4b7..f562ce3967 100644 --- a/lapack-netlib/SRC/slatrd.f +++ b/lapack-netlib/SRC/slatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup doubleOTHERauxiliary * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/slatrs.f b/lapack-netlib/SRC/slatrs.f index b762a4b6a4..d62debcd9c 100644 --- a/lapack-netlib/SRC/slatrs.f +++ b/lapack-netlib/SRC/slatrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), CNORM( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -238,10 +238,10 @@ SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/slatrz.f b/lapack-netlib/SRC/slatrz.f index 99cab45874..16e973294f 100644 --- a/lapack-netlib/SRC/slatrz.f +++ b/lapack-netlib/SRC/slatrz.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLATRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLATRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK ) -* +* * .. Scalar Arguments .. * INTEGER L, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER L, LDA, M, N diff --git a/lapack-netlib/SRC/slatsqr.f b/lapack-netlib/SRC/slatsqr.f new file mode 100644 index 0000000000..d6d6827999 --- /dev/null +++ b/lapack-netlib/SRC/slatsqr.f @@ -0,0 +1,255 @@ +* +* Definition: +* =========== +* +* SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLATSQR computes a blocked Tall-Skinny QR factorization of +*> an M-by-N matrix A, where M >= N: +*> A = Q * R . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> MB > N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal +*> of the array contain the N-by-N upper triangular matrix R; +*> the elements below the diagonal represent Q by the columns +*> of blocked V (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((M-N)/(MB-N)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) REAL array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= NB*N. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, + $ LWORK, INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( * ), T(LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL SGEQRT, STPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. M.LT.N ) THEN + INFO = -2 + ELSE IF( MB.LE.N ) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -8 + ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = NB*N + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLATSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF ((MB.LE.N).OR.(MB.GE.M)) THEN + CALL SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF + KK = MOD((M-N),(MB-N)) + II=M-KK+1 +* +* Compute the QR factorization of the first block A(1:MB,1:N) +* + CALL SGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO ) +* + CTR = 1 + DO I = MB+1, II-MB+N , (MB-N) +* +* Compute the QR factorization of the current block A(I:I+MB-N,1:N) +* + CALL STPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA, + $ T(1, CTR * N + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(II:M,1:N) +* + IF (II.LE.M) THEN + CALL STPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA, + $ T(1, CTR * N + 1), LDT, + $ WORK, INFO ) + END IF +* + work( 1 ) = N*NB + RETURN +* +* End of SLATSQR +* + END diff --git a/lapack-netlib/SRC/slauu2.f b/lapack-netlib/SRC/slauu2.f index e00eb29358..c9f774cc8f 100644 --- a/lapack-netlib/SRC/slauu2.f +++ b/lapack-netlib/SRC/slauu2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAUU2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAUU2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/slauum.f b/lapack-netlib/SRC/slauum.f index 0915e289cc..c23c4b3e67 100644 --- a/lapack-netlib/SRC/slauum.f +++ b/lapack-netlib/SRC/slauum.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLAUUM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLAUUM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sopgtr.f b/lapack-netlib/SRC/sopgtr.f index c047512711..567f76a794 100644 --- a/lapack-netlib/SRC/sopgtr.f +++ b/lapack-netlib/SRC/sopgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SOPGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SOPGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDQ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sopmtr.f b/lapack-netlib/SRC/sopmtr.f index ae2e7584a3..809f8b2a9f 100644 --- a/lapack-netlib/SRC/sopmtr.f +++ b/lapack-netlib/SRC/sopmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SOPMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SOPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -150,10 +150,10 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/sorbdb.f b/lapack-netlib/SRC/sorbdb.f index d615117eab..2e460aaa9f 100644 --- a/lapack-netlib/SRC/sorbdb.f +++ b/lapack-netlib/SRC/sorbdb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORBDB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, * TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIGNS, TRANS * INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, @@ -33,7 +33,7 @@ * $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), * $ X21( LDX21, * ), X22( LDX22, * ) * .. -* +* * *> \par Purpose: * ============= @@ -250,12 +250,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -287,10 +287,10 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -393,7 +393,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * IF( COLMAJOR ) THEN * -* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 * DO I = 1, Q * diff --git a/lapack-netlib/SRC/sorbdb1.f b/lapack-netlib/SRC/sorbdb1.f index b1f5f4628c..0e99826949 100644 --- a/lapack-netlib/SRC/sorbdb1.f +++ b/lapack-netlib/SRC/sorbdb1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB1 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -151,7 +151,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -169,10 +169,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -203,7 +203,7 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -304,9 +304,8 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I+1,I+1), LDX11, WORK(ILARF) ) CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK(ILARF) ) - C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), - $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), - $ 1 )**2 ) + C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + SNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) CALL SORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, diff --git a/lapack-netlib/SRC/sorbdb2.f b/lapack-netlib/SRC/sorbdb2.f index 582540e34b..dec4dbe120 100644 --- a/lapack-netlib/SRC/sorbdb2.f +++ b/lapack-netlib/SRC/sorbdb2.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB2 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -167,10 +167,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -201,7 +201,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -280,7 +280,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., P of X11 and X21 * DO I = 1, P -* +* IF( I .GT. 1 ) THEN CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) END IF @@ -291,8 +291,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I+1,I), LDX11, WORK(ILARF) ) CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), $ X21(I,I), LDX21, WORK(ILARF) ) - S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + SNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 + $ + SNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL SORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, diff --git a/lapack-netlib/SRC/sorbdb3.f b/lapack-netlib/SRC/sorbdb3.f index ea52f4db3f..5b6e946d81 100644 --- a/lapack-netlib/SRC/sorbdb3.f +++ b/lapack-netlib/SRC/sorbdb3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB3 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -168,10 +168,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -202,7 +202,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -281,7 +281,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., M-P of X11 and X21 * DO I = 1, M-P -* +* IF( I .GT. 1 ) THEN CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) END IF @@ -293,8 +293,8 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X11(I,I), LDX11, WORK(ILARF) ) CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) - C = SQRT( SNRM2( P-I+1, X11(I,I), 1, X11(I,I), - $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + C = SQRT( SNRM2( P-I+1, X11(I,I), 1 )**2 + $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL SORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, diff --git a/lapack-netlib/SRC/sorbdb4.f b/lapack-netlib/SRC/sorbdb4.f index 9ed16a714e..0b209b2d24 100644 --- a/lapack-netlib/SRC/sorbdb4.f +++ b/lapack-netlib/SRC/sorbdb4.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB4 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -30,8 +30,8 @@ * REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), * $ WORK(*), X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -161,7 +161,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -179,10 +179,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -214,7 +214,7 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -342,9 +342,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) IF( I .LT. M-Q ) THEN - S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), - $ 1 )**2 ) + S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 + $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) PHI(I) = ATAN2( S, C ) END IF * diff --git a/lapack-netlib/SRC/sorbdb5.f b/lapack-netlib/SRC/sorbdb5.f index a0b6672c05..f037ba1d38 100644 --- a/lapack-netlib/SRC/sorbdb5.f +++ b/lapack-netlib/SRC/sorbdb5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB5 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -156,7 +156,7 @@ SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -269,6 +269,6 @@ SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, RETURN * * End of SORBDB5 -* +* END diff --git a/lapack-netlib/SRC/sorbdb6.f b/lapack-netlib/SRC/sorbdb6.f index 900316ee82..83d96612ae 100644 --- a/lapack-netlib/SRC/sorbdb6.f +++ b/lapack-netlib/SRC/sorbdb6.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORBDB6 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -141,10 +141,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -154,7 +154,7 @@ SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -260,7 +260,7 @@ SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, IF( NORMSQ2 .EQ. ZERO ) THEN RETURN END IF -* +* NORMSQ1 = NORMSQ2 * DO I = 1, N @@ -305,7 +305,7 @@ SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, END IF * RETURN -* +* * End of SORBDB6 * END diff --git a/lapack-netlib/SRC/sorcsd.f b/lapack-netlib/SRC/sorcsd.f index ff4e80579f..5621d58edf 100644 --- a/lapack-netlib/SRC/sorcsd.f +++ b/lapack-netlib/SRC/sorcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * LDX12, X21, LDX21, X22, LDX22, THETA, * U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, * LDV2T, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, @@ -37,7 +37,7 @@ * $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, * $ * ) * .. -* +* * *> \par Purpose: * ============= @@ -284,12 +284,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -300,10 +300,10 @@ RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -343,7 +343,7 @@ RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ WANTV1T, WANTV2T * .. * .. External Subroutines .. - EXTERNAL SBBCSD, SLACPY, SLAPMR, SLAPMT, SLASCL, SLASET, + EXTERNAL SBBCSD, SLACPY, SLAPMR, SLAPMT, $ SORBDB, SORGLQ, SORGQR, XERBLA * .. * .. External Functions .. @@ -578,7 +578,7 @@ RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, * Permute rows and columns to place identity submatrices in top- * left corner of (1,1)-block and/or bottom-right corner of (1,2)- * block and/or bottom-right corner of (2,1)-block and/or top-left -* corner of (2,2)-block +* corner of (2,2)-block * IF( Q .GT. 0 .AND. WANTU2 ) THEN DO I = 1, Q diff --git a/lapack-netlib/SRC/sorcsd2by1.f b/lapack-netlib/SRC/sorcsd2by1.f index b2401af190..1ff4732c95 100644 --- a/lapack-netlib/SRC/sorcsd2by1.f +++ b/lapack-netlib/SRC/sorcsd2by1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download SORCSD2BY1 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, * X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, * LDV1T, WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T * INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, @@ -33,8 +33,8 @@ * $ X11(LDX11,*), X21(LDX21,*) * INTEGER IWORK(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -44,18 +44,19 @@ *> orthonormal columns that has been partitioned into a 2-by-1 block *> structure: *> -*> [ I 0 0 ] +*> [ I1 0 0 ] *> [ 0 C 0 ] *> [ X11 ] [ U1 | ] [ 0 0 0 ] *> X = [-----] = [---------] [----------] V1**T . *> [ X21 ] [ | U2 ] [ 0 0 0 ] *> [ 0 S 0 ] -*> [ 0 0 I ] -*> +*> [ 0 0 I2] +*> *> X11 is P-by-Q. The orthogonal matrices U1, U2, and V1 are P-by-P, *> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R *> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which -*> R = MIN(P,M-P,Q,M-Q). +*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a +*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). *> \endverbatim * * Arguments: @@ -218,10 +219,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -232,7 +233,7 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, $ LDV1T, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -248,7 +249,7 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ X11(LDX11,*), X21(LDX21,*) INTEGER IWORK(*) * .. -* +* * ===================================================================== * * .. Parameters .. @@ -264,6 +265,9 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LWORKMIN, LWORKOPT, R LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T * .. +* .. Local Arrays .. + REAL DUM1(1), DUM2(1,1) +* .. * .. External Subroutines .. EXTERNAL SBBCSD, SCOPY, SLACPY, SLAPMR, SLAPMT, SORBDB1, $ SORBDB2, SORBDB3, SORBDB4, SORGLQ, SORGQR, @@ -296,11 +300,11 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, INFO = -8 ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -10 - ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN INFO = -13 - ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN INFO = -15 - ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN INFO = -17 END IF * @@ -342,98 +346,124 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, IORBDB = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ1 + MAX( 1, Q ) IORGLQ = ITAUQ1 + MAX( 1, Q ) + LORGQRMIN = 1 + LORGQROPT = 1 + LORGLQMIN = 1 + LORGLQOPT = 1 IF( R .EQ. Q ) THEN - CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK, -1, CHILDINFO ) + CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, WORK, -1, + $ CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + ENDIF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SORGLQ( Q-1, Q-1, Q-1, V1T, LDV1T, + $ DUM1, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q-1 ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL SORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, - $ 0, WORK(1), -1, CHILDINFO ) - LORGLQMIN = MAX( 1, Q-1 ) - LORGLQOPT = INT( WORK(1) ) CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, - $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + $ DUM1, U1, LDU1, U2, LDU2, V1T, LDV1T, DUM2, + $ 1, DUM1, DUM1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, WORK(1), -1, CHILDINFO + $ ) LBBCSD = INT( WORK(1) ) ELSE IF( R .EQ. P ) THEN - CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, WORK(1), -1, + $ CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P-1 .GE. M-P ) THEN - CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), - $ -1, CHILDINFO ) - LORGQRMIN = MAX( 1, P-1 ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, DUM1, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, - $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + $ DUM1, V1T, LDV1T, DUM2, 1, U1, LDU1, U2, + $ LDU2, DUM1, DUM1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, WORK(1), -1, CHILDINFO + $ ) LBBCSD = INT( WORK(1) ) ELSE IF( R .EQ. M-P ) THEN - CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, WORK(1), -1, + $ CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P-1 ) THEN - CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, DUM1, $ WORK(1), -1, CHILDINFO ) - LORGQRMIN = MAX( 1, M-P-1 ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, - $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ THETA, DUM1, DUM2, 1, V1T, LDV1T, U2, LDU2, + $ U1, LDU1, DUM1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, WORK(1), -1, $ CHILDINFO ) LBBCSD = INT( WORK(1) ) ELSE - CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ DUM1, DUM1, DUM1, DUM1, DUM1, + $ WORK(1), -1, CHILDINFO ) LORBDB = M + INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL SORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SORGQR( P, P, M-Q, U1, LDU1, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, DUM1, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SORGLQ( Q, Q, Q, V1T, LDV1T, DUM1, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL SORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, - $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ THETA, DUM1, U2, LDU2, U1, LDU1, DUM2, 1, + $ V1T, LDV1T, DUM1, DUM1, DUM1, DUM1, + $ DUM1, DUM1, DUM1, DUM1, WORK(1), -1, $ CHILDINFO ) LBBCSD = INT( WORK(1) ) END IF @@ -495,16 +525,16 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL SORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, - $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, + $ DUM2, 1, WORK(IB11D), WORK(IB11E), WORK(IB12D), $ WORK(IB12E), WORK(IB21D), WORK(IB21E), $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place zero submatrices in * preferred positions * @@ -549,16 +579,16 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, - $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IPHI), V1T, LDV1T, DUM1, 1, U1, LDU1, U2, + $ LDU2, WORK(IB11D), WORK(IB11E), WORK(IB12D), $ WORK(IB12E), WORK(IB21D), WORK(IB21E), $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -604,16 +634,16 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1, - $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D), - $ WORK(IB12E), WORK(IB21D), WORK(IB21E), - $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ THETA, WORK(IPHI), DUM1, 1, V1T, LDV1T, U2, + $ LDU2, U1, LDU1, WORK(IB11D), WORK(IB11E), + $ WORK(IB12D), WORK(IB12E), WORK(IB21D), + $ WORK(IB21E), WORK(IB22D), WORK(IB22E), + $ WORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -673,16 +703,16 @@ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL SORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, - $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, DUM1, 1, + $ V1T, LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D), $ WORK(IB12E), WORK(IB21D), WORK(IB21E), $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * diff --git a/lapack-netlib/SRC/sorg2l.f b/lapack-netlib/SRC/sorg2l.f index 9e5c388726..e26c70d77b 100644 --- a/lapack-netlib/SRC/sorg2l.f +++ b/lapack-netlib/SRC/sorg2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/sorg2r.f b/lapack-netlib/SRC/sorg2r.f index 297b61a24b..a301f6008f 100644 --- a/lapack-netlib/SRC/sorg2r.f +++ b/lapack-netlib/SRC/sorg2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/sorgbr.f b/lapack-netlib/SRC/sorgbr.f index a525acd267..dccdbb58a7 100644 --- a/lapack-netlib/SRC/sorgbr.f +++ b/lapack-netlib/SRC/sorgbr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,10 +145,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ * ===================================================================== SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -182,8 +182,7 @@ SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SORGLQ, SORGQR, XERBLA diff --git a/lapack-netlib/SRC/sorghr.f b/lapack-netlib/SRC/sorghr.f index be54131bab..3efea72f28 100644 --- a/lapack-netlib/SRC/sorghr.f +++ b/lapack-netlib/SRC/sorghr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -152,8 +152,8 @@ SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) EXTERNAL SORGQR, XERBLA * .. * .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV + INTEGER ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN diff --git a/lapack-netlib/SRC/sorgl2.f b/lapack-netlib/SRC/sorgl2.f index 30430287d3..276a01ec8c 100644 --- a/lapack-netlib/SRC/sorgl2.f +++ b/lapack-netlib/SRC/sorgl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/sorglq.f b/lapack-netlib/SRC/sorglq.f index 9239c24400..90806fcc3b 100644 --- a/lapack-netlib/SRC/sorglq.f +++ b/lapack-netlib/SRC/sorglq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sorgql.f b/lapack-netlib/SRC/sorgql.f index a15dc3f05c..b46b00c273 100644 --- a/lapack-netlib/SRC/sorgql.f +++ b/lapack-netlib/SRC/sorgql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sorgqr.f b/lapack-netlib/SRC/sorgqr.f index d491346772..dbc9faff46 100644 --- a/lapack-netlib/SRC/sorgqr.f +++ b/lapack-netlib/SRC/sorgqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sorgr2.f b/lapack-netlib/SRC/sorgr2.f index b5f4a60f44..5a03e7d773 100644 --- a/lapack-netlib/SRC/sorgr2.f +++ b/lapack-netlib/SRC/sorgr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/sorgrq.f b/lapack-netlib/SRC/sorgrq.f index 5bafb88fa3..b5ecdeac41 100644 --- a/lapack-netlib/SRC/sorgrq.f +++ b/lapack-netlib/SRC/sorgrq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/sorgtr.f b/lapack-netlib/SRC/sorgtr.f index 919b9bb172..da9a6558f6 100644 --- a/lapack-netlib/SRC/sorgtr.f +++ b/lapack-netlib/SRC/sorgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -183,7 +183,7 @@ SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) LWKOPT = MAX( 1, N-1 )*NB WORK( 1 ) = LWKOPT END IF -* +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORGTR', -INFO ) RETURN diff --git a/lapack-netlib/SRC/sorm2l.f b/lapack-netlib/SRC/sorm2l.f index b0adc9ef43..0542ae222a 100644 --- a/lapack-netlib/SRC/sorm2l.f +++ b/lapack-netlib/SRC/sorm2l.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sorm2r.f b/lapack-netlib/SRC/sorm2r.f index 4a6aaa48ff..61560d656e 100644 --- a/lapack-netlib/SRC/sorm2r.f +++ b/lapack-netlib/SRC/sorm2r.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormbr.f b/lapack-netlib/SRC/sormbr.f index 83b9d6392b..425e04cd2d 100644 --- a/lapack-netlib/SRC/sormbr.f +++ b/lapack-netlib/SRC/sormbr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -183,12 +183,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -196,10 +196,10 @@ SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT @@ -277,18 +277,18 @@ SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, ELSE NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) - END IF + END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) + $ -1 ) ELSE NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT + WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN diff --git a/lapack-netlib/SRC/sormhr.f b/lapack-netlib/SRC/sormhr.f index b08c5f792a..10e0b3c602 100644 --- a/lapack-netlib/SRC/sormhr.f +++ b/lapack-netlib/SRC/sormhr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -253,7 +253,7 @@ SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, IF( LEFT ) THEN NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE - NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 ) + NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT diff --git a/lapack-netlib/SRC/sorml2.f b/lapack-netlib/SRC/sorml2.f index 28a7754bd3..b9242ce697 100644 --- a/lapack-netlib/SRC/sorml2.f +++ b/lapack-netlib/SRC/sorml2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormlq.f b/lapack-netlib/SRC/sormlq.f index e15309077d..5cc4b875c4 100644 --- a/lapack-netlib/SRC/sormlq.f +++ b/lapack-netlib/SRC/sormlq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,7 +137,7 @@ *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. +*> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -250,7 +250,7 @@ SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT - END IF + END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORMLQ', -INFO ) diff --git a/lapack-netlib/SRC/sormql.f b/lapack-netlib/SRC/sormql.f index eafaeeb491..51625693cd 100644 --- a/lapack-netlib/SRC/sormql.f +++ b/lapack-netlib/SRC/sormql.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormqr.f b/lapack-netlib/SRC/sormqr.f index 50b78572fd..5132f1a696 100644 --- a/lapack-netlib/SRC/sormqr.f +++ b/lapack-netlib/SRC/sormqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormr2.f b/lapack-netlib/SRC/sormr2.f index 9530393cea..8062115e04 100644 --- a/lapack-netlib/SRC/sormr2.f +++ b/lapack-netlib/SRC/sormr2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormr3.f b/lapack-netlib/SRC/sormr3.f index 13bc19dcf9..461957afb5 100644 --- a/lapack-netlib/SRC/sormr3.f +++ b/lapack-netlib/SRC/sormr3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormrq.f b/lapack-netlib/SRC/sormrq.f index eac91940e7..ec7775b4fa 100644 --- a/lapack-netlib/SRC/sormrq.f +++ b/lapack-netlib/SRC/sormrq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/sormrz.f b/lapack-netlib/SRC/sormrz.f index 5167b1183e..e86d1aa869 100644 --- a/lapack-netlib/SRC/sormrz.f +++ b/lapack-netlib/SRC/sormrz.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -187,10 +187,10 @@ SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -265,7 +265,7 @@ SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * IF( INFO.EQ.0 ) THEN * -* Compute the workspace requirements +* Compute the workspace requirements * IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 diff --git a/lapack-netlib/SRC/sormtr.f b/lapack-netlib/SRC/sormtr.f index 9935716ddb..5d46ff98fb 100644 --- a/lapack-netlib/SRC/sormtr.f +++ b/lapack-netlib/SRC/sormtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SORMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SORMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), C( LDC, * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -172,10 +172,10 @@ SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/spbcon.f b/lapack-netlib/SRC/spbcon.f index 3a9a8187a7..a32e605c60 100644 --- a/lapack-netlib/SRC/spbcon.f +++ b/lapack-netlib/SRC/spbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -132,10 +132,10 @@ SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbequ.f b/lapack-netlib/SRC/spbequ.f index ab5650faf9..6379831cb3 100644 --- a/lapack-netlib/SRC/spbequ.f +++ b/lapack-netlib/SRC/spbequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,22 +117,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbrfs.f b/lapack-netlib/SRC/spbrfs.f index fc230d97a2..1f83244337 100644 --- a/lapack-netlib/SRC/spbrfs.f +++ b/lapack-netlib/SRC/spbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbstf.f b/lapack-netlib/SRC/spbstf.f index ca93d70d7a..dba3d70b8e 100644 --- a/lapack-netlib/SRC/spbstf.f +++ b/lapack-netlib/SRC/spbstf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBSTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBSTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -152,10 +152,10 @@ * ===================================================================== SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbsv.f b/lapack-netlib/SRC/spbsv.f index 168d3441b5..aab1c74f5b 100644 --- a/lapack-netlib/SRC/spbsv.f +++ b/lapack-netlib/SRC/spbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERsolve * @@ -164,10 +164,10 @@ * ===================================================================== SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbsvx.f b/lapack-netlib/SRC/spbsvx.f index c0dfa99148..c43a079a30 100644 --- a/lapack-netlib/SRC/spbsvx.f +++ b/lapack-netlib/SRC/spbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, * EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -297,10 +297,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -343,7 +343,7 @@ SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/spbtf2.f b/lapack-netlib/SRC/spbtf2.f index 5e8a7747cc..6da0108501 100644 --- a/lapack-netlib/SRC/spbtf2.f +++ b/lapack-netlib/SRC/spbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbtrf.f b/lapack-netlib/SRC/spbtrf.f index fa89fbc0b6..3cd39fa879 100644 --- a/lapack-netlib/SRC/spbtrf.f +++ b/lapack-netlib/SRC/spbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spbtrs.f b/lapack-netlib/SRC/spbtrs.f index 3cc4049ff0..81ddaab9b4 100644 --- a/lapack-netlib/SRC/spbtrs.f +++ b/lapack-netlib/SRC/spbtrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spftrf.f b/lapack-netlib/SRC/spftrf.f index 3d73e0e630..6f48c00bd0 100644 --- a/lapack-netlib/SRC/spftrf.f +++ b/lapack-netlib/SRC/spftrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPFTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPFTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER N, INFO * .. * .. Array Arguments .. * REAL A( 0: * ) -* +* * *> \par Purpose: * ============= @@ -99,12 +99,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -198,10 +198,10 @@ * ===================================================================== SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/spftri.f b/lapack-netlib/SRC/spftri.f index 22634de87c..96c99a0284 100644 --- a/lapack-netlib/SRC/spftri.f +++ b/lapack-netlib/SRC/spftri.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. Array Arguments .. * REAL A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/spftrs.f b/lapack-netlib/SRC/spftrs.f index ff8aa11d30..e6710e2f2e 100644 --- a/lapack-netlib/SRC/spftrs.f +++ b/lapack-netlib/SRC/spftrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPFTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPFTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( 0: * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -199,10 +199,10 @@ * ===================================================================== SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/spocon.f b/lapack-netlib/SRC/spocon.f index b65279381d..c249c3eb33 100644 --- a/lapack-netlib/SRC/spocon.f +++ b/lapack-netlib/SRC/spocon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,14 +30,14 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SPOCON estimates the reciprocal of the condition number (in the +*> SPOCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric positive definite matrix using the *> Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. *> @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * @@ -121,10 +121,10 @@ SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spoequ.f b/lapack-netlib/SRC/spoequ.f index 9a79d5cc5a..f2de64db2f 100644 --- a/lapack-netlib/SRC/spoequ.f +++ b/lapack-netlib/SRC/spoequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/spoequb.f b/lapack-netlib/SRC/spoequb.f index 17be21f76b..e74eefa47c 100644 --- a/lapack-netlib/SRC/spoequb.f +++ b/lapack-netlib/SRC/spoequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -27,14 +27,14 @@ * .. Array Arguments .. * REAL A( LDA, * ), S( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SPOEQU computes row and column scalings intended to equilibrate a +*> SPOEQUB computes row and column scalings intended to equilibrate a *> symmetric positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with @@ -42,6 +42,12 @@ *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. +*> +*> This routine differs from SPOEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled diagonal entries are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: @@ -100,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/sporfs.f b/lapack-netlib/SRC/sporfs.f index 435ce779b0..32a69b0742 100644 --- a/lapack-netlib/SRC/sporfs.f +++ b/lapack-netlib/SRC/sporfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPORFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPORFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * @@ -183,10 +183,10 @@ SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sporfsx.f b/lapack-netlib/SRC/sporfsx.f index 5149fb6ba5..52fab69769 100644 --- a/lapack-netlib/SRC/sporfsx.f +++ b/lapack-netlib/SRC/sporfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPORFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPORFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -379,10 +379,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -394,7 +394,7 @@ SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -455,12 +455,11 @@ SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL SLAMCH, SLANSY, SLA_PORCOND REAL SLAMCH, SLANSY, SLA_PORCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/sposv.f b/lapack-netlib/SRC/sposv.f index 0fdcdb6753..2a9565d85c 100644 --- a/lapack-netlib/SRC/sposv.f +++ b/lapack-netlib/SRC/sposv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOsolve * * ===================================================================== SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sposvx.f b/lapack-netlib/SRC/sposvx.f index 597550a3ff..6051068108 100644 --- a/lapack-netlib/SRC/sposvx.f +++ b/lapack-netlib/SRC/sposvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, * S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -293,10 +293,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -307,7 +307,7 @@ SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/sposvxx.f b/lapack-netlib/SRC/sposvxx.f index 400dec6281..3cdfa749cb 100644 --- a/lapack-netlib/SRC/sposvxx.f +++ b/lapack-netlib/SRC/sposvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -482,10 +482,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -497,7 +497,7 @@ SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/spotf2.f b/lapack-netlib/SRC/spotf2.f index a2ee180e77..4af49997a3 100644 --- a/lapack-netlib/SRC/spotf2.f +++ b/lapack-netlib/SRC/spotf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spotrf.f b/lapack-netlib/SRC/spotrf.f index 4a1e4e3ded..968365c9a2 100644 --- a/lapack-netlib/SRC/spotrf.f +++ b/lapack-netlib/SRC/spotrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spotrf2.f b/lapack-netlib/SRC/spotrf2.f index dfdf16e2ae..6a371b370b 100644 --- a/lapack-netlib/SRC/spotrf2.f +++ b/lapack-netlib/SRC/spotrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,7 +41,7 @@ *> *> The subroutine calls itself to factor A11. Update and scale A21 *> or A12, update A22 then call itself to factor A22. -*> +*> *> \endverbatim * * Arguments: @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -126,7 +126,7 @@ RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) PARAMETER ( ONE = 1.0E+0, ZERO=0.0E+0 ) * .. * .. Local Scalars .. - LOGICAL UPPER + LOGICAL UPPER INTEGER N1, N2, IINFO * .. * .. External Functions .. @@ -134,7 +134,7 @@ RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. - EXTERNAL SGEMM, SSYRK, XERBLA + EXTERNAL SSYRK, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT @@ -189,7 +189,7 @@ RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO RETURN - END IF + END IF * * Compute the Cholesky factorization A = U**T*U * @@ -201,7 +201,7 @@ RECURSIVE SUBROUTINE SPOTRF2( UPLO, N, A, LDA, INFO ) $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) * * Update and factor A22 -* +* CALL SSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) CALL SPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) diff --git a/lapack-netlib/SRC/spotri.f b/lapack-netlib/SRC/spotri.f index 370c9e0cae..bbd504ca28 100644 --- a/lapack-netlib/SRC/spotri.f +++ b/lapack-netlib/SRC/spotri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spotrs.f b/lapack-netlib/SRC/spotrs.f index 6ee53d7c8b..7b2175530a 100644 --- a/lapack-netlib/SRC/spotrs.f +++ b/lapack-netlib/SRC/spotrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPOTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realPOcomputational * * ===================================================================== SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sppcon.f b/lapack-netlib/SRC/sppcon.f index 2bc65076e4..565b6eaff4 100644 --- a/lapack-netlib/SRC/sppcon.f +++ b/lapack-netlib/SRC/sppcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sppequ.f b/lapack-netlib/SRC/sppequ.f index 6d1a3916cd..2b30d333b0 100644 --- a/lapack-netlib/SRC/sppequ.f +++ b/lapack-netlib/SRC/sppequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AP( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spprfs.f b/lapack-netlib/SRC/spprfs.f index c42c5c1d44..760620e0a4 100644 --- a/lapack-netlib/SRC/spprfs.f +++ b/lapack-netlib/SRC/spprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, * BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sppsv.f b/lapack-netlib/SRC/sppsv.f index 820fe381f8..d92c25fc12 100644 --- a/lapack-netlib/SRC/sppsv.f +++ b/lapack-netlib/SRC/sppsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,7 +79,7 @@ *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -*> See below for further details. +*> See below for further details. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, in the same storage @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERsolve * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sppsvx.f b/lapack-netlib/SRC/sppsvx.f index 24144f38ab..021aa6078a 100644 --- a/lapack-netlib/SRC/sppsvx.f +++ b/lapack-netlib/SRC/sppsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, * X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,10 +279,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -312,7 +312,7 @@ SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/spptrf.f b/lapack-netlib/SRC/spptrf.f index 8ce6f05f9f..1134a069d3 100644 --- a/lapack-netlib/SRC/spptrf.f +++ b/lapack-netlib/SRC/spptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spptri.f b/lapack-netlib/SRC/spptri.f index b95f86f3e0..98240789b4 100644 --- a/lapack-netlib/SRC/spptri.f +++ b/lapack-netlib/SRC/spptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPTRI( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spptrs.f b/lapack-netlib/SRC/spptrs.f index 957b3091b9..7eb48eed93 100644 --- a/lapack-netlib/SRC/spptrs.f +++ b/lapack-netlib/SRC/spptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/spstf2.f b/lapack-netlib/SRC/spstf2.f index 12321ad37e..4d15065575 100644 --- a/lapack-netlib/SRC/spstf2.f +++ b/lapack-netlib/SRC/spstf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPSTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPSTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL TOL * INTEGER INFO, LDA, N, RANK @@ -29,7 +29,7 @@ * REAL A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL TOL diff --git a/lapack-netlib/SRC/spstrf.f b/lapack-netlib/SRC/spstrf.f index e0775effd1..f9bc4de089 100644 --- a/lapack-netlib/SRC/spstrf.f +++ b/lapack-netlib/SRC/spstrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPSTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPSTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL TOL * INTEGER INFO, LDA, N, RANK @@ -29,7 +29,7 @@ * REAL A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. REAL TOL diff --git a/lapack-netlib/SRC/sptcon.f b/lapack-netlib/SRC/sptcon.f index 2d2b9b9873..fd11c1d70e 100644 --- a/lapack-netlib/SRC/sptcon.f +++ b/lapack-netlib/SRC/sptcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * REAL ANORM, RCOND @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTcomputational * @@ -118,10 +118,10 @@ * ===================================================================== SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/spteqr.f b/lapack-netlib/SRC/spteqr.f index 5986e09397..be35475f35 100644 --- a/lapack-netlib/SRC/spteqr.f +++ b/lapack-netlib/SRC/spteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,22 +133,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTcomputational * * ===================================================================== SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/sptrfs.f b/lapack-netlib/SRC/sptrfs.f index f39a408ece..c7789c89d8 100644 --- a/lapack-netlib/SRC/sptrfs.f +++ b/lapack-netlib/SRC/sptrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, * BERR, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, LDX, N, NRHS * .. @@ -29,7 +29,7 @@ * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTcomputational * @@ -163,10 +163,10 @@ SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, $ BERR, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, LDX, N, NRHS diff --git a/lapack-netlib/SRC/sptsv.f b/lapack-netlib/SRC/sptsv.f index c0dc904d22..657548e47e 100644 --- a/lapack-netlib/SRC/sptsv.f +++ b/lapack-netlib/SRC/sptsv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * REAL B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTsolve * * ===================================================================== SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/sptsvx.f b/lapack-netlib/SRC/sptsvx.f index 3c35fd97cc..c293e547da 100644 --- a/lapack-netlib/SRC/sptsvx.f +++ b/lapack-netlib/SRC/sptsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTsolve * @@ -228,10 +228,10 @@ SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT diff --git a/lapack-netlib/SRC/spttrf.f b/lapack-netlib/SRC/spttrf.f index 9fa77c2fd7..a3b4c1ba23 100644 --- a/lapack-netlib/SRC/spttrf.f +++ b/lapack-netlib/SRC/spttrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTTRF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * REAL D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SPTTRF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/spttrs.f b/lapack-netlib/SRC/spttrs.f index 7ef2bb3368..2a7f4755d6 100644 --- a/lapack-netlib/SRC/spttrs.f +++ b/lapack-netlib/SRC/spttrs.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * REAL B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTcomputational * * ===================================================================== SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/sptts2.f b/lapack-netlib/SRC/sptts2.f index 3dd6bc699c..ffd73b1e38 100644 --- a/lapack-netlib/SRC/sptts2.f +++ b/lapack-netlib/SRC/sptts2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SPTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SPTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER LDB, N, NRHS * .. * .. Array Arguments .. * REAL B( LDB, * ), D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realPTcomputational * * ===================================================================== SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS diff --git a/lapack-netlib/SRC/srscl.f b/lapack-netlib/SRC/srscl.f index dacc5a7b78..b5168dd885 100644 --- a/lapack-netlib/SRC/srscl.f +++ b/lapack-netlib/SRC/srscl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SRSCL( N, SA, SX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * REAL SA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL SX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * * ===================================================================== SUBROUTINE SRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/ssb2st_kernels.f b/lapack-netlib/SRC/ssb2st_kernels.f new file mode 100644 index 0000000000..7183c9adaf --- /dev/null +++ b/lapack-netlib/SRC/ssb2st_kernels.f @@ -0,0 +1,335 @@ +*> \brief \b SSB2ST_KERNELS +* +* @generated from zhb2st_kernels.f, fortran z -> s, Wed Dec 7 08:22:40 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSB2ST_KERNELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSB2ST_KERNELS( UPLO, WANTZ, TTYPE, +* ST, ED, SWEEP, N, NB, IB, +* A, LDA, V, TAU, LDVT, WORK) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* LOGICAL WANTZ +* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), V( * ), +* TAU( * ), WORK( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSB2ST_KERNELS is an internal routine used by the SSYTRD_SB2ST +*> subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> @param[in] n +*> The order of the matrix A. +*> +*> @param[in] nb +*> The size of the band. +*> +*> @param[in, out] A +*> A pointer to the matrix A. +*> +*> @param[in] lda +*> The leading dimension of the matrix A. +*> +*> @param[out] V +*> REAL array, dimension 2*n if eigenvalues only are +*> requested or to be queried for vectors. +*> +*> @param[out] TAU +*> REAL array, dimension (2*n). +*> The scalar factors of the Householder reflectors are stored +*> in this array. +*> +*> @param[in] st +*> internal parameter for indices. +*> +*> @param[in] ed +*> internal parameter for indices. +*> +*> @param[in] sweep +*> internal parameter for indices. +*> +*> @param[in] Vblksiz +*> internal parameter for indices. +*> +*> @param[in] wantz +*> logical which indicate if Eigenvalue are requested or both +*> Eigenvalue/Eigenvectors. +*> +*> @param[in] work +*> Workspace of size nb. +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSB2ST_KERNELS( UPLO, WANTZ, TTYPE, + $ ST, ED, SWEEP, N, NB, IB, + $ A, LDA, V, TAU, LDVT, WORK) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + LOGICAL WANTZ + INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. + REAL A( LDA, * ), V( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, + $ ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, + $ DPOS, OFDPOS, AJETER + REAL CTMP +* .. +* .. External Subroutines .. + EXTERNAL SLARFG, SLARFX, SLARFY +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. +* .. Executable Statements .. +* + AJETER = IB + LDVT + UPPER = LSAME( UPLO, 'U' ) + + IF( UPPER ) THEN + DPOS = 2 * NB + 1 + OFDPOS = 2 * NB + ELSE + DPOS = 1 + OFDPOS = 2 + ENDIF + +* +* Upper case +* + IF( UPPER ) THEN +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 10 I = 1, LM-1 + V( VPOS+I ) = ( A( OFDPOS-I, ST+I ) ) + A( OFDPOS-I, ST+I ) = ZERO + 10 CONTINUE + CTMP = ( A( OFDPOS, ST ) ) + CALL SLARFG( LM, CTMP, V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) + A( OFDPOS, ST ) = CTMP +* + LM = ED - ST + 1 + CALL SLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.3 ) THEN +* + LM = ED - ST + 1 + CALL SLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 + IF( LM.GT.0) THEN + CALL SLARFX( 'Left', LN, LM, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS-NB, J1 ), LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 30 I = 1, LM-1 + V( VPOS+I ) = + $ ( A( DPOS-NB-I, J1+I ) ) + A( DPOS-NB-I, J1+I ) = ZERO + 30 CONTINUE + CTMP = ( A( DPOS-NB, J1 ) ) + CALL SLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) + A( DPOS-NB, J1 ) = CTMP +* + CALL SLARFX( 'Right', LN-1, LM, V( VPOS ), + $ TAU( TAUPOS ), + $ A( DPOS-NB+1, J1 ), LDA-1, WORK) + ENDIF + ENDIF +* +* Lower case +* + ELSE +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 20 I = 1, LM-1 + V( VPOS+I ) = A( OFDPOS+I, ST-1 ) + A( OFDPOS+I, ST-1 ) = ZERO + 20 CONTINUE + CALL SLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + LM = ED - ST + 1 +* + CALL SLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.3 ) THEN + LM = ED - ST + 1 +* + CALL SLARFY( UPLO, LM, V( VPOS ), 1, + $ ( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 +* + IF( LM.GT.0) THEN + CALL SLARFX( 'Right', LM, LN, V( VPOS ), + $ TAU( TAUPOS ), A( DPOS+NB, ST ), + $ LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 40 I = 1, LM-1 + V( VPOS+I ) = A( DPOS+NB+I, ST ) + A( DPOS+NB+I, ST ) = ZERO + 40 CONTINUE + CALL SLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + CALL SLARFX( 'Left', LM, LN-1, V( VPOS ), + $ ( TAU( TAUPOS ) ), + $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) + + ENDIF + ENDIF + ENDIF +* + RETURN +* +* END OF SSB2ST_KERNELS +* + END diff --git a/lapack-netlib/SRC/ssbev.f b/lapack-netlib/SRC/ssbev.f index d9f67d3215..78fa2ccd27 100644 --- a/lapack-netlib/SRC/ssbev.f +++ b/lapack-netlib/SRC/ssbev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -146,10 +146,10 @@ SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/ssbev_2stage.f b/lapack-netlib/SRC/ssbev_2stage.f new file mode 100644 index 0000000000..f77368ab17 --- /dev/null +++ b/lapack-netlib/SRC/ssbev_2stage.f @@ -0,0 +1,377 @@ +*> \brief SSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from dsbev_2stage.f, fortran d -> s, Sat Nov 5 23:58:09 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSBEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is REAL array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. + REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ, LQUERY + INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSB + EXTERNAL LSAME, SLAMCH, SLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SLASCL, SSCAL, SSTEQR, SSTERF, XERBLA, + $ SSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'SSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -11 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSBEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = AB( 1, 1 ) + ELSE + W( 1 ) = AB( KD+1, 1 ) + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call SSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL SSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of SSBEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssbevd.f b/lapack-netlib/SRC/ssbevd.f index 292bd1c5f8..21fd78ec89 100644 --- a/lapack-netlib/SRC/ssbevd.f +++ b/lapack-netlib/SRC/ssbevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -180,12 +180,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -193,10 +193,10 @@ SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -282,19 +282,19 @@ SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, CALL XERBLA( 'SSBEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN - RETURN + RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) - $ RETURN + $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AB( 1, 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/ssbevd_2stage.f b/lapack-netlib/SRC/ssbevd_2stage.f new file mode 100644 index 0000000000..b1c67d4d97 --- /dev/null +++ b/lapack-netlib/SRC/ssbevd_2stage.f @@ -0,0 +1,412 @@ +*> \brief SSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from dsbevd_2stage.f, fortran d -> s, Sat Nov 5 23:58:03 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSBEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses +*> a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is REAL array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ LLWRK2 + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSB + EXTERNAL LSAME, SLAMCH, SLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SLACPY, SLASCL, SSCAL, SSTEDC, + $ SSTERF, XERBLA, SSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + IB = ILAENV( 18, 'SSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 5*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = MAX( 2*N, N+LHTRD+LWTRD ) + END IF + END IF + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSBEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = AB( 1, 1 ) + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call SSYTRD_SB2ST to reduce band symmetric matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL SSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, + $ ZERO, WORK( INDWK2 ), N ) + CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of SSBEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssbevx.f b/lapack-netlib/SRC/ssbevx.f index 0fa1ac45f6..7eccf611a1 100644 --- a/lapack-netlib/SRC/ssbevx.f +++ b/lapack-netlib/SRC/ssbevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N @@ -32,7 +32,7 @@ * REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -139,13 +142,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -244,12 +251,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -258,10 +265,10 @@ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/ssbevx_2stage.f b/lapack-netlib/SRC/ssbevx_2stage.f new file mode 100644 index 0000000000..1d8f2cc163 --- /dev/null +++ b/lapack-netlib/SRC/ssbevx_2stage.f @@ -0,0 +1,633 @@ +*> \brief SSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @generated from dsbevx_2stage.f, fortran d -> s, Sat Nov 5 23:58:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSBEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, +* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, +* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric band matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is REAL array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is REAL array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N orthogonal matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*SLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*SLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 7*N, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS + 2*N +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup realOTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, + $ LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, + $ LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, + $ LQUERY + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ NSPLIT + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSB + EXTERNAL LSAME, SLAMCH, SLANSB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSCAL, + $ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA, + $ SSYTRD_SB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'SSYTRD_SB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_SB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -20 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSBEVX_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + TMP1 = AB( 1, 1 ) + ELSE + TMP1 = AB( KD+1, 1 ) + END IF + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = TMP1 + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call SSYTRD_SB2ST to reduce symmetric band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDHOUS = INDE + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL SSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call SSTERF or SSTEQR. If this fails for some +* eigenvalue, then try SSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by SSTEIN. +* + DO 20 J = 1, M + CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of SSBEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssbgst.f b/lapack-netlib/SRC/ssbgst.f index a8addb87ee..cf5d512442 100644 --- a/lapack-netlib/SRC/ssbgst.f +++ b/lapack-netlib/SRC/ssbgst.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, * LDX, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N @@ -29,7 +29,7 @@ * REAL AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/ssbgv.f b/lapack-netlib/SRC/ssbgv.f index ae7400fffa..078fb2a2d3 100644 --- a/lapack-netlib/SRC/ssbgv.f +++ b/lapack-netlib/SRC/ssbgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, * LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N @@ -29,7 +29,7 @@ * REAL AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -164,12 +164,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -177,10 +177,10 @@ SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/ssbgvd.f b/lapack-netlib/SRC/ssbgvd.f index b0d48ae93b..0b58760b73 100644 --- a/lapack-netlib/SRC/ssbgvd.f +++ b/lapack-netlib/SRC/ssbgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, * Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -209,12 +209,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -227,10 +227,10 @@ SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -338,7 +338,7 @@ SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, INDWK2 = INDWRK + N*N LLWRK2 = LWORK - INDWK2 + 1 CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, - $ WORK( INDWRK ), IINFO ) + $ WORK, IINFO ) * * Reduce to tridiagonal form. * diff --git a/lapack-netlib/SRC/ssbgvx.f b/lapack-netlib/SRC/ssbgvx.f index b35a7b323b..fe2ea6102b 100644 --- a/lapack-netlib/SRC/ssbgvx.f +++ b/lapack-netlib/SRC/ssbgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, * LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, * LDZ, WORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, @@ -33,7 +33,7 @@ * REAL AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), * $ W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,13 +152,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -166,14 +170,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -266,12 +275,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -285,10 +294,10 @@ SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/ssbtrd.f b/lapack-netlib/SRC/ssbtrd.f index 83bd8b775a..1a016f6774 100644 --- a/lapack-netlib/SRC/ssbtrd.f +++ b/lapack-netlib/SRC/ssbtrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSBTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSBTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KD, LDAB, LDQ, N @@ -29,7 +29,7 @@ * REAL AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/ssfrk.f b/lapack-netlib/SRC/ssfrk.f index 5531ffd7ca..b2cc4fcad7 100644 --- a/lapack-netlib/SRC/ssfrk.f +++ b/lapack-netlib/SRC/ssfrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSFRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSFRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, * C ) -* +* * .. Scalar Arguments .. * REAL ALPHA, BETA * INTEGER K, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -166,10 +166,10 @@ SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, $ C ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL ALPHA, BETA diff --git a/lapack-netlib/SRC/sspcon.f b/lapack-netlib/SRC/sspcon.f index ae2f742b49..9f79b01e31 100644 --- a/lapack-netlib/SRC/sspcon.f +++ b/lapack-netlib/SRC/sspcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -125,10 +125,10 @@ SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sspev.f b/lapack-netlib/SRC/sspev.f index 9f4b4b27aa..ff9ac1d555 100644 --- a/lapack-netlib/SRC/sspev.f +++ b/lapack-netlib/SRC/sspev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * * ===================================================================== SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/sspevd.f b/lapack-netlib/SRC/sspevd.f index aea1e3fbc5..1f407c3c73 100644 --- a/lapack-netlib/SRC/sspevd.f +++ b/lapack-netlib/SRC/sspevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -178,10 +178,10 @@ SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -262,19 +262,19 @@ SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, CALL XERBLA( 'SSPEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN - RETURN + RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) - $ RETURN + $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/sspevx.f b/lapack-netlib/SRC/sspevx.f index 565aedf319..51d4dda143 100644 --- a/lapack-netlib/SRC/sspevx.f +++ b/lapack-netlib/SRC/sspevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDZ, M, N @@ -31,7 +31,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -109,13 +112,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -213,12 +220,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -227,10 +234,10 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/sspgst.f b/lapack-netlib/SRC/sspgst.f index dadd484ce5..1e539e9154 100644 --- a/lapack-netlib/SRC/sspgst.f +++ b/lapack-netlib/SRC/sspgst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), BP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sspgv.f b/lapack-netlib/SRC/sspgv.f index f5025bcc50..bb8279aa17 100644 --- a/lapack-netlib/SRC/sspgv.f +++ b/lapack-netlib/SRC/sspgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, N @@ -29,7 +29,7 @@ * REAL AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -161,10 +161,10 @@ SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/sspgvd.f b/lapack-netlib/SRC/sspgvd.f index 2d50e637ac..f840d7856c 100644 --- a/lapack-netlib/SRC/sspgvd.f +++ b/lapack-netlib/SRC/sspgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N @@ -30,7 +30,7 @@ * REAL AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -210,10 +210,10 @@ SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/sspgvx.f b/lapack-netlib/SRC/sspgvx.f index c95139a62b..ce14b9641a 100644 --- a/lapack-netlib/SRC/sspgvx.f +++ b/lapack-netlib/SRC/sspgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, * IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDZ, M, N @@ -32,7 +32,7 @@ * REAL AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,13 +118,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,14 +136,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -244,12 +253,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -263,10 +272,10 @@ SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/ssprfs.f b/lapack-netlib/SRC/ssprfs.f index 4516e449a1..862dbf3575 100644 --- a/lapack-netlib/SRC/ssprfs.f +++ b/lapack-netlib/SRC/ssprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -179,10 +179,10 @@ SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sspsv.f b/lapack-netlib/SRC/sspsv.f index 87bb84840d..1685af7224 100644 --- a/lapack-netlib/SRC/sspsv.f +++ b/lapack-netlib/SRC/sspsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sspsvx.f b/lapack-netlib/SRC/sspsvx.f index 41ccbf168d..53d0973898 100644 --- a/lapack-netlib/SRC/sspsvx.f +++ b/lapack-netlib/SRC/sspsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/ssptrd.f b/lapack-netlib/SRC/ssptrd.f index 530693e4b1..eebc376d31 100644 --- a/lapack-netlib/SRC/ssptrd.f +++ b/lapack-netlib/SRC/ssptrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), D( * ), E( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -150,10 +150,10 @@ * ===================================================================== SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssptrf.f b/lapack-netlib/SRC/ssptrf.f index 592a0dd04c..dc3b85553d 100644 --- a/lapack-netlib/SRC/ssptrf.f +++ b/lapack-netlib/SRC/ssptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -157,10 +157,10 @@ * ===================================================================== SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssptri.f b/lapack-netlib/SRC/ssptri.f index 0b026e41c4..d62937bf23 100644 --- a/lapack-netlib/SRC/ssptri.f +++ b/lapack-netlib/SRC/ssptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssptrs.f b/lapack-netlib/SRC/ssptrs.f index 782aa8d83f..d1ff03c866 100644 --- a/lapack-netlib/SRC/ssptrs.f +++ b/lapack-netlib/SRC/ssptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/sstebz.f b/lapack-netlib/SRC/sstebz.f index c5263651aa..bcac56a794 100644 --- a/lapack-netlib/SRC/sstebz.f +++ b/lapack-netlib/SRC/sstebz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEBZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEBZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, * M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT @@ -31,7 +31,7 @@ * INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) * REAL D( * ), E( * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,13 +87,18 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. Eigenvalues less than or equal +*> to VL, or greater than VU, will not be returned. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. @@ -102,14 +107,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,12 +259,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup auxOTHERcomputational * @@ -263,10 +273,10 @@ SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE diff --git a/lapack-netlib/SRC/sstedc.f b/lapack-netlib/SRC/sstedc.f index dc4c0f0774..8eb43f530a 100644 --- a/lapack-netlib/SRC/sstedc.f +++ b/lapack-netlib/SRC/sstedc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/sstegr.f b/lapack-netlib/SRC/sstegr.f index d98c451fef..0a28c5843a 100644 --- a/lapack-netlib/SRC/sstegr.f +++ b/lapack-netlib/SRC/sstegr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEGR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEGR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * REAL D( * ), E( * ), W( * ), WORK( * ) * REAL Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,7 +48,7 @@ *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> -*> SSTEGR is a compatability wrapper around the improved SSTEMR routine. +*> SSTEGR is a compatibility wrapper around the improved SSTEMR routine. *> See SSTEMR for further details. *> *> One important change is that the ABSTOL parameter no longer provides any @@ -105,13 +105,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -119,14 +123,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -235,12 +244,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHERcomputational * @@ -256,10 +265,10 @@ SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/sstein.f b/lapack-netlib/SRC/sstein.f index 0eb2f6ebd4..a04b3ae870 100644 --- a/lapack-netlib/SRC/sstein.f +++ b/lapack-netlib/SRC/sstein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDZ, M, N * .. @@ -29,7 +29,7 @@ * $ IWORK( * ) * REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -174,10 +174,10 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N @@ -209,8 +209,8 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * .. * .. External Functions .. INTEGER ISAMAX - REAL SASUM, SDOT, SLAMCH, SNRM2 - EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SNRM2 + REAL SDOT, SLAMCH, SNRM2 + EXTERNAL ISAMAX, SDOT, SLAMCH, SNRM2 * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, diff --git a/lapack-netlib/SRC/sstemr.f b/lapack-netlib/SRC/sstemr.f index 2e995802ec..cff89ef909 100644 --- a/lapack-netlib/SRC/sstemr.f +++ b/lapack-netlib/SRC/sstemr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * LOGICAL TRYRAC @@ -33,7 +33,7 @@ * REAL D( * ), E( * ), W( * ), WORK( * ) * REAL Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,13 +136,17 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -150,14 +154,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -289,12 +298,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup realOTHERcomputational * @@ -312,10 +321,10 @@ SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/ssteqr.f b/lapack-netlib/SRC/ssteqr.f index c9fe9bf033..f776c246df 100644 --- a/lapack-netlib/SRC/ssteqr.f +++ b/lapack-netlib/SRC/ssteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,22 +119,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/ssterf.f b/lapack-netlib/SRC/ssterf.f index 58456e252b..02bf5b9f4b 100644 --- a/lapack-netlib/SRC/ssterf.f +++ b/lapack-netlib/SRC/ssterf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTERF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTERF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTERF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * REAL D( * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -74,22 +74,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE SSTERF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N @@ -189,7 +189,7 @@ SUBROUTINE SSTERF( N, D, E, INFO ) ANORM = SLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) - $ GO TO 10 + $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, diff --git a/lapack-netlib/SRC/sstev.f b/lapack-netlib/SRC/sstev.f index 375722494c..bd62b980a6 100644 --- a/lapack-netlib/SRC/sstev.f +++ b/lapack-netlib/SRC/sstev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * * ===================================================================== SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ diff --git a/lapack-netlib/SRC/sstevd.f b/lapack-netlib/SRC/sstevd.f index c3a1fd3655..7e239a34d5 100644 --- a/lapack-netlib/SRC/sstevd.f +++ b/lapack-netlib/SRC/sstevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHEReigen * @@ -163,10 +163,10 @@ SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ @@ -236,7 +236,7 @@ SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SSTEVD', -INFO ) - RETURN + RETURN ELSE IF( LQUERY ) THEN RETURN END IF @@ -244,12 +244,12 @@ SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * Quick return if possible * IF( N.EQ.0 ) - $ RETURN + $ RETURN * IF( N.EQ.1 ) THEN IF( WANTZ ) $ Z( 1, 1 ) = ONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/sstevr.f b/lapack-netlib/SRC/sstevr.f index e8b52a2210..16635c89b2 100644 --- a/lapack-netlib/SRC/sstevr.f +++ b/lapack-netlib/SRC/sstevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER ISUPPZ( * ), IWORK( * ) * REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -141,13 +144,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -275,12 +282,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -299,10 +306,10 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/sstevx.f b/lapack-netlib/SRC/sstevx.f index 58f86f2e33..bb7b3e5a7f 100644 --- a/lapack-netlib/SRC/sstevx.f +++ b/lapack-netlib/SRC/sstevx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSTEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSTEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, M, N @@ -30,7 +30,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,12 +89,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -102,13 +105,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -207,12 +214,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHEReigen * @@ -220,10 +227,10 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/ssycon.f b/lapack-netlib/SRC/ssycon.f index 7e614cebf1..a0a999cf6a 100644 --- a/lapack-netlib/SRC/ssycon.f +++ b/lapack-netlib/SRC/ssycon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -130,10 +130,10 @@ SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssycon_3.f b/lapack-netlib/SRC/ssycon_3.f new file mode 100644 index 0000000000..74f6761e21 --- /dev/null +++ b/lapack-netlib/SRC/ssycon_3.f @@ -0,0 +1,285 @@ +*> \brief \b SSYCON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYCON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* REAL A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYCON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric matrix A using the factorization +*> computed by DSYTRF_RK or DSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver SSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by SSYTRF_RK and SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_RK or SSYTRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SSYTRS_3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYCON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL SSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DSYCON_3 +* + END diff --git a/lapack-netlib/SRC/ssycon_rook.f b/lapack-netlib/SRC/ssycon_rook.f index c98db4bac9..bd2557a745 100644 --- a/lapack-netlib/SRC/ssycon_rook.f +++ b/lapack-netlib/SRC/ssycon_rook.f @@ -1,26 +1,26 @@ -*> \brief \b SSYCON_ROOK +*> \brief SSYCON_ROOK * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYCON_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ), IWORK( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -130,7 +130,7 @@ * ================== *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -144,10 +144,10 @@ SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssyconv.f b/lapack-netlib/SRC/ssyconv.f index e088ea082c..187528afd9 100644 --- a/lapack-netlib/SRC/ssyconv.f +++ b/lapack-netlib/SRC/ssyconv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYCONV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, WAY * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,7 +36,7 @@ *> \verbatim *> *> SSYCONV convert A given by TRF into L and D and vice-versa. -*> Get Non-diag elements of D (returned in workspace) and +*> Get Non-diag elements of D (returned in workspace) and *> apply or reverse permutation done in TRF. *> \endverbatim * @@ -55,7 +55,7 @@ *> \param[in] WAY *> \verbatim *> WAY is CHARACTER*1 -*> = 'C': Convert +*> = 'C': Convert *> = 'R': Revert *> \endverbatim *> @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, WAY @@ -194,7 +194,7 @@ SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) END DO * * Convert PERMUTATIONS -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0) THEN @@ -226,7 +226,7 @@ SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * * * Revert PERMUTATIONS -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/ssyconvf.f b/lapack-netlib/SRC/ssyconvf.f new file mode 100644 index 0000000000..b9069093e8 --- /dev/null +++ b/lapack-netlib/SRC/ssyconvf.f @@ -0,0 +1,559 @@ +*> \brief \b SSYCONVF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYCONVF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> SSYCONVF converts the factorization output format used in +*> SSYTRF provided on entry in parameter A into the factorization +*> output format used in SSYTRF_RK (or SSYTRF_BK) that is stored +*> on exit in parameters A and E. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in SSYTRF into +*> the format used in SSYTRF_RK (or SSYTRF_BK). +*> +*> If parameter WAY = 'R': +*> SSYCONVF performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in SSYTRF_RK +*> (or SSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in SSYTRF that is stored +*> on exit in parameter A. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in SSYTRF_RK +*> (or SSYTRF_BK) into the format used in SSYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> SSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> SSYTRF_RK or SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> SSYTRF_RK or SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> SSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> +*> 1) If WAY ='C': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in SSYTRF. +*> On exit, details of the interchanges and the block +*> structure of D in the format used in SSYTRF_RK +*> ( or SSYTRF_BK). +*> +*> 1) If WAY ='R': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in SSYTRF_RK +*> ( or SSYTRF_BK). +*> On exit, details of the interchanges and the block +*> structure of D in the format used in SSYTRF. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE SSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL SSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYCONVF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL SSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL SSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i-1 and IPIV(i-1), +* so this should be recorded in two consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I-1 ) +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where k increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL SSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL SSWAP( I-1, A( IP, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i+1 and IPIV(i+1), +* so this should be recorded in consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I+1 ) +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of SSYCONVF +* + END diff --git a/lapack-netlib/SRC/ssyconvf_rook.f b/lapack-netlib/SRC/ssyconvf_rook.f new file mode 100644 index 0000000000..1ed5774fd9 --- /dev/null +++ b/lapack-netlib/SRC/ssyconvf_rook.f @@ -0,0 +1,544 @@ +*> \brief \b SSYCONVF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYCONVF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> SSYCONVF_ROOK converts the factorization output format used in +*> SSYTRF_ROOK provided on entry in parameter A into the factorization +*> output format used in SSYTRF_RK (or SSYTRF_BK) that is stored +*> on exit in parameters A and E. IPIV format for SSYTRF_ROOK and +*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted. +*> +*> If parameter WAY = 'R': +*> SSYCONVF_ROOK performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in SSYTRF_RK +*> (or SSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in SSYTRF_ROOK that is stored +*> on exit in parameter A. IPIV format for SSYTRF_ROOK and +*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> SSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> SSYTRF_RK or SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> SSYTRF_RK or SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> SSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On entry, details of the interchanges and the block +*> structure of D as determined: +*> 1) by SSYTRF_ROOK, if WAY ='C'; +*> 2) by SSYTRF_RK (or SSYTRF_BK), if WAY ='R'. +*> The IPIV format is the same for all these routines. +*> +*> On exit, is not changed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL SSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, IP2 +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYCONVF_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) +* in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + IF( IP2.NE.(I-1) ) THEN + CALL SSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP2, I+1 ), LDA ) + END IF + END IF + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) +* in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP2.NE.(I-1) ) THEN + CALL SSWAP( N-I, A( IP2, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL SSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) +* in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + IF( IP2.NE.(I+1) ) THEN + CALL SSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP2, 1 ), LDA ) + END IF + END IF + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) +* in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP2.NE.(I+1) ) THEN + CALL SSWAP( I-1, A( IP2, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL SSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of SSYCONVF_ROOK +* + END diff --git a/lapack-netlib/SRC/ssyequb.f b/lapack-netlib/SRC/ssyequb.f index b233b35d60..e03f5feb29 100644 --- a/lapack-netlib/SRC/ssyequb.f +++ b/lapack-netlib/SRC/ssyequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * REAL AMAX, SCOND @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), S( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,12 +36,11 @@ *> \verbatim *> *> SSYEQUB computes row and column scalings intended to equilibrate a -*> symmetric matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> symmetric matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -51,30 +50,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> Specifies whether the details of the factorization are stored -*> as an upper or lower triangular matrix. -*> = 'U': Upper triangular, form is A = U*D*U**T; -*> = 'L': Lower triangular, form is A = L*D*L**T. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is REAL array, dimension (LDA,N) -*> The N-by-N symmetric matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N symmetric matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -87,21 +83,21 @@ *> \verbatim *> SCOND is REAL *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is REAL -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (3*N) +*> WORK is REAL array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -115,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -130,15 +126,15 @@ *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n *> DOI 10.1023/B:NUMA.0000016606.32820.69 \n -*> Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 *> * ===================================================================== SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -153,7 +149,7 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * .. Parameters .. REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) INTEGER MAX_ITER PARAMETER ( MAX_ITER = 100 ) * .. @@ -176,19 +172,19 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. * .. Executable Statements .. * -* Test input parameters. +* Test the input parameters. * INFO = 0 IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SSYEQUB', -INFO ) - RETURN + CALL XERBLA( 'SSYEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -197,12 +193,12 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -211,7 +207,7 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) DO I = 1, J-1 S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) - AMAX = MAX( AMAX, ABS( A(I, J) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) END DO S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) AMAX = MAX( AMAX, ABS( A( J, J ) ) ) @@ -228,99 +224,95 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) END DO END IF DO J = 1, N - S( J ) = 1.0 / S( J ) + S( J ) = 1.0E0 / S( J ) END DO - TOL = ONE / SQRT(2.0E0 * N) + TOL = ONE / SQRT( 2.0E0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0 - SUMSQ = 0.0 -* BETA = |A|S - DO I = 1, N - WORK(I) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = ABS( A( I, J ) ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) - DO I = J+1, N - T = ABS( A( I, J ) ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) - END DO - END DO - END IF - -* avg = s^T beta / n - AVG = 0.0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N - - STD = 0.0 - DO I = 2*N+1, 3*N - WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG - END DO - CALL SLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + SCALE = 0.0E0 + SUMSQ = 0.0E0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + END DO + END IF - IF ( STD .LT. TOL * AVG ) GOTO 999 +* avg = s^T beta / n + AVG = 0.0E0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - DO I = 1, N - T = ABS( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG - D = C1*C1 - 4*C0*C2 + STD = 0.0E0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL SLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( STD .LT. TOL * AVG ) GOTO 999 - D = SI - S( I ) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = ABS( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = ABS( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = ABS( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = ABS( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF + DO I = 1, N + T = ABS( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -329,13 +321,13 @@ SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BIGNUM = ONE / SMLNUM SMIN = BIGNUM SMAX = ZERO - T = ONE / SQRT(AVG) + T = ONE / SQRT( AVG ) BASE = SLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) * diff --git a/lapack-netlib/SRC/ssyev.f b/lapack-netlib/SRC/ssyev.f index d9b8ca3127..f3cfd5a1e3 100644 --- a/lapack-netlib/SRC/ssyev.f +++ b/lapack-netlib/SRC/ssyev.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYeigen * * ===================================================================== SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/ssyev_2stage.f b/lapack-netlib/SRC/ssyev_2stage.f new file mode 100644 index 0000000000..0de3ca7e4c --- /dev/null +++ b/lapack-netlib/SRC/ssyev_2stage.f @@ -0,0 +1,348 @@ +*> \brief SSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @generated from dsyev_2stage.f, fortran d -> s, Sat Nov 5 23:55:51 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSY + EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASCL, SORGTR, SSCAL, SSTEQR, SSTERF, + $ XERBLA, SSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL SSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, first call +* SORGTR to generate the orthogonal matrix, then call SSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, WORK( INDE ), INFO ) + ELSE +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + CALL SORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + CALL SSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of SSYEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssyevd.f b/lapack-netlib/SRC/ssyevd.f index 5e78379316..3ba95ca278 100644 --- a/lapack-netlib/SRC/ssyevd.f +++ b/lapack-netlib/SRC/ssyevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,7 @@ *> The dimension of the array WORK. *> If N <= 1, LWORK must be at least 1. *> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. -*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> If JOBZ = 'V' and N > 1, LWORK must be at least *> 1 + 6*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYeigen * @@ -183,10 +183,10 @@ SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -275,7 +275,7 @@ SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, CALL XERBLA( 'SSYEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN - RETURN + RETURN END IF * * Quick return if possible @@ -287,7 +287,7 @@ SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, W( 1 ) = A( 1, 1 ) IF( WANTZ ) $ A( 1, 1 ) = ONE - RETURN + RETURN END IF * * Get machine constants. diff --git a/lapack-netlib/SRC/ssyevd_2stage.f b/lapack-netlib/SRC/ssyevd_2stage.f new file mode 100644 index 0000000000..d65547732d --- /dev/null +++ b/lapack-netlib/SRC/ssyevd_2stage.f @@ -0,0 +1,406 @@ +*> \brief SSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @generated from dsyevd_2stage.f, fortran d -> s, Sat Nov 5 23:55:54 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, +*> dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N+1 +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N+1 +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least +*> 1 + 6*N + 2*N**2. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK and IWORK +*> arrays, returns these values as the first entries of the WORK +*> and IWORK arrays, and no error message related to LWORK or +*> LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYeigen +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA \n +*> Modified by Francoise Tisseur, University of Tennessee \n +*> Modified description of INFO. Sven, 16 Feb 05. \n +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. +* + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, + $ LIWMIN, LLWORK, LLWRK2, LWMIN, + $ LHTRD, LWTRD, KD, IB, INDHOUS + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SLACPY, SLASCL, SORMTR, SSCAL, SSTEDC, SSTERF, + $ SSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LIWMIN = 1 + LWMIN = 1 + ELSE + KD = ILAENV( 17, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LIWMIN = 3 + 5*N + LWMIN = 1 + 6*N + 2*N**2 + ELSE + LIWMIN = 1 + LWMIN = 2*N + 1 + LHTRD + LWTRD + END IF + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL SSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SSTERF. For eigenvectors, first call +* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call SORMTR to multiply it by the +* Householder transformations stored in A. +* + IF( .NOT.WANTZ ) THEN + CALL SSTERF( N, W, WORK( INDE ), INFO ) + ELSE +* Not available in this release, and agrument checking should not +* let it getting here + RETURN + CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) + CALL SORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL SLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( N, ONE / SIGMA, W, 1 ) +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of SSYEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssyevr.f b/lapack-netlib/SRC/ssyevr.f index bfe4258c7e..f24091e6f1 100644 --- a/lapack-netlib/SRC/ssyevr.f +++ b/lapack-netlib/SRC/ssyevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER ISUPPZ( * ), IWORK( * ) * REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -166,13 +169,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,7 +256,9 @@ *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through -*> ISUPPZ( 2*i ). +*> ISUPPZ( 2*i ). This is an output of SSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by SORMTR. *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> @@ -303,12 +312,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup realSYeigen * @@ -327,10 +336,10 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -582,7 +591,7 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * * * Apply orthogonal matrix used in reduction to tridiagonal -* form to eigenvectors returned by SSTEIN. +* form to eigenvectors returned by SSTEMR. * IF( WANTZ .AND. INFO.EQ.0 ) THEN INDWKN = INDE diff --git a/lapack-netlib/SRC/ssyevr_2stage.f b/lapack-netlib/SRC/ssyevr_2stage.f new file mode 100644 index 0000000000..9628a89926 --- /dev/null +++ b/lapack-netlib/SRC/ssyevr_2stage.f @@ -0,0 +1,745 @@ +*> \brief SSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @generated from dsyevr_2stage.f, fortran d -> s, Sat Nov 5 23:50:10 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYEVR_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, +* LWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> SSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call +*> to SSYTRD. Then, whenever possible, SSYEVR_2STAGE calls SSTEMR to compute +*> the eigenspectrum using Relatively Robust Representations. SSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see SSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : SSYEVR_2STAGE calls SSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> SSYEVR_2STAGE calls SSTEBZ and SSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of SSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and +*> SSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> SLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> future releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> Supplying N columns is always safe. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of SSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the orthogonal transformations applied by SORMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 26*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 5*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 5*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal size of the IWORK array, +*> returns this value as the first entry of the IWORK array, and +*> no error message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup realSYeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, + $ LWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, + $ TRYRAC, TEST + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, + $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, + $ LLWORK, LLWRKN, LWMIN, NSPLIT, + $ LHTRD, LWTRD, KD, IB, INDHOUS + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSY + EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN, + $ SSTERF, SSWAP, SSYTRD_2STAGE, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'SSYEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) +* + KD = ILAENV( 17, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 26*N, 5*N + LHTRD + LWTRD ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN +* NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) +* NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) ) +* LWKOPT = MAX( ( NB+1 )*N, LWMIN ) + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYEVR_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 26 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL SSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if SSTERF or SSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the +* elementary reflectors used in SSYTRD. + INDTAU = 1 +* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. + INDD = INDTAU + N +* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from SSYTRD. + INDE = INDD + N +* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over +* -written by SSTEMR (the SSTERF path copies the diagonal to W). + INDDD = INDE + N +* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in SSTERF and SSTEMR. + INDEE = INDDD + N +* INDHOUS is the starting offset Householder storage of stage 2 + INDHOUS = INDEE + N +* INDWK is the starting offset of the left-over workspace, and +* LLWORK is the remaining workspace size. + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* SSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* +* + CALL SSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call SSTERF or SSTEMR and SORMTR. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), + $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, + $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, + $ INFO ) +* +* +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by SSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN +* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are +* undefined. + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. +* Also call SSTEBZ and SSTEIN if SSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by SSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* +* Jump here if SSTEMR/SSTEIN succeeded. + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. +* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do +* not return this detailed information to the user. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + W( I ) = W( J ) + W( J ) = TMP1 + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of SSYEVR_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssyevx.f b/lapack-netlib/SRC/ssyevx.f index cbc8b1d0e1..7a7fac95bb 100644 --- a/lapack-netlib/SRC/ssyevx.f +++ b/lapack-netlib/SRC/ssyevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N @@ -31,7 +31,7 @@ * INTEGER IFAIL( * ), IWORK( * ) * REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,12 +98,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -111,13 +114,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -232,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realSYeigen * @@ -246,10 +253,10 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/ssyevx_2stage.f b/lapack-netlib/SRC/ssyevx_2stage.f new file mode 100644 index 0000000000..fd8518c307 --- /dev/null +++ b/lapack-netlib/SRC/ssyevx_2stage.f @@ -0,0 +1,608 @@ +*> \brief SSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices +* +* @generated from dsyevx_2stage.f, fortran d -> s, Sat Nov 5 23:55:46 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a real symmetric matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is REAL +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*SLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*SLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 8*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 3*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 3*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup realSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + REAL ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, LLWRKN, + $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANSY + EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ, + $ SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA, + $ SSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + KD = ILAENV( 17, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = MAX( 8*N, 3*N + LHTRD + LWTRD ) + WORK( 1 ) = LWMIN + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL SSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDHOUS = INDD + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL SSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call SSTERF or SORGTR and SSTEQR. If this fails for +* some eigenvalue, then try SSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL SLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL SORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* Apply orthogonal matrix used in reduction to tridiagonal +* form to eigenvectors returned by SSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of SSYEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssygs2.f b/lapack-netlib/SRC/ssygs2.f index 33a8c1d17e..addf681215 100644 --- a/lapack-netlib/SRC/ssygs2.f +++ b/lapack-netlib/SRC/ssygs2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssygst.f b/lapack-netlib/SRC/ssygst.f index 1005107486..422475a029 100644 --- a/lapack-netlib/SRC/ssygst.f +++ b/lapack-netlib/SRC/ssygst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssygv.f b/lapack-netlib/SRC/ssygv.f index 7a251637bc..40104241ac 100644 --- a/lapack-netlib/SRC/ssygv.f +++ b/lapack-netlib/SRC/ssygv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYeigen * @@ -175,10 +175,10 @@ SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/ssygv_2stage.f b/lapack-netlib/SRC/ssygv_2stage.f new file mode 100644 index 0000000000..2a376ea3dc --- /dev/null +++ b/lapack-netlib/SRC/ssygv_2stage.f @@ -0,0 +1,371 @@ +*> \brief \b SSYGV_2STAGE +* +* @generated from dsygv_2stage.f, fortran d -> s, Sun Nov 6 12:54:29 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYGV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be symmetric and B is also +*> positive definite. +*> This routine use the 2stage technique for the reduction to tridiagonal +*> which showed higher performance on recent architecture and for large +* sizes N>2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + 2*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + 2*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: SPOTRF or SSYEV returned an error code: +*> <= N: if INFO = i, SSYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER NEIG, + $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SPOTRF, SSYGST, STRMM, STRSM, XERBLA, + $ SSYEV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = 2*N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYGV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL SPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL SSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of SSYGV_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssygvd.f b/lapack-netlib/SRC/ssygvd.f index 1ed45b4806..7e28b0a349 100644 --- a/lapack-netlib/SRC/ssygvd.f +++ b/lapack-netlib/SRC/ssygvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N @@ -29,7 +29,7 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYeigen * @@ -227,10 +227,10 @@ SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/ssygvx.f b/lapack-netlib/SRC/ssygvx.f index bbe9222018..2982e17255 100644 --- a/lapack-netlib/SRC/ssygvx.f +++ b/lapack-netlib/SRC/ssygvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, * VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, * LWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N @@ -32,7 +32,7 @@ * REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,15 @@ *> \param[in] VL *> \verbatim *> VL is REAL +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is REAL -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -144,13 +147,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -271,12 +278,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realSYeigen * @@ -290,10 +297,10 @@ SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/ssyrfs.f b/lapack-netlib/SRC/ssyrfs.f index a7da716bee..5745b72f56 100644 --- a/lapack-netlib/SRC/ssyrfs.f +++ b/lapack-netlib/SRC/ssyrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -178,12 +178,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -191,10 +191,10 @@ SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssyrfsx.f b/lapack-netlib/SRC/ssyrfsx.f index cea4d538d6..b5dd0b2dfe 100644 --- a/lapack-netlib/SRC/ssyrfsx.f +++ b/lapack-netlib/SRC/ssyrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -387,10 +387,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -402,7 +402,7 @@ SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -462,12 +462,11 @@ SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL SLAMCH, SLANSY, SLA_SYRCOND REAL SLAMCH, SLANSY, SLA_SYRCOND LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/ssysv.f b/lapack-netlib/SRC/ssysv.f index 07eb1e2338..e27e5fc83b 100644 --- a/lapack-netlib/SRC/ssysv.f +++ b/lapack-netlib/SRC/ssysv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYsolve * @@ -171,10 +171,10 @@ SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssysv_aa.f b/lapack-netlib/SRC/ssysv_aa.f new file mode 100644 index 0000000000..5221dbad56 --- /dev/null +++ b/lapack-netlib/SRC/ssysv_aa.f @@ -0,0 +1,253 @@ +*> \brief SSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYSV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. The factored +*> form of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> SSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for +*> the best performance, LWORK >= MAX(1,N*NB), where NB is +*> the optimal blocksize for SSYTRF_AA. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYsolve +* +* ===================================================================== + SUBROUTINE SSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_SYTRF, LWKOPT_SYTRS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYTRF, SSYTRS, SSYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL SSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_SYTRF = INT( WORK(1) ) + CALL SSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_SYTRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_SYTRF, LWKOPT_SYTRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYSV_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL SSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL SSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SSYSV_AA +* + END diff --git a/lapack-netlib/SRC/ssysv_rk.f b/lapack-netlib/SRC/ssysv_rk.f new file mode 100644 index 0000000000..9503893251 --- /dev/null +++ b/lapack-netlib/SRC/ssysv_rk.f @@ -0,0 +1,317 @@ +*> \brief SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYSV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYSV_RK computes the solution to a real system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> SSYTRF_RK is called to compute the factorization of a real +*> symmetric matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine SSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by SSYTRF_RK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by SSYTRF_RK. +*> +*> For more info see the description of DSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYTRF_RK, SSYTRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYSV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = P*U*D*(U**T)*(P**T) or +* A = P*U*D*(U**T)*(P**T). +* + CALL SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SSYSV_RK +* + END diff --git a/lapack-netlib/SRC/ssysv_rook.f b/lapack-netlib/SRC/ssysv_rook.f index 6c159338ad..2829f5981b 100644 --- a/lapack-netlib/SRC/ssysv_rook.f +++ b/lapack-netlib/SRC/ssysv_rook.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYSV_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -53,7 +53,7 @@ *> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal *> pivoting method. *> -*> The factored form of A is then used to solve the system +*> The factored form of A is then used to solve the system *> of equations A * X = B by calling SSYTRS_ROOK. *> \endverbatim * @@ -154,7 +154,7 @@ *> The length of WORK. LWORK >= 1, and for best performance *> LWORK >= max(1,N*NB), where NB is the optimal blocksize for *> SSYTRF_ROOK. -*> +*> *> TRS will be done with Level 2 BLAS *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -176,10 +176,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -204,7 +204,7 @@ SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/ssysvx.f b/lapack-netlib/SRC/ssysvx.f index 00e16491fa..3f0983747a 100644 --- a/lapack-netlib/SRC/ssysvx.f +++ b/lapack-netlib/SRC/ssysvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -32,7 +32,7 @@ * REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -270,10 +270,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -284,7 +284,7 @@ SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/ssysvxx.f b/lapack-netlib/SRC/ssysvxx.f index be19e66270..4762748c06 100644 --- a/lapack-netlib/SRC/ssysvxx.f +++ b/lapack-netlib/SRC/ssysvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -493,14 +493,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * -*> \ingroup realSYdriver +*> \ingroup realSYsolve * * ===================================================================== SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, @@ -508,10 +508,10 @@ SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO @@ -553,7 +553,7 @@ SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, REAL SLAMCH, SLA_SYRPVGRW * .. * .. External Subroutines .. - EXTERNAL SSYCON, SSYEQUB, SSYTRF, SSYTRS, + EXTERNAL SSYEQUB, SSYTRF, SSYTRS, $ SLACPY, SLAQSY, XERBLA, SLASCL2, SSYRFSX * .. * .. Intrinsic Functions .. @@ -602,7 +602,7 @@ SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, IF ( RCEQU ) THEN SMIN = BIGNUM SMAX = ZERO - DO 10 J = 1, N + DO 10 J = 1, N SMIN = MIN( SMIN, S( J ) ) SMAX = MAX( SMAX, S( J ) ) 10 CONTINUE diff --git a/lapack-netlib/SRC/ssyswapr.f b/lapack-netlib/SRC/ssyswapr.f index 19007513c1..17ce4dbd9c 100644 --- a/lapack-netlib/SRC/ssyswapr.f +++ b/lapack-netlib/SRC/ssyswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYSWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYSWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * REAL A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYauxiliary * * ===================================================================== SUBROUTINE SSYSWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,12 +136,12 @@ SUBROUTINE SSYSWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL SSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -164,12 +164,12 @@ SUBROUTINE SSYSWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from I1 to I1-1 +* - swap row I1 and I2 from I1 to I1-1 CALL SSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP diff --git a/lapack-netlib/SRC/ssytd2.f b/lapack-netlib/SRC/ssytd2.f index e5e3c2006b..f6d327ccb3 100644 --- a/lapack-netlib/SRC/ssytd2.f +++ b/lapack-netlib/SRC/ssytd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), D( * ), E( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytf2.f b/lapack-netlib/SRC/ssytf2.f index 1ca56621cf..9e31cbb46f 100644 --- a/lapack-netlib/SRC/ssytf2.f +++ b/lapack-netlib/SRC/ssytf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -195,10 +195,10 @@ * ===================================================================== SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytf2_rk.f b/lapack-netlib/SRC/ssytf2_rk.f new file mode 100644 index 0000000000..bf113d1bde --- /dev/null +++ b/lapack-netlib/SRC/ssytf2_rk.f @@ -0,0 +1,943 @@ +*> \brief \b SSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYTF2_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, STEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + REAL SLAMCH + EXTERNAL LSAME, ISAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSWAP, SSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = ZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ISAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ISAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = ABS( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL SSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL SSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL SSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL SSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL SSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = ZERO + A( K-1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = ZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = ZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = ABS( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL SSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL SSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL SSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = ZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = ZERO + A( K+1, K ) = ZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of SSYTF2_RK +* + END diff --git a/lapack-netlib/SRC/ssytrd.f b/lapack-netlib/SRC/ssytrd.f index 765374b7b2..ebfaba7801 100644 --- a/lapack-netlib/SRC/ssytrd.f +++ b/lapack-netlib/SRC/ssytrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * REAL A( LDA, * ), D( * ), E( * ), TAU( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytrd_2stage.f b/lapack-netlib/SRC/ssytrd_2stage.f new file mode 100644 index 0000000000..7bb38c76d5 --- /dev/null +++ b/lapack-netlib/SRC/ssytrd_2stage.f @@ -0,0 +1,337 @@ +*> \brief \b SSYTRD_2STAGE +* +* @generated from zhetrd_2stage.f, fortran z -> s, Sun Nov 6 19:34:06 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, +* HOUS2, LHOUS2, WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER VECT, UPLO +* INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. +* REAL D( * ), E( * ) +* REAL A( LDA, * ), TAU( * ), +* HOUS2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q1**T Q2**T* A * Q2 * Q1 = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> in particular for the second stage (Band to +*> tridiagonal) and thus LHOUS2 is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate Q1 Q2 or to apply Q1 Q2, +*> then LHOUS2 is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the band superdiagonal +*> of A are overwritten by the corresponding elements of the +*> internal band-diagonal matrix AB, and the elements above +*> the KD superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q1 as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and band subdiagonal of A are over- +*> written by the corresponding elements of the internal band-diagonal +*> matrix AB, and the elements below the KD subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q1 as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (N-KD) +*> The scalar factors of the elementary reflectors of +*> the first stage (see Further Details). +*> \endverbatim +*> +*> \param[out] HOUS2 +*> \verbatim +*> HOUS2 is REAL array, dimension LHOUS2, that +*> store the Householder representation of the stage2 +*> band to tridiagonal. +*> \endverbatim +*> +*> \param[in] LHOUS2 +*> \verbatim +*> LHOUS2 is INTEGER +*> The dimension of the array HOUS2. LHOUS2 = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS2 array, returns +*> this value as the first entry of the HOUS2 array, and no error +*> message related to LHOUS2 is issued by XERBLA. +*> LHOUS2 = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, + $ HOUS2, LHOUS2, WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER VECT, UPLO + INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. + REAL D( * ), E( * ) + REAL A( LDA, * ), TAU( * ), + $ HOUS2( * ), WORK( * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTQ + INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYTRD_SY2SB, SSYTRD_SB2ST +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + KD = ILAENV( 17, 'SSYTRD_2STAGE', VECT, N, -1, -1, -1 ) + IB = ILAENV( 18, 'SSYTRD_2STAGE', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'SSYTRD_2STAGE', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'SSYTRD_2STAGE', VECT, N, KD, IB, -1 ) +* WRITE(*,*),'SSYTRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, +* $ LHMIN, LWMIN +* + IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDAB = KD+1 + LWRK = LWORK-LDAB*N + ABPOS = 1 + WPOS = ABPOS + LDAB*N + CALL SSYTRD_SY2SB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, + $ TAU, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRD_SY2SB', -INFO ) + RETURN + END IF + CALL SSYTRD_SB2ST( 'Y', VECT, UPLO, N, KD, + $ WORK( ABPOS ), LDAB, D, E, + $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRD_SB2ST', -INFO ) + RETURN + END IF +* +* + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of SSYTRD_2STAGE +* + END diff --git a/lapack-netlib/SRC/ssytrd_sb2st.F b/lapack-netlib/SRC/ssytrd_sb2st.F new file mode 100644 index 0000000000..c3c4069430 --- /dev/null +++ b/lapack-netlib/SRC/ssytrd_sb2st.F @@ -0,0 +1,556 @@ +*> \brief \b SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRD_SB2ST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, +* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* #if defined(_OPENMP) +* use omp_lib +* #endif +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER STAGE1, UPLO, VECT +* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. +* REAL D( * ), E( * ) +* REAL AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric +*> tridiagonal form T by a orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] STAGE +*> \verbatim +*> STAGE is CHARACTER*1 +*> = 'N': "No": to mention that the stage 1 of the reduction +*> from dense to band using the ssytrd_sy2sb routine +*> was not called before this routine to reproduce AB. +*> In other term this routine is called as standalone. +*> = 'Y': "Yes": to mention that the stage 1 of the +*> reduction from dense to band using the ssytrd_sy2sb +*> routine has been called to produce AB (e.g., AB is +*> the output of ssytrd_sy2sb. +*> \endverbatim +*> +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> and thus LHOUS is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate or to apply Q later on, +*> then LHOUS is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is REAL array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] HOUS +*> \verbatim +*> HOUS is REAL array, dimension LHOUS, that +*> store the Householder representation. +*> \endverbatim +*> +*> \param[in] LHOUS +*> \verbatim +*> LHOUS is INTEGER +*> The dimension of the array HOUS. LHOUS = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS array, returns +*> this value as the first entry of the HOUS array, and no error +*> message related to LHOUS is issued by XERBLA. +*> LHOUS = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup real16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, + $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +#if defined(_OPENMP) + use omp_lib +#endif +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER STAGE1, UPLO, VECT + INTEGER N, KD, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. + REAL D( * ), E( * ) + REAL AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL RZERO + REAL ZERO, ONE + PARAMETER ( RZERO = 0.0E+0, + $ ZERO = 0.0E+0, + $ ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 + INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, + $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, + $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, + $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, + $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, + $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, + $ SISEV, SIZETAU, LDV, LHMIN, LWMIN +* .. +* .. External Subroutines .. + EXTERNAL SSB2ST_KERNELS, SLACPY, SLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX, CEILING, REAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required. +* Test the input parameters +* + DEBUG = 0 + INFO = 0 + AFTERS1 = LSAME( STAGE1, 'Y' ) + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + IB = ILAENV( 18, 'SSYTRD_SB2ST', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'SSYTRD_SB2ST', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'SSYTRD_SB2ST', VECT, N, KD, IB, -1 ) +* + IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.(KD+1) ) THEN + INFO = -7 + ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRD_SB2ST', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDV = KD + IB + SIZETAU = 2 * N + SISEV = 2 * N + INDTAU = 1 + INDV = INDTAU + SIZETAU + LDA = 2 * KD + 1 + SIZEA = LDA * N + INDA = 1 + INDW = INDA + SIZEA + NTHREADS = 1 + TID = 0 +* + IF( UPPER ) THEN + APOS = INDA + KD + AWPOS = INDA + DPOS = APOS + KD + OFDPOS = DPOS - 1 + ABDPOS = KD + 1 + ABOFDPOS = KD + ELSE + APOS = INDA + AWPOS = INDA + KD + 1 + DPOS = APOS + OFDPOS = DPOS + 1 + ABDPOS = 1 + ABOFDPOS = 2 + + ENDIF +* +* Case KD=0: +* The matrix is diagonal. We just copy it (convert to "real" for +* real because D is double and the imaginary part should be 0) +* and store it in D. A sequential code here is better or +* in a parallel environment it might need two cores for D and E +* + IF( KD.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 30 CONTINUE + DO 40 I = 1, N-1 + E( I ) = RZERO + 40 CONTINUE +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Case KD=1: +* The matrix is already Tridiagonal. We have to make diagonal +* and offdiagonal elements real, and store them in D and E. +* For that, for real precision just copy the diag and offdiag +* to D and E while for the COMPLEX case the bulge chasing is +* performed to convert the hermetian tridiagonal to symmetric +* tridiagonal. A simpler coversion formula might be used, but then +* updating the Q matrix will be required and based if Q is generated +* or not this might complicate the story. +* + IF( KD.EQ.1 ) THEN + DO 50 I = 1, N + D( I ) = ( AB( ABDPOS, I ) ) + 50 CONTINUE +* + IF( UPPER ) THEN + DO 60 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I+1 ) ) + 60 CONTINUE + ELSE + DO 70 I = 1, N-1 + E( I ) = ( AB( ABOFDPOS, I ) ) + 70 CONTINUE + ENDIF +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Main code start here. +* Reduce the symmetric band of A to a tridiagonal matrix. +* + THGRSIZ = N + GRSIZ = 1 + SHIFT = 3 + NBTILES = CEILING( REAL(N)/REAL(KD) ) + STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) + THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) +* + CALL SLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) + CALL SLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) +* +* +* openMP parallelisation start here +* +#if defined(_OPENMP) +!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) +!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) +!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) +!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) +!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) +!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT ) +!$OMP MASTER +#endif +* +* main bulge chasing loop +* + DO 100 THGRID = 1, THGRNB + STT = (THGRID-1)*THGRSIZ+1 + THED = MIN( (STT + THGRSIZ -1), (N-1)) + DO 110 I = STT, N-1 + ED = MIN( I, THED ) + IF( STT.GT.ED ) EXIT + DO 120 M = 1, STEPERCOL + ST = STT + DO 130 SWEEPID = ST, ED + DO 140 K = 1, GRSIZ + MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) + $ + (M-1)*GRSIZ + K + IF ( MYID.EQ.1 ) THEN + TTYPE = 1 + ELSE + TTYPE = MOD( MYID, 2 ) + 2 + ENDIF + + IF( TTYPE.EQ.2 ) THEN + COLPT = (MYID/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + BLKLASTIND = COLPT + ELSE + COLPT = ((MYID+1)/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + IF( ( STIND.GE.EDIND-1 ).AND. + $ ( EDIND.EQ.N ) ) THEN + BLKLASTIND = N + ELSE + BLKLASTIND = 0 + ENDIF + ENDIF +* +* Call the kernel +* +#if defined(_OPENMP) + IF( TTYPE.NE.1 ) THEN +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(in:WORK(MYID-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL SSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ELSE +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL SSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ENDIF +#else + CALL SSB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +#endif + IF ( BLKLASTIND.GE.(N-1) ) THEN + STT = STT + 1 + EXIT + ENDIF + 140 CONTINUE + 130 CONTINUE + 120 CONTINUE + 110 CONTINUE + 100 CONTINUE +* +#if defined(_OPENMP) +!$OMP END MASTER +!$OMP END PARALLEL +#endif +* +* Copy the diagonal from A to D. Note that D is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + DO 150 I = 1, N + D( I ) = ( WORK( DPOS+(I-1)*LDA ) ) + 150 CONTINUE +* +* Copy the off diagonal from A to E. Note that E is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + IF( UPPER ) THEN + DO 160 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+I*LDA ) ) + 160 CONTINUE + ELSE + DO 170 I = 1, N-1 + E( I ) = ( WORK( OFDPOS+(I-1)*LDA ) ) + 170 CONTINUE + ENDIF +* + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of SSYTRD_SB2ST +* + END + diff --git a/lapack-netlib/SRC/ssytrd_sy2sb.f b/lapack-netlib/SRC/ssytrd_sy2sb.f new file mode 100644 index 0000000000..a37672eff9 --- /dev/null +++ b/lapack-netlib/SRC/ssytrd_sy2sb.f @@ -0,0 +1,517 @@ +*> \brief \b SSYTRD_SY2SB +* +* @generated from zhetrd_he2hb.f, fortran z -> s, Wed Dec 7 08:22:40 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRD_SY2SB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), AB( LDAB, * ), +* TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric +*> band-diagonal form AB by a orthogonal similarity transformation: +*> Q**T * A * Q = AB. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the reduced matrix if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> The reduced matrix is stored in the array AB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AB +*> \verbatim +*> AB is REAL array, dimension (LDAB,N) +*> On exit, the upper or lower triangle of the symmetric band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (N-KD) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension LWORK. +*> On exit, if INFO = 0, or if LWORK=-1, +*> WORK(1) returns the size of LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK which should be calculated +* by a workspace query. LWORK = MAX(1, LWORK_QUERY) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +*> where FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice otherwise +*> putting LWORK=-1 will provide the size of WORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in +*> A(i,i+kd+1:n), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in +* A(i+kd+2:n,i), and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( ab ab/v1 v1 v1 v1 ) ( ab ) +*> ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) +*> ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) +*> ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) +*> ( ab ) ( v1 v2 v3 ab/v4 ab ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AB( LDAB, * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL RONE + REAL ZERO, ONE, HALF + PARAMETER ( RONE = 1.0E+0, + $ ZERO = 0.0E+0, + $ ONE = 1.0E+0, + $ HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, J, IINFO, LWMIN, PN, PK, LK, + $ LDT, LDW, LDS2, LDS1, + $ LS2, LS1, LW, LT, + $ TPOS, WPOS, S2POS, S1POS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYR2K, SSYMM, SGEMM, + $ SLARFT, SGELQF, SGEQRF, SLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required +* and test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + LWMIN = ILAENV( 20, 'SSYTRD_SY2SB', '', N, KD, -1, -1 ) + + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRD_SY2SB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWMIN + RETURN + END IF +* +* Quick return if possible +* Copy the upper/lower portion of A into AB +* + IF( N.LE.KD+1 ) THEN + IF( UPPER ) THEN + DO 100 I = 1, N + LK = MIN( KD+1, I ) + CALL SCOPY( LK, A( I-LK+1, I ), 1, + $ AB( KD+1-LK+1, I ), 1 ) + 100 CONTINUE + ELSE + DO 110 I = 1, N + LK = MIN( KD+1, N-I+1 ) + CALL SCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) + 110 CONTINUE + ENDIF + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the pointer position for the workspace +* + LDT = KD + LDS1 = KD + LT = LDT*KD + LW = N*KD + LS1 = LDS1*KD + LS2 = LWMIN - LT - LW - LS1 +* LS2 = N*MAX(KD,FACTOPTNB) + TPOS = 1 + WPOS = TPOS + LT + S1POS = WPOS + LW + S2POS = S1POS + LS1 + IF( UPPER ) THEN + LDW = KD + LDS2 = KD + ELSE + LDW = N + LDS2 = N + ENDIF +* +* +* Set the workspace of the triangular matrix T to zero once such a +* way everytime T is generated the upper/lower portion will be always zero +* + CALL SLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) +* + IF( UPPER ) THEN + DO 10 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the LQ factorization of the current block +* + CALL SGELQF( KD, PN, A( I, I+KD ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 20 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL SCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 20 CONTINUE +* + CALL SLASET( 'Lower', PK, PK, ZERO, ONE, + $ A( I, I+KD ), LDA ) +* +* Form the matrix T +* + CALL SLARFT( 'Forward', 'Rowwise', PN, PK, + $ A( I, I+KD ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL SGEMM( 'Conjugate', 'No transpose', PK, PN, PK, + $ ONE, WORK( TPOS ), LDT, + $ A( I, I+KD ), LDA, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL SSYMM( 'Right', UPLO, PK, PN, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL SGEMM( 'No transpose', 'Conjugate', PK, PK, PN, + $ ONE, WORK( WPOS ), LDW, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL SGEMM( 'No transpose', 'No transpose', PK, PN, PK, + $ -HALF, WORK( S1POS ), LDS1, + $ A( I, I+KD ), LDA, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V'*W - W'*V +* + CALL SSYR2K( UPLO, 'Conjugate', PN, PK, + $ -ONE, A( I, I+KD ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) + 10 CONTINUE +* +* Copy the upper band to AB which is the band storage matrix +* + DO 30 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL SCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 30 CONTINUE +* + ELSE +* +* Reduce the lower triangle of A to lower band matrix +* + DO 40 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the QR factorization of the current block +* + CALL SGEQRF( PN, KD, A( I+KD, I ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 50 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL SCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 50 CONTINUE +* + CALL SLASET( 'Upper', PK, PK, ZERO, ONE, + $ A( I+KD, I ), LDA ) +* +* Form the matrix T +* + CALL SLARFT( 'Forward', 'Columnwise', PN, PK, + $ A( I+KD, I ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL SGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ ONE, A( I+KD, I ), LDA, + $ WORK( TPOS ), LDT, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL SSYMM( 'Left', UPLO, PN, PK, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL SGEMM( 'Conjugate', 'No transpose', PK, PK, PN, + $ ONE, WORK( S2POS ), LDS2, + $ WORK( WPOS ), LDW, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL SGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ -HALF, A( I+KD, I ), LDA, + $ WORK( S1POS ), LDS1, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL SSYR2K( UPLO, 'No transpose', PN, PK, + $ -ONE, A( I+KD, I ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) +* ================================================================== +* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED +* DO 45 J = I, I+PK-1 +* LK = MIN( KD, N-J ) + 1 +* CALL SCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) +* 45 CONTINUE +* ================================================================== + 40 CONTINUE +* +* Copy the lower band to AB which is the band storage matrix +* + DO 60 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL SCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 60 CONTINUE + + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of SSYTRD_SY2SB +* + END diff --git a/lapack-netlib/SRC/ssytrf.f b/lapack-netlib/SRC/ssytrf.f index 98693310a7..2c29475df6 100644 --- a/lapack-netlib/SRC/ssytrf.f +++ b/lapack-netlib/SRC/ssytrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -42,7 +42,7 @@ *> A = U*D*U**T or A = L*D*L**T *> *> where U (or L) is a product of permutation and unit upper (lower) -*> triangular matrices, and D is symmetric and block diagonal with +*> triangular matrices, and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> *> This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -182,10 +182,10 @@ * ===================================================================== SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytrf_aa.f b/lapack-netlib/SRC/ssytrf_aa.f new file mode 100644 index 0000000000..98f433afd0 --- /dev/null +++ b/lapack-netlib/SRC/ssytrf_aa.f @@ -0,0 +1,480 @@ +*> \brief \b SSYTRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRF_AA computes the factorization of a real symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a symmetric tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N). For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYcomputational +* +* ===================================================================== + SUBROUTINE SSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + REAL ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL SCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by SLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL SLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL SSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL SCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with SGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL SGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with SGEMM +* + CALL SGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL SCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL SCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by SLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL SLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL SSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL SCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with SGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL SGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with SGEMM +* + CALL SGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL SCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of SSYTRF_AA +* + END diff --git a/lapack-netlib/SRC/ssytrf_rk.f b/lapack-netlib/SRC/ssytrf_rk.f new file mode 100644 index 0000000000..f4221e1e06 --- /dev/null +++ b/lapack-netlib/SRC/ssytrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b SSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYTRF_RK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SLASYF_RK, SSYTF2_RK, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'SSYTRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by SLASYF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL SLASYF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL SSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL SSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by SLASYF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL SLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL SSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL SSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of SSYTRF_RK +* + END diff --git a/lapack-netlib/SRC/ssytrf_rook.f b/lapack-netlib/SRC/ssytrf_rook.f index 6467be4579..534a48e000 100644 --- a/lapack-netlib/SRC/ssytrf_rook.f +++ b/lapack-netlib/SRC/ssytrf_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRF_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup realSYcomputational * @@ -195,7 +195,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> June 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -208,10 +208,10 @@ * ===================================================================== SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -261,7 +261,7 @@ SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'SSYTRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * @@ -321,7 +321,7 @@ SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + $ INFO = IINFO * * No need to adjust IPIV * diff --git a/lapack-netlib/SRC/ssytri.f b/lapack-netlib/SRC/ssytri.f index 0e472449fd..31aa2dd140 100644 --- a/lapack-netlib/SRC/ssytri.f +++ b/lapack-netlib/SRC/ssytri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytri2.f b/lapack-netlib/SRC/ssytri2.f index 882a3be995..7da7eedce3 100644 --- a/lapack-netlib/SRC/ssytri2.f +++ b/lapack-netlib/SRC/ssytri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/ssytri2x.f b/lapack-netlib/SRC/ssytri2x.f index d542142963..c218383a66 100644 --- a/lapack-netlib/SRC/ssytri2x.f +++ b/lapack-netlib/SRC/ssytri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -212,7 +212,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -228,7 +228,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -245,8 +245,8 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K+1,INVD) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K+1,INVD) = -AKKP1 / D K=K+2 END IF END DO @@ -262,7 +262,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -272,7 +272,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -335,7 +335,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**T*invD1*U11->U11 * CALL STRMM('L','U','T','U',NNB, NNB, @@ -345,7 +345,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) DO J=I,NNB A(CUT+I,CUT+J)=WORK(U11+I,J) END DO - END DO + END DO * * U01**T*invD*U01->A(CUT+I,CUT+J) * @@ -379,7 +379,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -389,9 +389,9 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL SSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL SSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -405,7 +405,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -422,8 +422,8 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K-1,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K-1,INVD+1) = -AKKP1 / D K=K-2 END IF END DO @@ -439,7 +439,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -506,7 +506,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**T*invD1*L11->L11 * CALL STRMM('L',UPLO,'T','U',NNB, NNB, @@ -525,7 +525,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL SGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**T*invD1*L11 + U01**T*invD*U01 * @@ -565,7 +565,7 @@ SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/ssytri_3.f b/lapack-netlib/SRC/ssytri_3.f new file mode 100644 index 0000000000..e1ef66ee61 --- /dev/null +++ b/lapack-netlib/SRC/ssytri_3.f @@ -0,0 +1,248 @@ +*> \brief \b SSYTRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYTRI_3 computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> SSYTRI_3 sets the leading dimension of the workspace before calling +*> SSYTRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by SSYTRF_RK and SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_RK or SSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SSYTRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'SSYTRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SSYTRI_3 +* + END diff --git a/lapack-netlib/SRC/ssytri_3x.f b/lapack-netlib/SRC/ssytri_3x.f new file mode 100644 index 0000000000..09c9f93928 --- /dev/null +++ b/lapack-netlib/SRC/ssytri_3x.f @@ -0,0 +1,645 @@ +*> \brief \b SSYTRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYTRI_3X computes the inverse of a real symmetric indefinite +*> matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by SYTRF_RK and SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_RK or SSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + REAL AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J, + $ U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SSYSWAPR, STRTRI, STRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. +* + CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K+1, 1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = WORK( K, INVD+1 ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = ONE + DO J = 1, I-1 + WORK( U11+I, J ) = ZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**T * invD1 * U11 -> U11 +* + CALL STRMM( 'L', 'U', 'T', 'U', NNB, NNB, + $ ONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**T * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL SGEMM( 'T', 'N', NNB, NNB, CUT, ONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, ZERO, WORK(U11+1,1), N+NB+1 ) + +* +* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T * invD0 * U01 +* + CALL STRMM( 'L', UPLO, 'T', 'U', CUT, NNB, + $ ONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**T) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. +* + CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / A( K, K ) + WORK( K, INVD+1 ) = ZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K-1, 1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-ONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = WORK( K, INVD+1 ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**T) = (inv(L))**T +* +* inv(L**T) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = ONE + DO J = I+1, NNB + WORK( U11+I, J ) = ZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**T * invD1 * L11 -> L11 +* + CALL STRMM( 'L', UPLO, 'T', 'U', NNB, NNB, ONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL SGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, ONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ ZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T * invD2 * L21 +* + CALL STRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, ONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**T * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**T) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of SSYTRI_3X +* + END + diff --git a/lapack-netlib/SRC/ssytri_rook.f b/lapack-netlib/SRC/ssytri_rook.f index 0d0dfd98ad..01e4ea1ce3 100644 --- a/lapack-netlib/SRC/ssytri_rook.f +++ b/lapack-netlib/SRC/ssytri_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRI_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,10 +102,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -129,7 +129,7 @@ * ===================================================================== SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -300,7 +300,7 @@ SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) IF( KP.GT.1 ) $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) -* +* TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP @@ -391,7 +391,7 @@ SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) $ SDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 - END IF + END IF * IF( KSTEP.EQ.1 ) THEN * diff --git a/lapack-netlib/SRC/ssytrs.f b/lapack-netlib/SRC/ssytrs.f index fb5f655756..167851adb7 100644 --- a/lapack-netlib/SRC/ssytrs.f +++ b/lapack-netlib/SRC/ssytrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ssytrs2.f b/lapack-netlib/SRC/ssytrs2.f index 0988ae8177..0a1870b206 100644 --- a/lapack-netlib/SRC/ssytrs2.f +++ b/lapack-netlib/SRC/ssytrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,23 +119,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYcomputational * * ===================================================================== - SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -200,7 +200,7 @@ SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**T. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -225,7 +225,7 @@ SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL STRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -277,7 +277,7 @@ SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**T. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -302,7 +302,7 @@ SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL STRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -324,7 +324,7 @@ SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] -* +* CALL STRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/ssytrs_3.f b/lapack-netlib/SRC/ssytrs_3.f new file mode 100644 index 0000000000..bf565704a6 --- /dev/null +++ b/lapack-netlib/SRC/ssytrs_3.f @@ -0,0 +1,371 @@ +*> \brief \b SSYTRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SSYTRS_3 solves a system of linear equations A * X = B with a real +*> symmetric matrix A using the factorization computed +*> by SSYTRF_RK or SSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by SSYTRF_RK and SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_RK or SSYTRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup singleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ==================================================================== + SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + REAL AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSWAP, STRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL STRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL STRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL STRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL STRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of SSYTRS_3 +* + END diff --git a/lapack-netlib/SRC/ssytrs_aa.f b/lapack-netlib/SRC/ssytrs_aa.f new file mode 100644 index 0000000000..6d08473621 --- /dev/null +++ b/lapack-netlib/SRC/ssytrs_aa.f @@ -0,0 +1,294 @@ +*> \brief \b SSYTRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRS_AA solves a system of linear equations A*X = B with a real +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by SSYTRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> Details of factors computed by SSYTRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by SSYTRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup realSYcomputational +* +* ===================================================================== + SUBROUTINE SSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGTSV, SSWAP, STRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL STRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL SLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL SLACPY( 'F', 1, N-1, A(1, 2), LDA+1, WORK(1), 1) + CALL SLACPY( 'F', 1, N-1, A(1, 2), LDA+1, WORK(2*N), 1) + END IF + CALL SGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL STRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL STRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL SLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL SLACPY( 'F', 1, N-1, A(2, 1), LDA+1, WORK(1), 1) + CALL SLACPY( 'F', 1, N-1, A(2, 1), LDA+1, WORK(2*N), 1) + END IF + CALL SGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL STRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + END IF +* + RETURN +* +* End of SSYTRS_AA +* + END diff --git a/lapack-netlib/SRC/ssytrs_rook.f b/lapack-netlib/SRC/ssytrs_rook.f index 240b454b6c..ba2428b51e 100644 --- a/lapack-netlib/SRC/ssytrs_rook.f +++ b/lapack-netlib/SRC/ssytrs_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SSYTRS_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,10 +108,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -136,7 +136,7 @@ SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/stbcon.f b/lapack-netlib/SRC/stbcon.f index 6f1efa14fa..e11c895e1c 100644 --- a/lapack-netlib/SRC/stbcon.f +++ b/lapack-netlib/SRC/stbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -143,10 +143,10 @@ SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/stbrfs.f b/lapack-netlib/SRC/stbrfs.f index 625d21e406..85cd312b58 100644 --- a/lapack-netlib/SRC/stbrfs.f +++ b/lapack-netlib/SRC/stbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL AB( LDAB, * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -175,12 +175,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/stbtrs.f b/lapack-netlib/SRC/stbtrs.f index c0806b998d..4955b7cfc8 100644 --- a/lapack-netlib/SRC/stbtrs.f +++ b/lapack-netlib/SRC/stbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -146,10 +146,10 @@ SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/stfsm.f b/lapack-netlib/SRC/stfsm.f index 74d7540173..b8b81a872b 100644 --- a/lapack-netlib/SRC/stfsm.f +++ b/lapack-netlib/SRC/stfsm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STFSM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STFSM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO * INTEGER LDB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( 0: * ), B( 0: LDB-1, 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -277,10 +277,10 @@ SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, $ B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/stftri.f b/lapack-netlib/SRC/stftri.f index 681fa3b7bb..fa3099d153 100644 --- a/lapack-netlib/SRC/stftri.f +++ b/lapack-netlib/SRC/stftri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO, DIAG * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -201,10 +201,10 @@ * ===================================================================== SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO, DIAG diff --git a/lapack-netlib/SRC/stfttp.f b/lapack-netlib/SRC/stfttp.f index e2dfbbecbf..52e581ddad 100644 --- a/lapack-netlib/SRC/stfttp.f +++ b/lapack-netlib/SRC/stfttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STFTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STFTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,12 +88,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -187,10 +187,10 @@ * ===================================================================== SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/stfttr.f b/lapack-netlib/SRC/stfttr.f index 490778fc81..c7cf06628c 100644 --- a/lapack-netlib/SRC/stfttr.f +++ b/lapack-netlib/SRC/stfttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STFTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STFTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -196,10 +196,10 @@ * ===================================================================== SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/stgevc.f b/lapack-netlib/SRC/stgevc.f index bbf3f8cf74..03d4b7193f 100644 --- a/lapack-netlib/SRC/stgevc.f +++ b/lapack-netlib/SRC/stgevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGEVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGEVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, * LDVL, VR, LDVR, MM, M, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N @@ -30,8 +30,8 @@ * REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -49,20 +49,20 @@ *> *> The right eigenvector x and the left eigenvector y of (S,P) *> corresponding to an eigenvalue w are defined by: -*> +*> *> S*x = w*P*x, (y**H)*S = w*(y**H)*P, -*> +*> *> where y**H denotes the conjugate tranpose of y. *> The eigenvalues are not input to this routine, but are computed *> directly from the diagonal blocks of S and P. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of (S,P), or the products Z*X and/or Q*Y, *> where Z and Q are input matrices. *> If Q and Z are the orthogonal factors from the generalized Schur *> factorization of a matrix pair (A,B), then Z*X and Q*Y *> are the matrices of right and left eigenvectors of (A,B). -*> +*> *> \endverbatim * * Arguments: @@ -179,7 +179,7 @@ *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part and the second the imaginary part. -*> +*> *> Not referenced if SIDE = 'L'. *> \endverbatim *> @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -295,10 +295,10 @@ SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/stgex2.f b/lapack-netlib/SRC/stgex2.f index 0cfc15789a..fc5f9330d9 100644 --- a/lapack-netlib/SRC/stgex2.f +++ b/lapack-netlib/SRC/stgex2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGEX2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGEX2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, J1, N1, N2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 @@ -29,7 +29,7 @@ * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realGEauxiliary * @@ -221,10 +221,10 @@ SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -314,7 +314,7 @@ SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) * -* THRES has been changed from +* THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) diff --git a/lapack-netlib/SRC/stgexc.f b/lapack-netlib/SRC/stgexc.f index 3991fc1543..a1d9dbb56e 100644 --- a/lapack-netlib/SRC/stgexc.f +++ b/lapack-netlib/SRC/stgexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, IFST, ILST, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N @@ -29,7 +29,7 @@ * REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -190,12 +190,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realGEcomputational * @@ -220,10 +220,10 @@ SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ diff --git a/lapack-netlib/SRC/stgsen.f b/lapack-netlib/SRC/stgsen.f index 90e1d94511..5e63a9679e 100644 --- a/lapack-netlib/SRC/stgsen.f +++ b/lapack-netlib/SRC/stgsen.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, * PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, @@ -35,7 +35,7 @@ * $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -299,12 +299,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup realOTHERcomputational * @@ -451,10 +451,10 @@ SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -541,6 +541,7 @@ SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * M = 0 PAIR = .FALSE. + IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. @@ -560,6 +561,7 @@ SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, END IF END IF 10 CONTINUE + END IF * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) ) @@ -800,7 +802,7 @@ SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * 60 CONTINUE * -* Compute generalized eigenvalues of reordered pair (A, B) and +* Compute generalized eigenvalues of reordered pair (A, B) and * normalize the generalized Schur form. * PAIR = .FALSE. diff --git a/lapack-netlib/SRC/stgsja.f b/lapack-netlib/SRC/stgsja.f index 36a06d9884..2a6fc354d2 100644 --- a/lapack-netlib/SRC/stgsja.f +++ b/lapack-netlib/SRC/stgsja.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGSJA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGSJA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, * LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, * Q, LDQ, WORK, NCYCLE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, @@ -33,7 +33,7 @@ * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -345,12 +345,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -378,10 +378,10 @@ SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/stgsna.f b/lapack-netlib/SRC/stgsna.f index 28730987f4..2ff38d1e9d 100644 --- a/lapack-netlib/SRC/stgsna.f +++ b/lapack-netlib/SRC/stgsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, * LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N @@ -32,7 +32,7 @@ * REAL A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -225,12 +225,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -381,10 +381,10 @@ SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/stgsy2.f b/lapack-netlib/SRC/stgsy2.f index bffdf9211a..ca9946a7ed 100644 --- a/lapack-netlib/SRC/stgsy2.f +++ b/lapack-netlib/SRC/stgsy2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGSY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGSY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, * IWORK, PQ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, @@ -33,7 +33,7 @@ * REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. -* +* * *> \par Purpose: * ============= @@ -254,12 +254,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realSYauxiliary * @@ -274,10 +274,10 @@ SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ IWORK, PQ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/stgsyl.f b/lapack-netlib/SRC/stgsyl.f index 44c66bc4d9..cd597f37d4 100644 --- a/lapack-netlib/SRC/stgsyl.f +++ b/lapack-netlib/SRC/stgsyl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STGSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STGSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, @@ -34,7 +34,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -256,12 +256,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -299,10 +299,10 @@ SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/stpcon.f b/lapack-netlib/SRC/stpcon.f index 2e4ce62d2c..2814e691f8 100644 --- a/lapack-netlib/SRC/stpcon.f +++ b/lapack-netlib/SRC/stpcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -130,10 +130,10 @@ SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/stplqt.f b/lapack-netlib/SRC/stplqt.f new file mode 100644 index 0000000000..e3c37abff1 --- /dev/null +++ b/lapack-netlib/SRC/stplqt.f @@ -0,0 +1,270 @@ +*> \brief \b STPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL STPLQT2, STPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL STPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of STPLQT +* + END diff --git a/lapack-netlib/SRC/stplqt2.f b/lapack-netlib/SRC/stplqt2.f new file mode 100644 index 0000000000..f1b8e03034 --- /dev/null +++ b/lapack-netlib/SRC/stplqt2.f @@ -0,0 +1,312 @@ +*> \brief \b STPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download STPLQT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE STPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPLQT2 computes a LQ a factorization of a real "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the lower triangular M-by-M matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,M) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ][ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ][ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L lower trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> +*> C = [ A ][ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ][ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> W = [ V1 ][ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W**T * T * W +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ONE = 1.0, ZERO = 0.0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + REAL ALPHA +* .. +* .. External Subroutines .. + EXTERNAL SLARFG, SGEMV, SGER, STRMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPLQT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, M +* +* Generate elementary reflector H(I) to annihilate B(I,:) +* + P = N-L+MIN( L, I ) + CALL SLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) ) + IF( I.LT.M ) THEN +* +* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] +* + DO J = 1, M-I + T( M, J ) = (A( I+J, I )) + END DO + CALL SGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB, + $ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT ) +* +* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H +* + ALPHA = -(T( 1, I )) + DO J = 1, M-I + A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J )) + END DO + CALL SGER( M-I, P, ALPHA, T( M, 1 ), LDT, + $ B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + END IF + END DO +* + DO I = 2, M +* +* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H) +* + ALPHA = -T( 1, I ) + + DO J = 1, I-1 + T( I, J ) = ZERO + END DO + P = MIN( I-1, L ) + NP = MIN( N-L+1, N ) + MP = MIN( P+1, M ) +* +* Triangular part of B2 +* + DO J = 1, P + T( I, J ) = ALPHA*B( I, N-L+J ) + END DO + CALL STRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB, + $ T( I, 1 ), LDT ) +* +* Rectangular part of B2 +* + CALL SGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB, + $ B( I, NP ), LDB, ZERO, T( I,MP ), LDT ) +* +* B1 +* + CALL SGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB, + $ ONE, T( I, 1 ), LDT ) +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) +* + CALL STRMV( 'L', 'T', 'N', I-1, T, LDT, T( I, 1 ), LDT ) +* +* T(I,I) = tau(I) +* + T( I, I ) = T( 1, I ) + T( 1, I ) = ZERO + END DO + DO I=1,M + DO J= I+1,M + T(I,J)=T(J,I) + T(J,I)= ZERO + END DO + END DO + +* +* End of STPLQT2 +* + END diff --git a/lapack-netlib/SRC/stpmlqt.f b/lapack-netlib/SRC/stpmlqt.f new file mode 100644 index 0000000000..3f8716402f --- /dev/null +++ b/lapack-netlib/SRC/stpmlqt.f @@ -0,0 +1,366 @@ +*> \brief \b DTPMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE STPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. +* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMQRT applies a real orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DTPLQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTPLQT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DTPLQT, stored as a MB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array. The dimension of WORK is +*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] [V2]. +*> +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. + REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, NB, LB, KF, LDAQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'T' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.K ) THEN + INFO = -9 + ELSE IF( LDT.LT.MB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL STPRFB( 'L', 'T', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL STPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL STPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL STPRFB( 'R', 'T', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of STPMLQT +* + END diff --git a/lapack-netlib/SRC/stpmqrt.f b/lapack-netlib/SRC/stpmqrt.f index ccdfcf9241..2a97505b9e 100644 --- a/lapack-netlib/SRC/stpmqrt.f +++ b/lapack-netlib/SRC/stpmqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * A, LDA, B, LDB, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. -* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), +* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> STPMQRT applies a real orthogonal matrix Q obtained from a +*> STPMQRT applies a real orthogonal matrix Q obtained from a *> "triangular-pentagonal" real block reflector H to a general *> real matrix C, which consists of two blocks A and B. *> \endverbatim @@ -69,7 +69,7 @@ *> N is INTEGER *> The number of columns of the matrix B. N >= 0. *> \endverbatim -*> +*> *> \param[in] K *> \verbatim *> K is INTEGER @@ -80,7 +80,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -124,19 +124,19 @@ *> \param[in,out] A *> \verbatim *> A is REAL array, dimension -*> (LDA,N) if SIDE = 'L' or +*> (LDA,N) if SIDE = 'L' or *> (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of +*> On exit, A is overwritten by the corresponding block of *> Q*C or Q^T*C or C*Q or C*Q^T. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -150,7 +150,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -185,20 +185,20 @@ *> \verbatim *> *> The columns of the pentagonal matrix V contain the elementary reflectors -*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a *> trapezoidal block V2: *> *> V = [V1] *> [V2]. *> -*> The size of the trapezoidal block V2 is determined by the parameter L, +*> The size of the trapezoidal block V2 is determined by the parameter L, *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. *> -*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. -*> [B] -*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. +*> [B] +*> *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. *> *> The real orthogonal matrix Q is formed from V and T. @@ -216,17 +216,17 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. - REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), + REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * @@ -242,7 +242,7 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, SLARFB + EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -256,7 +256,7 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF ( LEFT ) THEN LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) @@ -275,7 +275,7 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN - INFO = -6 + INFO = -6 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN @@ -307,11 +307,11 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-M+L-I+1 END IF - CALL STPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL STPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB @@ -322,8 +322,8 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-N+L-I+1 END IF - CALL STPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL STPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * @@ -331,15 +331,15 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 - END IF + END IF CALL STPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * @@ -347,7 +347,7 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 @@ -355,7 +355,7 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, LB = MB-N+L-I+1 END IF CALL STPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * diff --git a/lapack-netlib/SRC/stpqrt.f b/lapack-netlib/SRC/stpqrt.f index 139c1f7370..815d83a6ff 100644 --- a/lapack-netlib/SRC/stpqrt.f +++ b/lapack-netlib/SRC/stpqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> STPQRT computes a blocked QR factorization of a real -*> "triangular-pentagonal" matrix C, which is composed of a -*> triangular block A and pentagonal block B, using the compact +*> STPQRT computes a blocked QR factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact *> WY representation for Q. *> \endverbatim * @@ -46,7 +46,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -88,7 +88,7 @@ *> \param[in,out] B *> \verbatim *> B is REAL array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -105,7 +105,7 @@ *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See Further Details. *> \endverbatim -*> +*> *> \param[in] LDT *> \verbatim *> LDT is INTEGER @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -141,10 +141,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -154,8 +154,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -169,17 +169,17 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> *> The number of blocks is B = ceiling(N/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. @@ -189,10 +189,10 @@ SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -240,7 +240,7 @@ SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, IF( M.EQ.0 .OR. N.EQ.0 ) RETURN * DO I = 1, N, NB -* +* * Compute the QR factorization of the current block * IB = MIN( N-I+1, NB ) @@ -251,20 +251,20 @@ SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, LB = MB-M+L-I+1 END IF * - CALL STPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, + CALL STPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, $ T(1, I ), LDT, IINFO ) * * Update by applying H^H to B(:,I+IB:N) from the left * IF( I+IB.LE.N ) THEN CALL STPRFB( 'L', 'T', 'F', 'C', MB, N-I-IB+1, IB, LB, - $ B( 1, I ), LDB, T( 1, I ), LDT, - $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, + $ B( 1, I ), LDB, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, $ WORK, IB ) END IF END DO RETURN -* +* * End of STPQRT * END diff --git a/lapack-netlib/SRC/stpqrt2.f b/lapack-netlib/SRC/stpqrt2.f index beb2b97dfb..f235712652 100644 --- a/lapack-netlib/SRC/stpqrt2.f +++ b/lapack-netlib/SRC/stpqrt2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> STPQRT2 computes a QR factorization of a real "triangular-pentagonal" -*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> matrix C, which is composed of a triangular block A and pentagonal block B, *> using the compact WY representation for Q. *> \endverbatim * @@ -44,7 +44,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The total number of rows of the matrix B. +*> The total number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -59,7 +59,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The number of rows of the upper trapezoidal part of B. +*> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> @@ -80,7 +80,7 @@ *> \param[in,out] B *> \verbatim *> B is REAL array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -128,10 +128,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -141,8 +141,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -156,12 +156,12 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> The (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W^H @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L @@ -227,7 +227,7 @@ SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) RETURN -* +* DO I = 1, N * * Generate elementary reflector H(I) to annihilate B(:,I) @@ -241,16 +241,16 @@ SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) DO J = 1, N-I T( J, N ) = (A( I, I+J )) END DO - CALL SGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, + CALL SGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) * * C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H * - ALPHA = -(T( I, 1 )) + ALPHA = -(T( I, 1 )) DO J = 1, N-I A( I, I+J ) = A( I, I+J ) + ALPHA*(T( J, N )) END DO - CALL SGER( P, N-I, ALPHA, B( 1, I ), 1, + CALL SGER( P, N-I, ALPHA, B( 1, I ), 1, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO @@ -278,13 +278,13 @@ SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * Rectangular part of B2 * - CALL SGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, + CALL SGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) * * B1 * - CALL SGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, - $ ONE, T( 1, I ), 1 ) + CALL SGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, + $ ONE, T( 1, I ), 1 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * @@ -295,7 +295,7 @@ SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO - + * * End of STPQRT2 * diff --git a/lapack-netlib/SRC/stprfb.f b/lapack-netlib/SRC/stprfb.f index 01383aebca..66e67252f7 100644 --- a/lapack-netlib/SRC/stprfb.f +++ b/lapack-netlib/SRC/stprfb.f @@ -2,44 +2,44 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPRFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPRFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, +* SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. -* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), +* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ V( LDV, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> STPRFB applies a real "triangular-pentagonal" block reflector H or its -*> conjugate transpose H^H to a real matrix C, which is composed of two +*> STPRFB applies a real "triangular-pentagonal" block reflector H or its +*> conjugate transpose H^H to a real matrix C, which is composed of two *> blocks A and B, either from the left or right. -*> +*> *> \endverbatim * * Arguments: @@ -80,14 +80,14 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The number of columns of the matrix B. +*> The number of columns of the matrix B. *> N >= 0. *> \endverbatim *> @@ -95,14 +95,14 @@ *> \verbatim *> K is INTEGER *> The order of the matrix T, i.e. the number of elementary -*> reflectors whose product defines the block reflector. +*> reflectors whose product defines the block reflector. *> K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -129,13 +129,13 @@ *> \verbatim *> T is REAL array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the -*> block reflector. +*> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER -*> The leading dimension of the array T. +*> The leading dimension of the array T. *> LDT >= K. *> \endverbatim *> @@ -144,16 +144,16 @@ *> A is REAL array, dimension *> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of -*> H*C or H^H*C or C*H or C*H^H. See Futher Details. +*> On exit, A is overwritten by the corresponding block of +*> H*C or H^H*C or C*H or C*H^H. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -167,7 +167,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -182,19 +182,19 @@ *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= K; +*> If SIDE = 'L', LDWORK >= K; *> if SIDE = 'R', LDWORK >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERauxiliary * @@ -204,21 +204,21 @@ *> \verbatim *> *> The matrix C is a composite matrix formed from blocks A and B. -*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, +*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, *> and if SIDE = 'L', A is of size K-by-N. *> *> If SIDE = 'R' and DIRECT = 'F', C = [A B]. *> -*> If SIDE = 'L' and DIRECT = 'F', C = [A] +*> If SIDE = 'L' and DIRECT = 'F', C = [A] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] -*> [A]. +*> [A]. *> -*> The pentagonal matrix V is composed of a rectangular block V1 and a -*> trapezoidal block V2. The size of the trapezoidal block is determined by +*> The pentagonal matrix V is composed of a rectangular block V1 and a +*> trapezoidal block V2. The size of the trapezoidal block is determined by *> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; *> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. *> @@ -235,7 +235,7 @@ *> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] -*> +*> *> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) *> *> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. @@ -248,20 +248,20 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, + SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), + REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * @@ -322,7 +322,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END IF * * --------------------------------------------------------------------------- -* +* IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -336,34 +336,34 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W^H or H^H = I - W T^H W^H * * A = A - T (A + V^H B) or A = A - T^H (A + V^H B) -* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) +* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) -* +* DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL STRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( MP, 1 ), LDV, - $ WORK, LDWORK ) - CALL SGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, + $ WORK, LDWORK ) + CALL SGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, $ ONE, WORK, LDWORK ) - CALL SGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, + CALL SGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) -* +* DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL STRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL STRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) @@ -373,7 +373,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL SGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL SGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, - $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL STRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N @@ -383,7 +383,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -402,7 +402,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) @@ -410,20 +410,20 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL STRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) - CALL SGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, + CALL SGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, $ V, LDV, ONE, WORK, LDWORK ) - CALL SGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL SGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL STRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL STRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -443,7 +443,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -457,7 +457,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W^H or H^H = I - W T^H W^H * * A = A - T (A + V^H B) or A = A - T^H (A + V^H B) -* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) +* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) * * --------------------------------------------------------------------------- * @@ -472,10 +472,10 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL STRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) - CALL SGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, + CALL SGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL SGEMM( 'T', 'N', K-L, N, M, ONE, V, LDV, - $ B, LDB, ZERO, WORK, LDWORK ) + $ B, LDB, ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K @@ -483,16 +483,16 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL STRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, + CALL STRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * - CALL SGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, + CALL SGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL SGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) @@ -505,7 +505,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -524,7 +524,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) @@ -532,20 +532,20 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL STRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) - CALL SGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, + CALL SGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) - CALL SGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL SGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V, LDV, ZERO, WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL STRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL STRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -565,7 +565,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -578,7 +578,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W^H T W or H^H = I - W^H T^H W * * A = A - T (A + V B) or A = A - T^H (A + V B) -* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) +* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) * * --------------------------------------------------------------------------- * @@ -589,12 +589,12 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO - END DO + END DO CALL STRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDB ) - CALL SGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, + CALL SGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, $ ONE, WORK, LDWORK ) - CALL SGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, + CALL SGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N @@ -603,7 +603,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL STRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL STRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N @@ -614,7 +614,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL SGEMM( 'T', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) - CALL SGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, + CALL SGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL STRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) @@ -625,7 +625,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -653,7 +653,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ WORK, LDWORK ) CALL SGEMM( 'N', 'T', M, L, N-L, ONE, B, LDB, V, LDV, $ ONE, WORK, LDWORK ) - CALL SGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, + CALL SGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K @@ -662,7 +662,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL STRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL STRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -671,10 +671,10 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL SGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL SGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL SGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, - $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) + $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL STRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L @@ -684,7 +684,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -697,7 +697,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W^H T W or H^H = I - W^H T^H W * * A = A - T (A + V B) or A = A - T^H (A + V B) -* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) +* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) * * --------------------------------------------------------------------------- * @@ -733,10 +733,10 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL SGEMM( 'T', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) - CALL SGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, + CALL SGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL STRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, - $ WORK( KP, 1 ), LDWORK ) + $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) @@ -744,7 +744,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -773,7 +773,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL SGEMM( 'N', 'T', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL SGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, V, LDV, - $ ZERO, WORK, LDWORK ) + $ ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M @@ -781,7 +781,7 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL STRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL STRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -790,9 +790,9 @@ SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL SGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL SGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) - CALL SGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, + CALL SGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL STRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) diff --git a/lapack-netlib/SRC/stprfs.f b/lapack-netlib/SRC/stprfs.f index a8c8b12aea..76ae10dc7c 100644 --- a/lapack-netlib/SRC/stprfs.f +++ b/lapack-netlib/SRC/stprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -175,10 +175,10 @@ SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/stptri.f b/lapack-netlib/SRC/stptri.f index 19790c3c9f..3acc70981b 100644 --- a/lapack-netlib/SRC/stptri.f +++ b/lapack-netlib/SRC/stptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -117,10 +117,10 @@ * ===================================================================== SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/stptrs.f b/lapack-netlib/SRC/stptrs.f index c7e8efc299..fc422c5ed5 100644 --- a/lapack-netlib/SRC/stptrs.f +++ b/lapack-netlib/SRC/stptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/stpttf.f b/lapack-netlib/SRC/stpttf.f index a2c01515c1..230be172f2 100644 --- a/lapack-netlib/SRC/stpttf.f +++ b/lapack-netlib/SRC/stpttf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * REAL AP( 0: * ), ARF( 0: * ) -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -186,10 +186,10 @@ * ===================================================================== SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/stpttr.f b/lapack-netlib/SRC/stpttr.f index 3e0c4f76a1..a58f7f0163 100644 --- a/lapack-netlib/SRC/stpttr.f +++ b/lapack-netlib/SRC/stpttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STPTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STPTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/strcon.f b/lapack-netlib/SRC/strcon.f index 37384e6b5c..ec92b53edb 100644 --- a/lapack-netlib/SRC/strcon.f +++ b/lapack-netlib/SRC/strcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IWORK( * ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -137,10 +137,10 @@ SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/strevc.f b/lapack-netlib/SRC/strevc.f index 2cc7d2588f..37513a37a7 100644 --- a/lapack-netlib/SRC/strevc.f +++ b/lapack-netlib/SRC/strevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STREVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, MM, M, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, M, MM, N @@ -30,7 +30,7 @@ * REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,16 +41,16 @@ *> a real upper quasi-triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. -*> +*> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: -*> -*> T*x = w*x, (y**T)*T = w*(y**T) -*> -*> where y**T denotes the transpose of y. +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal blocks of T. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the orthogonal factor that reduces a matrix @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -222,10 +222,10 @@ SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/strevc3.f b/lapack-netlib/SRC/strevc3.f new file mode 100644 index 0000000000..84a4a8f583 --- /dev/null +++ b/lapack-netlib/SRC/strevc3.f @@ -0,0 +1,1304 @@ +*> \brief \b STREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download STREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE STREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, +* VR, LDVR, MM, M, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STREVC3 computes some or all of the right and/or left eigenvectors of +*> a real upper quasi-triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal blocks of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the orthogonal factor that reduces a matrix +*> A to Schur form T, then Q*X and Q*Y are the matrices of right and +*> left eigenvectors of A. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed by the matrices in VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> If w(j) is a real eigenvalue, the corresponding real +*> eigenvector is computed if SELECT(j) is .TRUE.. +*> If w(j) and w(j+1) are the real and imaginary parts of a +*> complex eigenvalue, the corresponding complex eigenvector is +*> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +*> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +*> .FALSE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is REAL array, dimension (LDT,N) +*> The upper quasi-triangular matrix T in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is REAL array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by SHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part, and the second the imaginary part. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is REAL array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by SHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part and the second the imaginary part. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected real eigenvector occupies one column and each +*> selected complex eigenvector occupies two columns. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,3*N). +*> For optimum performance, LWORK >= N + 2*N*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @generated from dtrevc3.f, fortran d -> s, Tue Apr 19 01:47:44 2016 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, + $ VR, LDVR, MM, M, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER NBMIN, NBMAX + PARAMETER ( NBMIN = 8, NBMAX = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, PAIR, + $ RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, + $ IV, MAXWRK, NB, KI2 + REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX, ILAENV + REAL SDOT, SLAMCH + EXTERNAL LSAME, ISAMAX, ILAENV, SDOT, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SCOPY, SGEMV, SLALN2, SSCAL, XERBLA, + $ SGEMM, SLABAD, SLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + REAL X( 2, 2 ) + INTEGER ISCOMPLEX( NBMAX ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + NB = ILAENV( 1, 'STREVC', SIDE // HOWMNY, N, -1, -1, -1 ) + MAXWRK = N + 2*N*NB + WORK(1) = MAXWRK + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN + INFO = -14 + ELSE +* +* Set M to the number of columns required to store the selected +* eigenvectors, standardize the array SELECT if necessary, and +* test MM. +* + IF( SOMEV ) THEN + M = 0 + PAIR = .FALSE. + DO 10 J = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( J ) = .FALSE. + ELSE + IF( J.LT.N ) THEN + IF( T( J+1, J ).EQ.ZERO ) THEN + IF( SELECT( J ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN + SELECT( J ) = .TRUE. + M = M + 2 + END IF + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -11 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STREVC3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN + NB = (LWORK - N) / (2*N) + NB = MIN( NB, NBMAX ) + CALL SLASET( 'F', N, 1+2*NB, ZERO, ZERO, WORK, N ) + ELSE + NB = 1 + END IF +* +* Set the constants to control overflow. +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 30 J = 2, N + WORK( J ) = ZERO + DO 20 I = 1, J - 1 + WORK( J ) = WORK( J ) + ABS( T( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* +* Index IP is used to specify the real or complex eigenvalue: +* IP = 0, real eigenvalue, +* 1, first of conjugate complex pair: (wr,wi) +* -1, second of conjugate complex pair: (wr,wi) +* ISCOMPLEX array stores IP for each column in current block. +* + IF( RIGHTV ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* For complex right vector, uses IV-1 for real part and IV for complex part. +* Non-blocked version always uses IV=2; +* blocked version starts with IV=NB, goes down to 1 or 2. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 2 + IF( NB.GT.2 ) THEN + IV = NB + END IF + + IP = 0 + IS = M + DO 140 KI = N, 1, -1 + IF( IP.EQ.-1 ) THEN +* previous iteration (ki+1) was second of conjugate pair, +* so this ki is first of conjugate pair; skip to end of loop + IP = 1 + GO TO 140 + ELSE IF( KI.EQ.1 ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI, KI-1 ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is second of conjugate pair + IP = -1 + END IF + + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 140 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 140 + END IF + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* + $ SQRT( ABS( T( KI-1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* -------------------------------------------------------- +* Real right eigenvector +* + WORK( KI + IV*N ) = ONE +* +* Form right-hand side. +* + DO 50 K = 1, KI - 1 + WORK( K + IV*N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve upper quasi-triangular system: +* [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. +* + JNXT = KI - 1 + DO 60 J = KI - 1, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 60 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL SSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+IV*N ), N, WR, ZERO, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(2,1) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 2, 1 ) = X( 2, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL SSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) + WORK( J-1+IV*N ) = X( 1, 1 ) + WORK( J +IV*N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+IV*N ), 1 ) + CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+IV*N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL SCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) +* + II = ISAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / ABS( VR( II, IS ) ) + CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 70 K = KI + 1, N + VR( K, IS ) = ZERO + 70 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.1 ) + $ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1 + IV*N ), 1, WORK( KI + IV*N ), + $ VR( 1, KI ), 1 ) +* + II = ISAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / ABS( VR( II, KI ) ) + CALL SSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + END IF + ELSE +* +* -------------------------------------------------------- +* Complex right eigenvector. +* +* Initial solve +* [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. +* [ ( T(KI, KI-1) T(KI, KI) ) ] +* + IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN + WORK( KI-1 + (IV-1)*N ) = ONE + WORK( KI + (IV )*N ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1 + (IV-1)*N ) = -WI / T( KI, KI-1 ) + WORK( KI + (IV )*N ) = ONE + END IF + WORK( KI + (IV-1)*N ) = ZERO + WORK( KI-1 + (IV )*N ) = ZERO +* +* Form right-hand side. +* + DO 80 K = 1, KI - 2 + WORK( K+(IV-1)*N ) = -WORK( KI-1+(IV-1)*N )*T(K,KI-1) + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(K,KI ) + 80 CONTINUE +* +* Solve upper quasi-triangular system: +* [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) +* + JNXT = KI - 2 + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+(IV-1)*N ), N, + $ WR, WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(1,2) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 1, 2 ) = X( 1, 2 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL SSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) + CALL SSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J+(IV-1)*N ) = X( 1, 1 ) + WORK( J+(IV )*N ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL SLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+(IV-1)*N ), N, WR, WI, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + REC = ONE / XNORM + X( 1, 1 ) = X( 1, 1 )*REC + X( 1, 2 ) = X( 1, 2 )*REC + X( 2, 1 ) = X( 2, 1 )*REC + X( 2, 2 ) = X( 2, 2 )*REC + SCALE = SCALE*REC + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL SSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) + CALL SSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) + END IF + WORK( J-1+(IV-1)*N ) = X( 1, 1 ) + WORK( J +(IV-1)*N ) = X( 2, 1 ) + WORK( J-1+(IV )*N ) = X( 1, 2 ) + WORK( J +(IV )*N ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+(IV-1)*N ), 1 ) + CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+(IV )*N ), 1 ) + CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+(IV )*N ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL SCOPY( KI, WORK( 1+(IV-1)*N ), 1, VR(1,IS-1), 1 ) + CALL SCOPY( KI, WORK( 1+(IV )*N ), 1, VR(1,IS ), 1 ) +* + EMAX = ZERO + DO 100 K = 1, KI + EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ + $ ABS( VR( K, IS ) ) ) + 100 CONTINUE + REMAX = ONE / EMAX + CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) + CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 110 K = KI + 1, N + VR( K, IS-1 ) = ZERO + VR( K, IS ) = ZERO + 110 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.2 ) THEN + CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV-1)*N ), 1, + $ WORK( KI-1 + (IV-1)*N ), VR(1,KI-1), 1) + CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), VR( 1, KI ), 1 ) + ELSE + CALL SSCAL( N, WORK(KI-1+(IV-1)*N), VR(1,KI-1), 1) + CALL SSCAL( N, WORK(KI +(IV )*N), VR(1,KI ), 1) + END IF +* + EMAX = ZERO + DO 120 K = 1, N + EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ + $ ABS( VR( K, KI ) ) ) + 120 CONTINUE + REMAX = ONE / EMAX + CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) + CALL SSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + (IV-1)*N ) = ZERO + WORK( K + (IV )*N ) = ZERO + END DO + ISCOMPLEX( IV-1 ) = -IP + ISCOMPLEX( IV ) = IP + IV = IV - 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI-1 and KI) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI - 1 + END IF + +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.LE.2) .OR. (KI2.EQ.1) ) THEN + CALL SGEMM( 'N', 'N', N, NB-IV+1, KI2+NB-IV, ONE, + $ VR, LDVR, + $ WORK( 1 + (IV)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+IV)*N ), N ) +* normalize vectors + DO K = IV, NB + IF( ISCOMPLEX(K).EQ.0 ) THEN +* real eigenvector + II = ISAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1 ) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL SSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL SLACPY( 'F', N, NB-IV+1, + $ WORK( 1 + (NB+IV)*N ), N, + $ VR( 1, KI2 ), LDVR ) + IV = NB + ELSE + IV = IV - 1 + END IF + END IF ! blocked back-transform +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 140 CONTINUE + END IF + + IF( LEFTV ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* For complex left vector, uses IV for real part and IV+1 for complex part. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB-1 or NB. +* (Note the "0-th" column is used for 1-norms computed above.) + IV = 1 + IP = 0 + IS = 1 + DO 260 KI = 1, N + IF( IP.EQ.1 ) THEN +* previous iteration (ki-1) was first of conjugate pair, +* so this ki is second of conjugate pair; skip to end of loop + IP = -1 + GO TO 260 + ELSE IF( KI.EQ.N ) THEN +* last column, so this ki must be real eigenvalue + IP = 0 + ELSE IF( T( KI+1, KI ).EQ.ZERO ) THEN +* zero on sub-diagonal, so this ki is real eigenvalue + IP = 0 + ELSE +* non-zero on sub-diagonal, so this ki is first of conjugate pair + IP = 1 + END IF +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 260 + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* + $ SQRT( ABS( T( KI+1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* -------------------------------------------------------- +* Real left eigenvector +* + WORK( KI + IV*N ) = ONE +* +* Form right-hand side. +* + DO 160 K = KI + 1, N + WORK( K + IV*N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 1 + DO 170 J = KI + 1, N + IF( J.LT.JNXT ) + $ GO TO 170 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL SSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ SDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve [ T(J,J) - WR ]**T * X = WORK +* + CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J+IV*N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+IV*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL SSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+IV*N ) = WORK( J+IV*N ) - + $ SDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* + WORK( J+1+IV*N ) = WORK( J+1+IV*N ) - + $ SDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+IV*N ), 1 ) +* +* Solve +* [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) +* [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) +* + CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) + WORK( J +IV*N ) = X( 1, 1 ) + WORK( J+1+IV*N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J +IV*N ) ), + $ ABS( WORK( J+1+IV*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL SCOPY( N-KI+1, WORK( KI + IV*N ), 1, + $ VL( KI, IS ), 1 ) +* + II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / ABS( VL( II, IS ) ) + CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 180 K = 1, KI - 1 + VL( K, IS ) = ZERO + 180 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N ) + $ CALL SGEMV( 'N', N, N-KI, ONE, + $ VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 + IV*N ), 1, + $ WORK( KI + IV*N ), VL( 1, KI ), 1 ) +* + II = ISAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / ABS( VL( II, KI ) ) + CALL SSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + IV*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP +* back-transform and normalization is done below + END IF + ELSE +* +* -------------------------------------------------------- +* Complex left eigenvector. +* +* Initial solve: +* [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. +* [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] +* + IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN + WORK( KI + (IV )*N ) = WI / T( KI, KI+1 ) + WORK( KI+1 + (IV+1)*N ) = ONE + ELSE + WORK( KI + (IV )*N ) = ONE + WORK( KI+1 + (IV+1)*N ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1 + (IV )*N ) = ZERO + WORK( KI + (IV+1)*N ) = ZERO +* +* Form right-hand side. +* + DO 190 K = KI + 2, N + WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(KI, K) + WORK( K+(IV+1)*N ) = -WORK( KI+1+(IV+1)*N )*T(KI+1,K) + 190 CONTINUE +* +* Solve transposed quasi-triangular system: +* [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 2 + DO 200 J = KI + 2, N + IF( J.LT.JNXT ) + $ GO TO 200 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when +* forming the right-hand side elements. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL SSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) + CALL SSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+(IV )*N ) = WORK( J+(IV)*N ) - + $ SDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) + WORK( J+(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ SDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* +* Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 +* + CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL SSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) + CALL SSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J+(IV )*N ) = X( 1, 1 ) + WORK( J+(IV+1)*N ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+(IV )*N ) ), + $ ABS( WORK( J+(IV+1)*N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side elements. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL SSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) + CALL SSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J +(IV )*N ) = WORK( J+(IV)*N ) - + $ SDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J +(IV+1)*N ) = WORK( J+(IV+1)*N ) - + $ SDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* + WORK( J+1+(IV )*N ) = WORK( J+1+(IV)*N ) - + $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV)*N ), 1 ) +* + WORK( J+1+(IV+1)*N ) = WORK( J+1+(IV+1)*N ) - + $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+(IV+1)*N ), 1 ) +* +* Solve 2-by-2 complex linear equation +* [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B +* [ (T(j+1,j) T(j+1,j+1)) ] +* + CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL SSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) + CALL SSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) + END IF + WORK( J +(IV )*N ) = X( 1, 1 ) + WORK( J +(IV+1)*N ) = X( 1, 2 ) + WORK( J+1+(IV )*N ) = X( 2, 1 ) + WORK( J+1+(IV+1)*N ) = X( 2, 2 ) + VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), + $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), + $ VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 200 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL SCOPY( N-KI+1, WORK( KI + (IV )*N ), 1, + $ VL( KI, IS ), 1 ) + CALL SCOPY( N-KI+1, WORK( KI + (IV+1)*N ), 1, + $ VL( KI, IS+1 ), 1 ) +* + EMAX = ZERO + DO 220 K = KI, N + EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ + $ ABS( VL( K, IS+1 ) ) ) + 220 CONTINUE + REMAX = ONE / EMAX + CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) + CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) +* + DO 230 K = 1, KI - 1 + VL( K, IS ) = ZERO + VL( K, IS+1 ) = ZERO + 230 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N-1 ) THEN + CALL SGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV)*N ), 1, + $ WORK( KI + (IV)*N ), + $ VL( 1, KI ), 1 ) + CALL SGEMV( 'N', N, N-KI-1, ONE, + $ VL( 1, KI+2 ), LDVL, + $ WORK( KI+2 + (IV+1)*N ), 1, + $ WORK( KI+1 + (IV+1)*N ), + $ VL( 1, KI+1 ), 1 ) + ELSE + CALL SSCAL( N, WORK(KI+ (IV )*N), VL(1, KI ), 1) + CALL SSCAL( N, WORK(KI+1+(IV+1)*N), VL(1, KI+1), 1) + END IF +* + EMAX = ZERO + DO 240 K = 1, N + EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ + $ ABS( VL( K, KI+1 ) ) ) + 240 CONTINUE + REMAX = ONE / EMAX + CALL SSCAL( N, REMAX, VL( 1, KI ), 1 ) + CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + (IV )*N ) = ZERO + WORK( K + (IV+1)*N ) = ZERO + END DO + ISCOMPLEX( IV ) = IP + ISCOMPLEX( IV+1 ) = -IP + IV = IV + 1 +* back-transform and normalization is done below + END IF + END IF + + IF( NB.GT.1 ) THEN +* -------------------------------------------------------- +* Blocked version of back-transform +* For complex case, KI2 includes both vectors (KI and KI+1) + IF( IP.EQ.0 ) THEN + KI2 = KI + ELSE + KI2 = KI + 1 + END IF + +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB-1 or NB, +* or if this was last vector, do the GEMM + IF( (IV.GE.NB-1) .OR. (KI2.EQ.N) ) THEN + CALL SGEMM( 'N', 'N', N, IV, N-KI2+IV, ONE, + $ VL( 1, KI2-IV+1 ), LDVL, + $ WORK( KI2-IV+1 + (1)*N ), N, + $ ZERO, + $ WORK( 1 + (NB+1)*N ), N ) +* normalize vectors + DO K = 1, IV + IF( ISCOMPLEX(K).EQ.0) THEN +* real eigenvector + II = ISAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) + ELSE IF( ISCOMPLEX(K).EQ.1) THEN +* first eigenvector of conjugate pair + EMAX = ZERO + DO II = 1, N + EMAX = MAX( EMAX, + $ ABS( WORK( II + (NB+K )*N ) )+ + $ ABS( WORK( II + (NB+K+1)*N ) ) ) + END DO + REMAX = ONE / EMAX +* else if ISCOMPLEX(K).EQ.-1 +* second eigenvector of conjugate pair +* reuse same REMAX as previous K + END IF + CALL SSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL SLACPY( 'F', N, IV, + $ WORK( 1 + (NB+1)*N ), N, + $ VL( 1, KI2-IV+1 ), LDVL ) + IV = 1 + ELSE + IV = IV + 1 + END IF + END IF ! blocked back-transform +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 260 CONTINUE + END IF +* + RETURN +* +* End of STREVC3 +* + END diff --git a/lapack-netlib/SRC/strexc.f b/lapack-netlib/SRC/strexc.f index 3e2ca3b89b..8aaaccd4ac 100644 --- a/lapack-netlib/SRC/strexc.f +++ b/lapack-netlib/SRC/strexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STREXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -63,6 +63,7 @@ *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. *> \endverbatim *> *> \param[in,out] T @@ -92,7 +93,8 @@ *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] IFST @@ -133,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -146,10 +148,10 @@ SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ @@ -193,9 +195,9 @@ SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN diff --git a/lapack-netlib/SRC/strrfs.f b/lapack-netlib/SRC/strrfs.f index e04f3d49bd..9b21910af5 100644 --- a/lapack-netlib/SRC/strrfs.f +++ b/lapack-netlib/SRC/strrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/strsen.f b/lapack-netlib/SRC/strsen.f index 593dd70b03..a52c627728 100644 --- a/lapack-netlib/SRC/strsen.f +++ b/lapack-netlib/SRC/strsen.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, * M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, JOB * INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), * $ WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -226,10 +226,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -314,7 +314,7 @@ SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/strsna.f b/lapack-netlib/SRC/strsna.f index e53205cd75..1dc7fe74cf 100644 --- a/lapack-netlib/SRC/strsna.f +++ b/lapack-netlib/SRC/strsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N @@ -32,7 +32,7 @@ * REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -208,12 +208,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -265,10 +265,10 @@ SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/strsyl.f b/lapack-netlib/SRC/strsyl.f index db8649eaf3..029367ce6a 100644 --- a/lapack-netlib/SRC/strsyl.f +++ b/lapack-netlib/SRC/strsyl.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, * LDC, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANA, TRANB * INTEGER INFO, ISGN, LDA, LDB, LDC, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realSYcomputational * @@ -164,10 +164,10 @@ SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB diff --git a/lapack-netlib/SRC/strti2.f b/lapack-netlib/SRC/strti2.f index 20eea39712..e3de4a306b 100644 --- a/lapack-netlib/SRC/strti2.f +++ b/lapack-netlib/SRC/strti2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/strtri.f b/lapack-netlib/SRC/strtri.f index d9dbf845bd..267de1a2fd 100644 --- a/lapack-netlib/SRC/strtri.f +++ b/lapack-netlib/SRC/strtri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/strtrs.f b/lapack-netlib/SRC/strtrs.f index 51c6a4ed0e..9eb6e3693f 100644 --- a/lapack-netlib/SRC/strtrs.f +++ b/lapack-netlib/SRC/strtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -140,10 +140,10 @@ SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/strttf.f b/lapack-netlib/SRC/strttf.f index c42ea20024..5853be902a 100644 --- a/lapack-netlib/SRC/strttf.f +++ b/lapack-netlib/SRC/strttf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * @@ -194,10 +194,10 @@ * ===================================================================== SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/strttp.f b/lapack-netlib/SRC/strttp.f index 4b2391bbd3..c51a528909 100644 --- a/lapack-netlib/SRC/strttp.f +++ b/lapack-netlib/SRC/strttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STRTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STRTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup realOTHERcomputational * * ===================================================================== SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/stzrzf.f b/lapack-netlib/SRC/stzrzf.f index 9b2b498cc6..6da3c4a0e8 100644 --- a/lapack-netlib/SRC/stzrzf.f +++ b/lapack-netlib/SRC/stzrzf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download STZRZF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download STZRZF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,10 +111,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -142,7 +142,7 @@ *> *> V = ( I A(:,M+1:N) ) *> -*> I is the M-by-M identity matrix, A(:,M+1:N) +*> I is the M-by-M identity matrix, A(:,M+1:N) *> is the output stored in A on exit from DTZRZF, *> and tau(k) is the kth element of the array TAU. *> @@ -151,7 +151,7 @@ * ===================================================================== SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/xerbla.f b/lapack-netlib/SRC/xerbla.f index 3e93bc4e0e..4a0350988c 100644 --- a/lapack-netlib/SRC/xerbla.f +++ b/lapack-netlib/SRC/xerbla.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download XERBLA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. -* +* * *> \par Purpose: * ============= @@ -58,22 +58,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*(*) SRNAME diff --git a/lapack-netlib/SRC/xerbla_array.f b/lapack-netlib/SRC/xerbla_array.f index a1307cadc5..84fe7de9d8 100644 --- a/lapack-netlib/SRC/xerbla_array.f +++ b/lapack-netlib/SRC/xerbla_array.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download XERBLA_ARRAY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download XERBLA_ARRAY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO) -* +* * .. Scalar Arguments .. * INTEGER SRNAME_LEN, INFO * .. * .. Array Arguments .. * CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup auxOTHERauxiliary +*> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER SRNAME_LEN, INFO diff --git a/lapack-netlib/SRC/zbbcsd.f b/lapack-netlib/SRC/zbbcsd.f index 0d6e218bb7..51e148b420 100644 --- a/lapack-netlib/SRC/zbbcsd.f +++ b/lapack-netlib/SRC/zbbcsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZBBCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZBBCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, * V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, * B22D, B22E, RWORK, LRWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LRWORK, M, P, Q @@ -34,7 +34,7 @@ * COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,7 +149,7 @@ *> \param[in,out] U1 *> \verbatim *> U1 is COMPLEX*16 array, dimension (LDU1,P) -*> On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied +*> On entry, a P-by-P matrix. On exit, U1 is postmultiplied *> by the left singular vector matrix common to [ B11 ; 0 ] and *> [ B12 0 0 ; 0 -I 0 0 ]. *> \endverbatim @@ -157,13 +157,13 @@ *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER -*> The leading dimension of the array U1. +*> The leading dimension of the array U1, LDU1 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] U2 *> \verbatim *> U2 is COMPLEX*16 array, dimension (LDU2,M-P) -*> On entry, an LDU2-by-(M-P) matrix. On exit, U2 is +*> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is *> postmultiplied by the left singular vector matrix common to *> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. *> \endverbatim @@ -171,13 +171,13 @@ *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER -*> The leading dimension of the array U2. +*> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] V1T *> \verbatim *> V1T is COMPLEX*16 array, dimension (LDV1T,Q) -*> On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied +*> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied *> by the conjugate transpose of the right singular vector *> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. *> \endverbatim @@ -185,13 +185,13 @@ *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER -*> The leading dimension of the array V1T. +*> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). *> \endverbatim *> *> \param[in,out] V2T *> \verbatim *> V2T is COMPLEX*16 array, dimenison (LDV2T,M-Q) -*> On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is +*> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is *> premultiplied by the conjugate transpose of the right *> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and *> [ B22 0 0 ; 0 0 I ]. @@ -200,7 +200,7 @@ *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER -*> The leading dimension of the array V2T. +*> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). *> \endverbatim *> *> \param[out] B11D @@ -273,8 +273,8 @@ *> *> \param[out] RWORK *> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. *> \endverbatim *> *> \param[in] LRWORK @@ -317,12 +317,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -332,10 +332,10 @@ SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS diff --git a/lapack-netlib/SRC/zbdsqr.f b/lapack-netlib/SRC/zbdsqr.f index 927fdb7209..66281bb8b3 100644 --- a/lapack-netlib/SRC/zbdsqr.f +++ b/lapack-netlib/SRC/zbdsqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZBDSQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ), RWORK( * ) * COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,9 +40,9 @@ *> left singular vectors from the singular value decomposition (SVD) of *> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit *> zero-shift QR algorithm. The SVD of B has the form -*> +*> *> B = Q * S * P**H -*> +*> *> where S is the diagonal matrix of singular values, Q is an orthogonal *> matrix of left singular vectors, and P is an orthogonal matrix of *> right singular vectors. If left singular vectors are requested, this @@ -51,9 +51,9 @@ *> P**H, for given complex input matrices U and VT. When U and VT are *> the unitary matrices that reduce a general matrix A to bidiagonal *> form: A = U*B*VT, as computed by ZGEBRD, then -*> +*> *> A = (U*Q) * S * (P**H*VT) -*> +*> *> is the SVD of A. Optionally, the subroutine may also compute Q**H*C *> for a given complex input matrix C. *> @@ -209,12 +209,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -222,10 +222,10 @@ SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -321,7 +321,7 @@ SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, CALL DLASQ1( N, D, E, RWORK, INFO ) * * If INFO equals 2, dqds didn't finish, try to finish -* +* IF( INFO .NE. 2 ) RETURN INFO = 0 END IF diff --git a/lapack-netlib/SRC/zcgesv.f b/lapack-netlib/SRC/zcgesv.f index d7d0a9d285..8240e2b659 100644 --- a/lapack-netlib/SRC/zcgesv.f +++ b/lapack-netlib/SRC/zcgesv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZCGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZCGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, * SWORK, RWORK, ITER, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS * .. @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,7 +170,7 @@ *> -3 : failure of CGETRF *> -31: stop the iterative refinement after the 30th *> iterations -*> > 0: iterative refinement has been sucessfully used. +*> > 0: iterative refinement has been successfully used. *> Returns the number of iterations *> \endverbatim *> @@ -188,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16GEsolve * @@ -201,10 +201,10 @@ SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, $ SWORK, RWORK, ITER, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS diff --git a/lapack-netlib/SRC/zcposv.f b/lapack-netlib/SRC/zcposv.f index dfa114d96d..3159c3dd98 100644 --- a/lapack-netlib/SRC/zcposv.f +++ b/lapack-netlib/SRC/zcposv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZCPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZCPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, * SWORK, RWORK, ITER, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -178,7 +178,7 @@ *> -3 : failure of CPOTRF *> -31: stop the iterative refinement after the 30th *> iterations -*> > 0: iterative refinement has been sucessfully used. +*> > 0: iterative refinement has been successfully used. *> Returns the number of iterations *> \endverbatim *> @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16POsolve * @@ -209,10 +209,10 @@ SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, $ SWORK, RWORK, ITER, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zdrscl.f b/lapack-netlib/SRC/zdrscl.f index 94ba393442..03b87d4093 100644 --- a/lapack-netlib/SRC/zdrscl.f +++ b/lapack-netlib/SRC/zdrscl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZDRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZDRSCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZDRSCL( N, SA, SX, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 SX( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/zgbbrd.f b/lapack-netlib/SRC/zgbbrd.f index cc85fb6149..e299824063 100644 --- a/lapack-netlib/SRC/zgbbrd.f +++ b/lapack-netlib/SRC/zgbbrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, * LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC @@ -30,7 +30,7 @@ * COMPLEX*16 AB( LDAB, * ), C( LDC, * ), PT( LDPT, * ), * $ Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -180,12 +180,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -193,10 +193,10 @@ SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER VECT diff --git a/lapack-netlib/SRC/zgbcon.f b/lapack-netlib/SRC/zgbcon.f index 1c1e5c20fd..6d7c8d829b 100644 --- a/lapack-netlib/SRC/zgbcon.f +++ b/lapack-netlib/SRC/zgbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, KL, KU, LDAB, N @@ -31,7 +31,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -147,10 +147,10 @@ SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zgbequ.f b/lapack-netlib/SRC/zgbequ.f index a5cb5124f7..e8938855f8 100644 --- a/lapack-netlib/SRC/zgbequ.f +++ b/lapack-netlib/SRC/zgbequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -154,10 +154,10 @@ SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/zgbequb.f b/lapack-netlib/SRC/zgbequb.f index 3dce529cd6..4b08ac1d45 100644 --- a/lapack-netlib/SRC/zgbequb.f +++ b/lapack-netlib/SRC/zgbequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,9 +49,9 @@ *> number of A but works well in practice. *> *> This routine differs from ZGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -84,7 +84,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> AB is COMPLEX*16 array, dimension (LDAB,N) *> On entry, the matrix A in band storage, in rows 1 to KL+KU+1. *> The j-th column of A is stored in the j-th column of the *> array AB as follows: @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16GBcomputational * @@ -161,10 +161,10 @@ SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/zgbrfs.f b/lapack-netlib/SRC/zgbrfs.f index 7ae4390a13..bb7d58eb7d 100644 --- a/lapack-netlib/SRC/zgbrfs.f +++ b/lapack-netlib/SRC/zgbrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -206,10 +206,10 @@ SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgbrfsx.f b/lapack-netlib/SRC/zgbrfsx.f index 2b81d403b9..e40d7d23e9 100644 --- a/lapack-netlib/SRC/zgbrfsx.f +++ b/lapack-netlib/SRC/zgbrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -195,7 +195,7 @@ *> *> \param[in] B *> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> B is COMPLEX*16 array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> @@ -232,7 +232,7 @@ *> *> \param[out] BERR *> \verbatim -*> BERR is COMPLEX*16 array, dimension (NRHS) +*> BERR is DOUBLE PRECISION array, dimension (NRHS) *> Componentwise relative backward error. This is the *> componentwise relative backward error of each solution vector X(j) *> (i.e., the smallest relative change in any element of A or B that @@ -424,10 +424,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -440,7 +440,7 @@ SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -498,11 +498,10 @@ SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, ZLANGB, ZLA_GBRCOND_X, ZLA_GBRCOND_C DOUBLE PRECISION DLAMCH, ZLANGB, ZLA_GBRCOND_X, ZLA_GBRCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. @@ -642,7 +641,7 @@ SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, * * Perform refinement on each right-hand side * - IF ( REF_TYPE .NE. 0 ) THEN + IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN PREC_TYPE = ILAPREC( 'E' ) diff --git a/lapack-netlib/SRC/zgbsv.f b/lapack-netlib/SRC/zgbsv.f index 1487d60083..7bc4c44ebf 100644 --- a/lapack-netlib/SRC/zgbsv.f +++ b/lapack-netlib/SRC/zgbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zgbsvx.f b/lapack-netlib/SRC/zgbsvx.f index 3883cbdcfb..0e55866ac9 100644 --- a/lapack-netlib/SRC/zgbsvx.f +++ b/lapack-netlib/SRC/zgbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -356,10 +356,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -370,7 +370,7 @@ SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -390,7 +390,7 @@ SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * * ===================================================================== * Moved setting of INFO = N+1 so INFO does not subsequently get -* overwritten. Sven, 17 Mar 05. +* overwritten. Sven, 17 Mar 05. * ===================================================================== * * .. Parameters .. diff --git a/lapack-netlib/SRC/zgbsvxx.f b/lapack-netlib/SRC/zgbsvxx.f index eddf950e34..9ba9c2ee38 100644 --- a/lapack-netlib/SRC/zgbsvxx.f +++ b/lapack-netlib/SRC/zgbsvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RCOND, RPVGRW, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -544,10 +544,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -560,7 +560,7 @@ SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zgbtf2.f b/lapack-netlib/SRC/zgbtf2.f index 890d301237..cfddec898b 100644 --- a/lapack-netlib/SRC/zgbtf2.f +++ b/lapack-netlib/SRC/zgbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -145,10 +145,10 @@ * ===================================================================== SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/zgbtrf.f b/lapack-netlib/SRC/zgbtrf.f index bbdd986d46..533f5ee280 100644 --- a/lapack-netlib/SRC/zgbtrf.f +++ b/lapack-netlib/SRC/zgbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff --git a/lapack-netlib/SRC/zgbtrs.f b/lapack-netlib/SRC/zgbtrs.f index 2b41f129a4..8dc9746ee6 100644 --- a/lapack-netlib/SRC/zgbtrs.f +++ b/lapack-netlib/SRC/zgbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -138,10 +138,10 @@ SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgebak.f b/lapack-netlib/SRC/zgebak.f index 43d1b06c56..a9761fde20 100644 --- a/lapack-netlib/SRC/zgebak.f +++ b/lapack-netlib/SRC/zgebak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION SCALE( * ) * COMPLEX*16 V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -131,10 +131,10 @@ SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/zgebal.f b/lapack-netlib/SRC/zgebal.f index c679ba0f84..601d543146 100644 --- a/lapack-netlib/SRC/zgebal.f +++ b/lapack-netlib/SRC/zgebal.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION SCALE( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB @@ -189,7 +189,6 @@ SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 - COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL DISNAN, LSAME diff --git a/lapack-netlib/SRC/zgebd2.f b/lapack-netlib/SRC/zgebd2.f index 9991f4d6e8..d5752e043a 100644 --- a/lapack-netlib/SRC/zgebd2.f +++ b/lapack-netlib/SRC/zgebd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -189,10 +189,10 @@ * ===================================================================== SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgebrd.f b/lapack-netlib/SRC/zgebrd.f index deef71e611..26879a75a1 100644 --- a/lapack-netlib/SRC/zgebrd.f +++ b/lapack-netlib/SRC/zgebrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEBRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -205,10 +205,10 @@ SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgecon.f b/lapack-netlib/SRC/zgecon.f index 74d3116851..91362a977b 100644 --- a/lapack-netlib/SRC/zgecon.f +++ b/lapack-netlib/SRC/zgecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -124,10 +124,10 @@ SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zgeequ.f b/lapack-netlib/SRC/zgeequ.f index b8f0c61e87..13fcb2a63d 100644 --- a/lapack-netlib/SRC/zgeequ.f +++ b/lapack-netlib/SRC/zgeequ.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -140,10 +140,10 @@ SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgeequb.f b/lapack-netlib/SRC/zgeequb.f index c18c526457..1b9a3bbe85 100644 --- a/lapack-netlib/SRC/zgeequb.f +++ b/lapack-netlib/SRC/zgeequb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND @@ -29,7 +29,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,9 +49,9 @@ *> number of A but works well in practice. *> *> This routine differs from ZGEEQU by restricting the scaling factors -*> to a power of the radix. Baring over- and underflow, scaling by +*> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the -*> scaled entries' magnitured are no longer approximately 1 but lie +*> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -147,10 +147,10 @@ SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgees.f b/lapack-netlib/SRC/zgees.f index 23bb978ee8..a33e0a1481 100644 --- a/lapack-netlib/SRC/zgees.f +++ b/lapack-netlib/SRC/zgees.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, * LDVS, WORK, LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -34,7 +34,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEeigen * @@ -197,10 +197,10 @@ SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT diff --git a/lapack-netlib/SRC/zgeesx.f b/lapack-netlib/SRC/zgeesx.f index 4cf4ef3194..a5391cbb5c 100644 --- a/lapack-netlib/SRC/zgeesx.f +++ b/lapack-netlib/SRC/zgeesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, * VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, * BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVS, SENSE, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM @@ -36,7 +36,7 @@ * LOGICAL SELECT * EXTERNAL SELECT * .. -* +* * *> \par Purpose: * ============= @@ -83,7 +83,7 @@ *> *> \param[in] SELECT *> \verbatim -*> SELECT is procedure) LOGICAL FUNCTION of one COMPLEX*16 argument +*> SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to order *> to the top left of the Schur form. @@ -225,12 +225,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16GEeigen * @@ -239,10 +239,10 @@ SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT diff --git a/lapack-netlib/SRC/zgeev.f b/lapack-netlib/SRC/zgeev.f index a518b4cd9e..22b04469f1 100644 --- a/lapack-netlib/SRC/zgeev.f +++ b/lapack-netlib/SRC/zgeev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDVL, LDVR, LWORK, N @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -164,23 +164,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date November 2011 +* @precisions fortran z -> c * *> \ingroup complex16GEeigen * * ===================================================================== SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -202,7 +205,7 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, - $ IWRK, K, MAXWRK, MINWRK, NOUT + $ IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. @@ -212,7 +215,7 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -221,7 +224,7 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT + INTRINSIC DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT * .. * .. Executable Statements .. * @@ -266,18 +269,28 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, IF( WANTVL ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', $ ' ', N, 1, N, -1 ) ) + CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', $ ' ', N, 1, N, -1 ) ) + CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) ELSE CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, - $ WORK, -1, INFO ) + $ WORK, -1, INFO ) END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) END IF WORK( 1 ) = MAXWRK @@ -412,12 +425,13 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (CWorkspace: need 2*N) +* (CWorkspace: need 2*N, prefer N + 2*N*NB) * (RWorkspace: need 2*N) * IRWORK = IBAL + N - CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) + CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, + $ RWORK( IRWORK ), N, IERR ) END IF * IF( WANTVL ) THEN @@ -436,10 +450,10 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) DO 10 K = 1, N RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + - $ DIMAG( VL( K, I ) )**2 + $ AIMAG( VL( K, I ) )**2 10 CONTINUE K = IDAMAX( N, RWORK( IRWORK ), 1 ) - TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) 20 CONTINUE @@ -461,10 +475,10 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) DO 30 K = 1, N RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + - $ DIMAG( VR( K, I ) )**2 + $ AIMAG( VR( K, I ) )**2 30 CONTINUE K = IDAMAX( N, RWORK( IRWORK ), 1 ) - TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) 40 CONTINUE diff --git a/lapack-netlib/SRC/zgeevx.f b/lapack-netlib/SRC/zgeevx.f index 402eec799f..323782bce0 100644 --- a/lapack-netlib/SRC/zgeevx.f +++ b/lapack-netlib/SRC/zgeevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, * LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, * RCONDV, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,12 +271,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 * -*> \date November 2011 +* @precisions fortran z -> c * *> \ingroup complex16GEeigen * @@ -284,11 +286,12 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, $ RCONDV, WORK, LWORK, RWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -312,8 +315,8 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, $ WNTSNN, WNTSNV CHARACTER JOB, SIDE - INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK, - $ MINWRK, NOUT + INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. @@ -323,7 +326,7 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, * .. * .. External Subroutines .. EXTERNAL DLABAD, DLASCL, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, - $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, + $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, $ ZTRSNA, ZUNGHR * .. * .. External Functions .. @@ -333,7 +336,7 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT + INTRINSIC DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT * .. * .. Executable Statements .. * @@ -387,9 +390,19 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) * IF( WANTVL ) THEN + CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, LWORK_TREVC ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN + CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, + $ N, NOUT, WORK, -1, RWORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, LWORK_TREVC ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, $ WORK, -1, INFO ) ELSE @@ -401,7 +414,7 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ WORK, -1, INFO ) END IF END IF - HSWORK = WORK( 1 ) + HSWORK = INT( WORK(1) ) * IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = 2*N @@ -559,19 +572,20 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * -* If INFO > 0 from ZHSEQR, then quit +* If INFO .NE. 0 from ZHSEQR, then quit * - IF( INFO.GT.0 ) + IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors -* (CWorkspace: need 2*N) +* (CWorkspace: need 2*N, prefer N + 2*N*NB) * (RWorkspace: need N) * - CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, - $ N, NOUT, WORK( IWRK ), RWORK, IERR ) + CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, + $ RWORK, N, IERR ) END IF * * Compute condition numbers if desired @@ -598,10 +612,10 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) DO 10 K = 1, N RWORK( K ) = DBLE( VL( K, I ) )**2 + - $ DIMAG( VL( K, I ) )**2 + $ AIMAG( VL( K, I ) )**2 10 CONTINUE K = IDAMAX( N, RWORK, 1 ) - TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( K ) ) + TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( K ) ) CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) 20 CONTINUE @@ -621,10 +635,10 @@ SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) DO 30 K = 1, N RWORK( K ) = DBLE( VR( K, I ) )**2 + - $ DIMAG( VR( K, I ) )**2 + $ AIMAG( VR( K, I ) )**2 30 CONTINUE K = IDAMAX( N, RWORK, 1 ) - TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( K ) ) + TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( K ) ) CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) 40 CONTINUE diff --git a/lapack-netlib/SRC/zgehd2.f b/lapack-netlib/SRC/zgehd2.f index 4263fcba7f..12bac62a3d 100644 --- a/lapack-netlib/SRC/zgehd2.f +++ b/lapack-netlib/SRC/zgehd2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEHD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -149,10 +149,10 @@ * ===================================================================== SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff --git a/lapack-netlib/SRC/zgehrd.f b/lapack-netlib/SRC/zgehrd.f index d0d1ff0d8a..d8ddf2439b 100644 --- a/lapack-netlib/SRC/zgehrd.f +++ b/lapack-netlib/SRC/zgehrd.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,12 +115,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -167,10 +167,10 @@ * ===================================================================== SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -186,7 +186,7 @@ SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. @@ -316,7 +316,7 @@ SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL ZGEMM( 'No transpose', 'Conjugate transpose', + CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) diff --git a/lapack-netlib/SRC/zgejsv.f b/lapack-netlib/SRC/zgejsv.f index 62274f3a24..fcf073514a 100644 --- a/lapack-netlib/SRC/zgejsv.f +++ b/lapack-netlib/SRC/zgejsv.f @@ -1,1871 +1,2237 @@ -*> \brief \b ZGEJSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZGEJSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, -* M, N, A, LDA, SVA, U, LDU, V, LDV, -* CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* IMPLICIT NONE -* INTEGER INFO, LDA, LDU, LDV, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) -* DOUBLE PRECISION SVA( N ), RWORK( LRWORK ) -* INTEGER IWORK( * ) -* CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -* ZGEJSV computes the singular value decomposition (SVD) of a real M-by-N -* matrix [A], where M >= N. The SVD of [A] is written as -* -* [A] = [U] * [SIGMA] * [V]^*, -* -* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N -* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and -* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are -* the singular values of [A]. The columns of [U] and [V] are the left and -* the right singular vectors of [A], respectively. The matrices [U] and [V] -* are computed and stored in the arrays U and V, respectively. The diagonal -* of [SIGMA] is computed and stored in the array SVA. -* -* Arguments: -* ========== -*> -*> \param[in] JOBA -*> \verbatim -*> JOBA is CHARACTER*1 -*> Specifies the level of accuracy: -*> = 'C': This option works well (high relative accuracy) if A = B * D, -*> with well-conditioned B and arbitrary diagonal matrix D. -*> The accuracy cannot be spoiled by COLUMN scaling. The -*> accuracy of the computed output depends on the condition of -*> B, and the procedure aims at the best theoretical accuracy. -*> The relative error max_{i=1:N}|d sigma_i| / sigma_i is -*> bounded by f(M,N)*epsilon* cond(B), independent of D. -*> The input matrix is preprocessed with the QRF with column -*> pivoting. This initial preprocessing and preconditioning by -*> a rank revealing QR factorization is common for all values of -*> JOBA. Additional actions are specified as follows: -*> = 'E': Computation as with 'C' with an additional estimate of the -*> condition number of B. It provides a realistic error bound. -*> = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings -*> D1, D2, and well-conditioned matrix C, this option gives -*> higher accuracy than the 'C' option. If the structure of the -*> input matrix is not known, and relative accuracy is -*> desirable, then this option is advisable. The input matrix A -*> is preprocessed with QR factorization with FULL (row and -*> column) pivoting. -*> = 'G' Computation as with 'F' with an additional estimate of the -*> condition number of B, where A=D*B. If A has heavily weighted -*> rows, then using this condition number gives too pessimistic -*> error bound. -*> = 'A': Small singular values are the noise and the matrix is treated -*> as numerically rank defficient. The error in the computed -*> singular values is bounded by f(m,n)*epsilon*||A||. -*> The computed SVD A = U * S * V^* restores A up to -*> f(m,n)*epsilon*||A||. -*> This gives the procedure the licence to discard (set to zero) -*> all singular values below N*epsilon*||A||. -*> = 'R': Similar as in 'A'. Rank revealing property of the initial -*> QR factorization is used do reveal (using triangular factor) -*> a gap sigma_{r+1} < epsilon * sigma_r in which case the -*> numerical RANK is declared to be r. The SVD is computed with -*> absolute error bounds, but more accurately than with 'A'. -*> \endverbatim -*> -*> \param[in] JOBU -*> \verbatim -*> JOBU is CHARACTER*1 -*> Specifies whether to compute the columns of U: -*> = 'U': N columns of U are returned in the array U. -*> = 'F': full set of M left sing. vectors is returned in the array U. -*> = 'W': U may be used as workspace of length M*N. See the description -*> of U. -*> = 'N': U is not computed. -*> \endverbatim -*> -*> \param[in] JOBV -*> \verbatim -*> JOBV is CHARACTER*1 -*> Specifies whether to compute the matrix V: -*> = 'V': N columns of V are returned in the array V; Jacobi rotations -*> are not explicitly accumulated. -*> = 'J': N columns of V are returned in the array V, but they are -*> computed as the product of Jacobi rotations. This option is -*> allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. -*> = 'W': V may be used as workspace of length N*N. See the description -*> of V. -*> = 'N': V is not computed. -*> \endverbatim -*> -*> \param[in] JOBR -*> \verbatim -*> JOBR is CHARACTER*1 -*> Specifies the RANGE for the singular values. Issues the licence to -*> set to zero small positive singular values if they are outside -*> specified range. If A .NE. 0 is scaled so that the largest singular -*> value of c*A is around SQRT(BIG), BIG=DLAMCH('O'), then JOBR issues -*> the licence to kill columns of A whose norm in c*A is less than -*> SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, -*> where SFMIN=DLAMCH('S'), EPSLN=DLAMCH('E'). -*> = 'N': Do not kill small columns of c*A. This option assumes that -*> BLAS and QR factorizations and triangular solvers are -*> implemented to work in that range. If the condition of A -*> is greater than BIG, use ZGESVJ. -*> = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] -*> (roughly, as described above). This option is recommended. -*> =========================== -*> For computing the singular values in the FULL range [SFMIN,BIG] -*> use ZGESVJ. -*> \endverbatim -*> -*> \param[in] JOBT -*> \verbatim -*> JOBT is CHARACTER*1 -*> If the matrix is square then the procedure may determine to use -*> transposed A if A^* seems to be better with respect to convergence. -*> If the matrix is not square, JOBT is ignored. This is subject to -*> changes in the future. -*> The decision is based on two values of entropy over the adjoint -*> orbit of A^* * A. See the descriptions of WORK(6) and WORK(7). -*> = 'T': transpose if entropy test indicates possibly faster -*> convergence of Jacobi process if A^* is taken as input. If A is -*> replaced with A^*, then the row pivoting is included automatically. -*> = 'N': do not speculate. -*> This option can be used to compute only the singular values, or the -*> full SVD (U, SIGMA and V). For only one set of singular vectors -*> (U or V), the caller should provide both U and V, as one of the -*> matrices is used as workspace if the matrix A is transposed. -*> The implementer can easily remove this constraint and make the -*> code more complicated. See the descriptions of U and V. -*> \endverbatim -*> -*> \param[in] JOBP -*> \verbatim -*> JOBP is CHARACTER*1 -*> Issues the licence to introduce structured perturbations to drown -*> denormalized numbers. This licence should be active if the -*> denormals are poorly implemented, causing slow computation, -*> especially in cases of fast convergence (!). For details see [1,2]. -*> For the sake of simplicity, this perturbations are included only -*> when the full SVD or only the singular values are requested. The -*> implementer/user can easily add the perturbation for the cases of -*> computing one set of singular vectors. -*> = 'P': introduce perturbation -*> = 'N': do not perturb -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the input matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the input matrix A. M >= N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE COMPLEX array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] SVA -*> \verbatim -*> SVA is DOUBLE PRECISION array, dimension (N) -*> On exit, -*> - For WORK(1)/WORK(2) = ONE: The singular values of A. During the -*> computation SVA contains Euclidean column norms of the -*> iterated matrices in the array A. -*> - For WORK(1) .NE. WORK(2): The singular values of A are -*> (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if -*> sigma_max(A) overflows or if small singular values have been -*> saved from underflow by scaling the input matrix A. -*> - If JOBR='R' then some of the singular values may be returned -*> as exact zeros obtained by "set to zero" because they are -*> below the numerical rank threshold or are denormalized numbers. -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is DOUBLE COMPLEX array, dimension ( LDU, N ) -*> If JOBU = 'U', then U contains on exit the M-by-N matrix of -*> the left singular vectors. -*> If JOBU = 'F', then U contains on exit the M-by-M matrix of -*> the left singular vectors, including an ONB -*> of the orthogonal complement of the Range(A). -*> If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), -*> then U is used as workspace if the procedure -*> replaces A with A^*. In that case, [V] is computed -*> in U as left singular vectors of A^* and then -*> copied back to the V array. This 'W' option is just -*> a reminder to the caller that in this case U is -*> reserved as workspace of length N*N. -*> If JOBU = 'N' U is not referenced. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U, LDU >= 1. -*> IF JOBU = 'U' or 'F' or 'W', then LDU >= M. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE COMPLEX array, dimension ( LDV, N ) -*> If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of -*> the right singular vectors; -*> If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), -*> then V is used as workspace if the pprocedure -*> replaces A with A^*. In that case, [U] is computed -*> in V as right singular vectors of A^* and then -*> copied back to the U array. This 'W' option is just -*> a reminder to the caller that in this case V is -*> reserved as workspace of length N*N. -*> If JOBV = 'N' V is not referenced. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V, LDV >= 1. -*> If JOBV = 'V' or 'J' or 'W', then LDV >= N. -*> \endverbatim -*> -*> \param[out] CWORK -*> \verbatim -*> CWORK (workspace) -*> CWORK is DOUBLE COMPLEX array, dimension at least LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> Length of CWORK to confirm proper allocation of workspace. -*> LWORK depends on the job: -*> -*> 1. If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and -*> 1.1 .. no scaled condition estimate required (JOBE.EQ.'N'): -*> LWORK >= 2*N+1. This is the minimal requirement. -*> ->> For optimal performance (blocked code) the optimal value -*> is LWORK >= N + (N+1)*NB. Here NB is the optimal -*> block size for ZGEQP3 and ZGEQRF. -*> In general, optimal LWORK is computed as -*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF)). -*> 1.2. .. an estimate of the scaled condition number of A is -*> required (JOBA='E', or 'G'). In this case, LWORK the minimal -*> requirement is LWORK >= N*N + 3*N. -*> ->> For optimal performance (blocked code) the optimal value -*> is LWORK >= max(N+(N+1)*NB, N*N+3*N). -*> In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF), -*> N+N*N+LWORK(CPOCON)). -*> -*> 2. If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), -*> (JOBU.EQ.'N') -*> -> the minimal requirement is LWORK >= 3*N. -*> -> For optimal performance, LWORK >= max(N+(N+1)*NB, 3*N,2*N+N*NB), -*> where NB is the optimal block size for ZGEQP3, ZGEQRF, ZGELQ, -*> CUNMLQ. In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(ZGEQP3), N+LWORK(CPOCON), N+LWORK(ZGESVJ), -*> N+LWORK(ZGELQF), 2*N+LWORK(ZGEQRF), N+LWORK(CUNMLQ)). -*> -*> 3. If SIGMA and the left singular vectors are needed -*> -> the minimal requirement is LWORK >= 3*N. -*> -> For optimal performance: -*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB), -*> where NB is the optimal block size for ZGEQP3, ZGEQRF, CUNMQR. -*> In general, the optimal length LWORK is computed as -*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(CPOCON), -*> 2*N+LWORK(ZGEQRF), N+LWORK(CUNMQR)). -*> -*> 4. If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and -*> 4.1. if JOBV.EQ.'V' -*> the minimal requirement is LWORK >= 5*N+2*N*N. -*> 4.2. if JOBV.EQ.'J' the minimal requirement is -*> LWORK >= 4*N+N*N. -*> In both cases, the allocated CWORK can accomodate blocked runs -*> of ZGEQP3, ZGEQRF, ZGELQF, SUNMQR, CUNMLQ. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension at least LRWORK. -*> On exit, -*> RWORK(1) = Determines the scaling factor SCALE = RWORK(2) / RWORK(1) -*> such that SCALE*SVA(1:N) are the computed singular values -*> of A. (See the description of SVA().) -*> RWORK(2) = See the description of RWORK(1). -*> RWORK(3) = SCONDA is an estimate for the condition number of -*> column equilibrated A. (If JOBA .EQ. 'E' or 'G') -*> SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). -*> It is computed using SPOCON. It holds -*> N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA -*> where R is the triangular factor from the QRF of A. -*> However, if R is truncated and the numerical rank is -*> determined to be strictly smaller than N, SCONDA is -*> returned as -1, thus indicating that the smallest -*> singular values might be lost. -*> -*> If full SVD is needed, the following two condition numbers are -*> useful for the analysis of the algorithm. They are provied for -*> a developer/implementer who is familiar with the details of -*> the method. -*> -*> RWORK(4) = an estimate of the scaled condition number of the -*> triangular factor in the first QR factorization. -*> RWORK(5) = an estimate of the scaled condition number of the -*> triangular factor in the second QR factorization. -*> The following two parameters are computed if JOBT .EQ. 'T'. -*> They are provided for a developer/implementer who is familiar -*> with the details of the method. -*> RWORK(6) = the entropy of A^* * A :: this is the Shannon entropy -*> of diag(A^* * A) / Trace(A^* * A) taken as point in the -*> probability simplex. -*> RWORK(7) = the entropy of A * A^*. (See the description of RWORK(6).) -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> Length of RWORK to confirm proper allocation of workspace. -*> LRWORK depends on the job: -*> -*> 1. If only singular values are requested i.e. if -*> LSAME(JOBU,'N') .AND. LSAME(JOBV,'N') -*> then: -*> 1.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 1.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 2. If singular values with the right singular vectors are requested -*> i.e. if -*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) .AND. -*> .NOT.(LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) -*> then: -*> 2.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 2.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 3. If singular values with the left singular vectors are requested, i.e. if -*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. -*> .NOT.(LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) -*> then: -*> 3.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 3.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> 4. If singular values with both the left and the right singular vectors -*> are requested, i.e. if -*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. -*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) -*> then: -*> 4.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), -*> then LRWORK = max( 7, N + 2 * M ). -*> 4.2. Otherwise, LRWORK = max( 7, 2 * N ). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, of dimension: -*> If LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), then -*> the dimension of IWORK is max( 3, 2 * N + M ). -*> Otherwise, the dimension of IWORK is -*> -> max( 3, 2*N ) for full SVD -*> -> max( 3, N ) for singular values only or singular -*> values with one set of singular vectors (left or right) -*> On exit, -*> IWORK(1) = the numerical rank determined after the initial -*> QR factorization with pivoting. See the descriptions -*> of JOBA and JOBR. -*> IWORK(2) = the number of the computed nonzero singular values -*> IWORK(3) = if nonzero, a warning message: -*> If IWORK(3).EQ.1 then some of the column norms of A -*> were denormalized floats. The requested high accuracy -*> is not warranted by the data. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> < 0 : if INFO = -i, then the i-th argument had an illegal value. -*> = 0 : successfull exit; -*> > 0 : ZGEJSV did not converge in the maximal allowed number -*> of sweeps. The computed values may be inaccurate. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2015 -* -*> \ingroup complex16GEsing -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> ZGEJSV implements a preconditioned Jacobi SVD algorithm. It uses ZGEQP3, -*> ZGEQRF, and ZGELQF as preprocessors and preconditioners. Optionally, an -*> additional row pivoting can be used as a preprocessor, which in some -*> cases results in much higher accuracy. An example is matrix A with the -*> structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned -*> diagonal matrices and C is well-conditioned matrix. In that case, complete -*> pivoting in the first QR factorizations provides accuracy dependent on the -*> condition number of C, and independent of D1, D2. Such higher accuracy is -*> not completely understood theoretically, but it works well in practice. -*> Further, if A can be written as A = B*D, with well-conditioned B and some -*> diagonal D, then the high accuracy is guaranteed, both theoretically and -*> in software, independent of D. For more details see [1], [2]. -*> The computational range for the singular values can be the full range -*> ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS -*> & LAPACK routines called by ZGEJSV are implemented to work in that range. -*> If that is not the case, then the restriction for safe computation with -*> the singular values in the range of normalized IEEE numbers is that the -*> spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not -*> overflow. This code (ZGEJSV) is best used in this restricted range, -*> meaning that singular values of magnitude below ||A||_2 / DLAMCH('O') are -*> returned as zeros. See JOBR for details on this. -*> Further, this implementation is somewhat slower than the one described -*> in [1,2] due to replacement of some non-LAPACK components, and because -*> the choice of some tuning parameters in the iterative part (ZGESVJ) is -*> left to the implementer on a particular machine. -*> The rank revealing QR factorization (in this code: ZGEQP3) should be -*> implemented as in [3]. We have a new version of ZGEQP3 under development -*> that is more robust than the current one in LAPACK, with a cleaner cut in -*> rank defficient cases. It will be available in the SIGMA library [4]. -*> If M is much larger than N, it is obvious that the inital QRF with -*> column pivoting can be preprocessed by the QRF without pivoting. That -*> well known trick is not used in ZGEJSV because in some cases heavy row -*> weighting can be treated with complete pivoting. The overhead in cases -*> M much larger than N is then only due to pivoting, but the benefits in -*> terms of accuracy have prevailed. The implementer/user can incorporate -*> this extra QRF step easily. The implementer can also improve data movement -*> (matrix transpose, matrix copy, matrix transposed copy) - this -*> implementation of ZGEJSV uses only the simplest, naive data movement. -* -*> \par Contributors: -* ================== -*> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) -* -*> \par References: -* ================ -*> -*> \verbatim -*> -* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. -* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. -* LAPACK Working note 169. -* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. -* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. -* LAPACK Working note 170. -* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR -* factorization software - a case study. -* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28. -* LAPACK Working note 176. -* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, -* QSVD, (H,K)-SVD computations. -* Department of Mathematics, University of Zagreb, 2008. -*> \endverbatim -* -*> \par Bugs, examples and comments: -* ================================= -*> -*> Please report all bugs and send interesting examples and/or comments to -*> drmac@math.hr. Thank you. -*> -* ===================================================================== - SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, - $ M, N, A, LDA, SVA, U, LDU, V, LDV, - $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) -* -* -- LAPACK computational routine (version 3.6.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 -* -* .. Scalar Arguments .. - IMPLICIT NONE - INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A( LDA, * ), U( LDU, * ), V( LDV, * ), - $ CWORK( LWORK ) - DOUBLE PRECISION SVA( N ), RWORK( * ) - INTEGER IWORK( * ) - CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV -* .. -* -* =========================================================================== -* -* .. Local Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE COMPLEX CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX CTEMP - DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, - $ COND_OK, CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, - $ MAXPRJ, SCALEM, SCONDA, SFMIN, SMALL, TEMP1, - $ USCAL1, USCAL2, XSC - INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING - LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC, - $ L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, - $ NOSCAL, ROWPIV, RSVEC, TRANSP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DCMPLX, DCONJG, DLOG, DMAX1, DMIN1, DFLOAT, - $ MAX0, MIN0, NINT, DSQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DZNRM2 - INTEGER IDAMAX - LOGICAL LSAME - EXTERNAL IDAMAX, LSAME, DLAMCH, DZNRM2 -* .. -* .. External Subroutines .. - EXTERNAL ZCOPY, ZGELQF, ZGEQP3, ZGEQRF, ZLACPY, ZLASCL, - $ ZLASET, ZLASSQ, ZLASWP, ZUNGQR, ZUNMLQ, - $ ZUNMQR, ZPOCON, DSCAL, ZDSCAL, ZSWAP, ZTRSM, XERBLA -* - EXTERNAL ZGESVJ -* .. -* -* Test the input arguments -* - - LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) - JRACC = LSAME( JOBV, 'J' ) - RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC - ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) - L2RANK = LSAME( JOBA, 'R' ) - L2ABER = LSAME( JOBA, 'A' ) - ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) - L2TRAN = LSAME( JOBT, 'T' ) - L2KILL = LSAME( JOBR, 'R' ) - DEFR = LSAME( JOBR, 'N' ) - L2PERT = LSAME( JOBP, 'P' ) -* - IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. - $ ERREST .OR. LSAME( JOBA, 'C' ) )) THEN - INFO = - 1 - ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. - $ LSAME( JOBU, 'W' )) ) THEN - INFO = - 2 - ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. - $ LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN - INFO = - 3 - ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN - INFO = - 4 - ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN - INFO = - 5 - ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN - INFO = - 6 - ELSE IF ( M .LT. 0 ) THEN - INFO = - 7 - ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN - INFO = - 8 - ELSE IF ( LDA .LT. M ) THEN - INFO = - 10 - ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN - INFO = - 13 - ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN - INFO = - 15 - ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. - $ (LWORK .LT. 2*N+1)) .OR. - $ (.NOT.(LSVEC .OR. RSVEC) .AND. ERREST .AND. - $ (LWORK .LT. N*N+3*N)) .OR. - $ (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. 3*N)) - $ .OR. - $ (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. 3*N)) - $ .OR. - $ (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. - $ (LWORK.LT.5*N+2*N*N)) - $ .OR. (LSVEC .AND. RSVEC .AND. JRACC .AND. - $ LWORK.LT.4*N+N*N)) - $ THEN - INFO = - 17 - ELSE IF ( LRWORK.LT. MAX0(N+2*M,7)) THEN - INFO = -19 - ELSE -* #:) - INFO = 0 - END IF -* - IF ( INFO .NE. 0 ) THEN -* #:( - CALL XERBLA( 'ZGEJSV', - INFO ) - RETURN - END IF -* -* Quick return for void matrix (Y3K safe) -* #:) - IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN -* -* Determine whether the matrix U should be M x N or M x M -* - IF ( LSVEC ) THEN - N1 = N - IF ( LSAME( JOBU, 'F' ) ) N1 = M - END IF -* -* Set numerical parameters -* -*! NOTE: Make sure DLAMCH() does not fail on the target architecture. -* - EPSLN = DLAMCH('Epsilon') - SFMIN = DLAMCH('SafeMinimum') - SMALL = SFMIN / EPSLN - BIG = DLAMCH('O') -* BIG = ONE / SFMIN -* -* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N -* -*(!) If necessary, scale SVA() to protect the largest norm from -* overflow. It is possible that this scaling pushes the smallest -* column norm left from the underflow threshold (extreme case). -* - SCALEM = ONE / DSQRT(DFLOAT(M)*DFLOAT(N)) - NOSCAL = .TRUE. - GOSCAL = .TRUE. - DO 1874 p = 1, N - AAPP = ZERO - AAQQ = ONE - CALL ZLASSQ( M, A(1,p), 1, AAPP, AAQQ ) - IF ( AAPP .GT. BIG ) THEN - INFO = - 9 - CALL XERBLA( 'ZGEJSV', -INFO ) - RETURN - END IF - AAQQ = DSQRT(AAQQ) - IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN - SVA(p) = AAPP * AAQQ - ELSE - NOSCAL = .FALSE. - SVA(p) = AAPP * ( AAQQ * SCALEM ) - IF ( GOSCAL ) THEN - GOSCAL = .FALSE. - CALL DSCAL( p-1, SCALEM, SVA, 1 ) - END IF - END IF - 1874 CONTINUE -* - IF ( NOSCAL ) SCALEM = ONE -* - AAPP = ZERO - AAQQ = BIG - DO 4781 p = 1, N - AAPP = DMAX1( AAPP, SVA(p) ) - IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) ) - 4781 CONTINUE -* -* Quick return for zero M x N matrix -* #:) - IF ( AAPP .EQ. ZERO ) THEN - IF ( LSVEC ) CALL ZLASET( 'G', M, N1, CZERO, CONE, U, LDU ) - IF ( RSVEC ) CALL ZLASET( 'G', N, N, CZERO, CONE, V, LDV ) - RWORK(1) = ONE - RWORK(2) = ONE - IF ( ERREST ) RWORK(3) = ONE - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = ONE - RWORK(5) = ONE - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ZERO - RWORK(7) = ZERO - END IF - IWORK(1) = 0 - IWORK(2) = 0 - IWORK(3) = 0 - RETURN - END IF -* -* Issue warning if denormalized column norms detected. Override the -* high relative accuracy request. Issue licence to kill columns -* (set them to zero) whose norm is less than sigma_max / BIG (roughly). -* #:( - WARNING = 0 - IF ( AAQQ .LE. SFMIN ) THEN - L2RANK = .TRUE. - L2KILL = .TRUE. - WARNING = 1 - END IF -* -* Quick return for one-column matrix -* #:) - IF ( N .EQ. 1 ) THEN -* - IF ( LSVEC ) THEN - CALL ZLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) - CALL ZLACPY( 'A', M, 1, A, LDA, U, LDU ) -* computing all M left singular vectors of the M x 1 matrix - IF ( N1 .NE. N ) THEN - CALL ZGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) - CALL ZUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) - CALL ZCOPY( M, A(1,1), 1, U(1,1), 1 ) - END IF - END IF - IF ( RSVEC ) THEN - V(1,1) = CONE - END IF - IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN - SVA(1) = SVA(1) / SCALEM - SCALEM = ONE - END IF - RWORK(1) = ONE / SCALEM - RWORK(2) = ONE - IF ( SVA(1) .NE. ZERO ) THEN - IWORK(1) = 1 - IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN - IWORK(2) = 1 - ELSE - IWORK(2) = 0 - END IF - ELSE - IWORK(1) = 0 - IWORK(2) = 0 - END IF - IWORK(3) = 0 - IF ( ERREST ) RWORK(3) = ONE - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = ONE - RWORK(5) = ONE - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ZERO - RWORK(7) = ZERO - END IF - RETURN -* - END IF -* - TRANSP = .FALSE. - L2TRAN = L2TRAN .AND. ( M .EQ. N ) -* - AATMAX = -ONE - AATMIN = BIG - IF ( ROWPIV .OR. L2TRAN ) THEN -* -* Compute the row norms, needed to determine row pivoting sequence -* (in the case of heavily row weighted A, row pivoting is strongly -* advised) and to collect information needed to compare the -* structures of A * A^* and A^* * A (in the case L2TRAN.EQ..TRUE.). -* - IF ( L2TRAN ) THEN - DO 1950 p = 1, M - XSC = ZERO - TEMP1 = ONE - CALL ZLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) -* ZLASSQ gets both the ell_2 and the ell_infinity norm -* in one pass through the vector - RWORK(M+N+p) = XSC * SCALEM - RWORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1)) - AATMAX = DMAX1( AATMAX, RWORK(N+p) ) - IF (RWORK(N+p) .NE. ZERO) - $ AATMIN = DMIN1(AATMIN,RWORK(N+p)) - 1950 CONTINUE - ELSE - DO 1904 p = 1, M - RWORK(M+N+p) = SCALEM*ABS( A(p,IDAMAX(N,A(p,1),LDA)) ) - AATMAX = DMAX1( AATMAX, RWORK(M+N+p) ) - AATMIN = DMIN1( AATMIN, RWORK(M+N+p) ) - 1904 CONTINUE - END IF -* - END IF -* -* For square matrix A try to determine whether A^* would be better -* input for the preconditioned Jacobi SVD, with faster convergence. -* The decision is based on an O(N) function of the vector of column -* and row norms of A, based on the Shannon entropy. This should give -* the right choice in most cases when the difference actually matters. -* It may fail and pick the slower converging side. -* - ENTRA = ZERO - ENTRAT = ZERO - IF ( L2TRAN ) THEN -* - XSC = ZERO - TEMP1 = ONE - CALL ZLASSQ( N, SVA, 1, XSC, TEMP1 ) - TEMP1 = ONE / TEMP1 -* - ENTRA = ZERO - DO 1113 p = 1, N - BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 - IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1) - 1113 CONTINUE - ENTRA = - ENTRA / DLOG(DFLOAT(N)) -* -* Now, SVA().^2/Trace(A^* * A) is a point in the probability simplex. -* It is derived from the diagonal of A^* * A. Do the same with the -* diagonal of A * A^*, compute the entropy of the corresponding -* probability distribution. Note that A * A^* and A^* * A have the -* same trace. -* - ENTRAT = ZERO - DO 1114 p = N+1, N+M - BIG1 = ( ( RWORK(p) / XSC )**2 ) * TEMP1 - IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1) - 1114 CONTINUE - ENTRAT = - ENTRAT / DLOG(DFLOAT(M)) -* -* Analyze the entropies and decide A or A^*. Smaller entropy -* usually means better input for the algorithm. -* - TRANSP = ( ENTRAT .LT. ENTRA ) - TRANSP = .TRUE. -* -* If A^* is better than A, take the adjoint of A. -* - IF ( TRANSP ) THEN -* In an optimal implementation, this trivial transpose -* should be replaced with faster transpose. - DO 1115 p = 1, N - 1 - A(p,p) = DCONJG(A(p,p)) - DO 1116 q = p + 1, N - CTEMP = DCONJG(A(q,p)) - A(q,p) = DCONJG(A(p,q)) - A(p,q) = CTEMP - 1116 CONTINUE - 1115 CONTINUE - A(N,N) = DCONJG(A(N,N)) - DO 1117 p = 1, N - RWORK(M+N+p) = SVA(p) - SVA(p) = RWORK(N+p) -* previously computed row 2-norms are now column 2-norms -* of the transposed matrix - 1117 CONTINUE - TEMP1 = AAPP - AAPP = AATMAX - AATMAX = TEMP1 - TEMP1 = AAQQ - AAQQ = AATMIN - AATMIN = TEMP1 - KILL = LSVEC - LSVEC = RSVEC - RSVEC = KILL - IF ( LSVEC ) N1 = N -* - ROWPIV = .TRUE. - END IF -* - END IF -* END IF L2TRAN -* -* Scale the matrix so that its maximal singular value remains less -* than SQRT(BIG) -- the matrix is scaled so that its maximal column -* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep -* SQRT(BIG) instead of BIG is the fact that ZGEJSV uses LAPACK and -* BLAS routines that, in some implementations, are not capable of -* working in the full interval [SFMIN,BIG] and that they may provoke -* overflows in the intermediate results. If the singular values spread -* from SFMIN to BIG, then ZGESVJ will compute them. So, in that case, -* one should use ZGESVJ instead of ZGEJSV. -* - BIG1 = DSQRT( BIG ) - TEMP1 = DSQRT( BIG / DFLOAT(N) ) -* - CALL ZLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) - IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN - AAQQ = ( AAQQ / AAPP ) * TEMP1 - ELSE - AAQQ = ( AAQQ * TEMP1 ) / AAPP - END IF - TEMP1 = TEMP1 * SCALEM - CALL ZLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) -* -* To undo scaling at the end of this procedure, multiply the -* computed singular values with USCAL2 / USCAL1. -* - USCAL1 = TEMP1 - USCAL2 = AAPP -* - IF ( L2KILL ) THEN -* L2KILL enforces computation of nonzero singular values in -* the restricted range of condition number of the initial A, -* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). - XSC = DSQRT( SFMIN ) - ELSE - XSC = SMALL -* -* Now, if the condition number of A is too big, -* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, -* as a precaution measure, the full SVD is computed using ZGESVJ -* with accumulated Jacobi rotations. This provides numerically -* more robust computation, at the cost of slightly increased run -* time. Depending on the concrete implementation of BLAS and LAPACK -* (i.e. how they behave in presence of extreme ill-conditioning) the -* implementor may decide to remove this switch. - IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN - JRACC = .TRUE. - END IF -* - END IF - IF ( AAQQ .LT. XSC ) THEN - DO 700 p = 1, N - IF ( SVA(p) .LT. XSC ) THEN - CALL ZLASET( 'A', M, 1, CZERO, CZERO, A(1,p), LDA ) - SVA(p) = ZERO - END IF - 700 CONTINUE - END IF -* -* Preconditioning using QR factorization with pivoting -* - IF ( ROWPIV ) THEN -* Optional row permutation (Bjoerck row pivoting): -* A result by Cox and Higham shows that the Bjoerck's -* row pivoting combined with standard column pivoting -* has similar effect as Powell-Reid complete pivoting. -* The ell-infinity norms of A are made nonincreasing. - DO 1952 p = 1, M - 1 - q = IDAMAX( M-p+1, RWORK(M+N+p), 1 ) + p - 1 - IWORK(2*N+p) = q - IF ( p .NE. q ) THEN - TEMP1 = RWORK(M+N+p) - RWORK(M+N+p) = RWORK(M+N+q) - RWORK(M+N+q) = TEMP1 - END IF - 1952 CONTINUE - CALL ZLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 ) - END IF - -* -* End of the preparation phase (scaling, optional sorting and -* transposing, optional flushing of small columns). -* -* Preconditioning -* -* If the full SVD is needed, the right singular vectors are computed -* from a matrix equation, and for that we need theoretical analysis -* of the Businger-Golub pivoting. So we use ZGEQP3 as the first RR QRF. -* In all other cases the first RR QRF can be chosen by other criteria -* (eg speed by replacing global with restricted window pivoting, such -* as in xGEQPX from TOMS # 782). Good results will be obtained using -* xGEQPX with properly (!) chosen numerical parameters. -* Any improvement of ZGEQP3 improves overal performance of ZGEJSV. -* -* A * P1 = Q1 * [ R1^* 0]^*: - DO 1963 p = 1, N -* .. all columns are free columns - IWORK(p) = 0 - 1963 CONTINUE - CALL ZGEQP3( M, N, A, LDA, IWORK, CWORK, CWORK(N+1), LWORK-N, - $ RWORK, IERR ) -* -* The upper triangular matrix R1 from the first QRF is inspected for -* rank deficiency and possibilities for deflation, or possible -* ill-conditioning. Depending on the user specified flag L2RANK, -* the procedure explores possibilities to reduce the numerical -* rank by inspecting the computed upper triangular factor. If -* L2RANK or L2ABER are up, then ZGEJSV will compute the SVD of -* A + dA, where ||dA|| <= f(M,N)*EPSLN. -* - NR = 1 - IF ( L2ABER ) THEN -* Standard absolute error bound suffices. All sigma_i with -* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an -* agressive enforcement of lower numerical rank by introducing a -* backward error of the order of N*EPSLN*||A||. - TEMP1 = DSQRT(DFLOAT(N))*EPSLN - DO 3001 p = 2, N - IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN - NR = NR + 1 - ELSE - GO TO 3002 - END IF - 3001 CONTINUE - 3002 CONTINUE - ELSE IF ( L2RANK ) THEN -* .. similarly as above, only slightly more gentle (less agressive). -* Sudden drop on the diagonal of R1 is used as the criterion for -* close-to-rank-defficient. - TEMP1 = DSQRT(SFMIN) - DO 3401 p = 2, N - IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. - $ ( ABS(A(p,p)) .LT. SMALL ) .OR. - $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 - NR = NR + 1 - 3401 CONTINUE - 3402 CONTINUE -* - ELSE -* The goal is high relative accuracy. However, if the matrix -* has high scaled condition number the relative accuracy is in -* general not feasible. Later on, a condition number estimator -* will be deployed to estimate the scaled condition number. -* Here we just remove the underflowed part of the triangular -* factor. This prevents the situation in which the code is -* working hard to get the accuracy not warranted by the data. - TEMP1 = DSQRT(SFMIN) - DO 3301 p = 2, N - IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR. - $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 - NR = NR + 1 - 3301 CONTINUE - 3302 CONTINUE -* - END IF -* - ALMORT = .FALSE. - IF ( NR .EQ. N ) THEN - MAXPRJ = ONE - DO 3051 p = 2, N - TEMP1 = ABS(A(p,p)) / SVA(IWORK(p)) - MAXPRJ = DMIN1( MAXPRJ, TEMP1 ) - 3051 CONTINUE - IF ( MAXPRJ**2 .GE. ONE - DFLOAT(N)*EPSLN ) ALMORT = .TRUE. - END IF -* -* - SCONDA = - ONE - CONDR1 = - ONE - CONDR2 = - ONE -* - IF ( ERREST ) THEN - IF ( N .EQ. NR ) THEN - IF ( RSVEC ) THEN -* .. V is available as workspace - CALL ZLACPY( 'U', N, N, A, LDA, V, LDV ) - DO 3053 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL ZDSCAL( p, ONE/TEMP1, V(1,p), 1 ) - 3053 CONTINUE - CALL ZPOCON( 'U', N, V, LDV, ONE, TEMP1, - $ CWORK(N+1), RWORK, IERR ) -* - ELSE IF ( LSVEC ) THEN -* .. U is available as workspace - CALL ZLACPY( 'U', N, N, A, LDA, U, LDU ) - DO 3054 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL ZDSCAL( p, ONE/TEMP1, U(1,p), 1 ) - 3054 CONTINUE - CALL ZPOCON( 'U', N, U, LDU, ONE, TEMP1, - $ CWORK(N+1), RWORK, IERR ) - ELSE - CALL ZLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) - DO 3052 p = 1, N - TEMP1 = SVA(IWORK(p)) - CALL ZDSCAL( p, ONE/TEMP1, CWORK(N+(p-1)*N+1), 1 ) - 3052 CONTINUE -* .. the columns of R are scaled to have unit Euclidean lengths. - CALL ZPOCON( 'U', N, CWORK(N+1), N, ONE, TEMP1, - $ CWORK(N+N*N+1), RWORK, IERR ) -* - END IF - SCONDA = ONE / DSQRT(TEMP1) -* SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). -* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA - ELSE - SCONDA = - ONE - END IF - END IF -* - L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) ) -* If there is no violent scaling, artificial perturbation is not needed. -* -* Phase 3: -* - IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN -* -* Singular Values only -* -* .. transpose A(1:NR,1:N) - DO 1946 p = 1, MIN0( N-1, NR ) - CALL ZCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) - CALL ZLACGV( N-p+1, A(p,p), 1 ) - 1946 CONTINUE - IF ( NR .EQ. N ) A(N,N) = DCONJG(A(N,N)) -* -* The following two DO-loops introduce small relative perturbation -* into the strict upper triangle of the lower triangular matrix. -* Small entries below the main diagonal are also changed. -* This modification is useful if the computing environment does not -* provide/allow FLUSH TO ZERO underflow, for it prevents many -* annoying denormalized numbers in case of strongly scaled matrices. -* The perturbation is structured so that it does not introduce any -* new perturbation of the singular values, and it does not destroy -* the job done by the preconditioner. -* The licence for this perturbation is in the variable L2PERT, which -* should be .FALSE. if FLUSH TO ZERO underflow is active. -* - IF ( .NOT. ALMORT ) THEN -* - IF ( L2PERT ) THEN -* XSC = SQRT(SMALL) - XSC = EPSLN / DFLOAT(N) - DO 4947 q = 1, NR - CTEMP = DCMPLX(XSC*ABS(A(q,q)),ZERO) - DO 4949 p = 1, N - IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) - $ .OR. ( p .LT. q ) ) -* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) - $ A(p,q) = CTEMP - 4949 CONTINUE - 4947 CONTINUE - ELSE - CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, A(1,2),LDA ) - END IF -* -* .. second preconditioning using the QR factorization -* - CALL ZGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) -* -* .. and transpose upper to lower triangular - DO 1948 p = 1, NR - 1 - CALL ZCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) - CALL ZLACGV( NR-p+1, A(p,p), 1 ) - 1948 CONTINUE -* - END IF -* -* Row-cyclic Jacobi SVD algorithm with column pivoting -* -* .. again some perturbation (a "background noise") is added -* to drown denormals - IF ( L2PERT ) THEN -* XSC = SQRT(SMALL) - XSC = EPSLN / DFLOAT(N) - DO 1947 q = 1, NR - CTEMP = DCMPLX(XSC*ABS(A(q,q)),ZERO) - DO 1949 p = 1, NR - IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) - $ .OR. ( p .LT. q ) ) -* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) - $ A(p,q) = CTEMP - 1949 CONTINUE - 1947 CONTINUE - ELSE - CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) - END IF -* -* .. and one-sided Jacobi rotations are started on a lower -* triangular matrix (plus perturbation which is ignored in -* the part which destroys triangular form (confusing?!)) -* - CALL ZGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA, - $ N, V, LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) -* - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) -* -* - ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN -* -* -> Singular Values and Right Singular Vectors <- -* - IF ( ALMORT ) THEN -* -* .. in this case NR equals N - DO 1998 p = 1, NR - CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL ZLACGV( N-p+1, V(p,p), 1 ) - 1998 CONTINUE - CALL ZLASET( 'Upper', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) -* - CALL ZGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA, - $ CWORK, LWORK, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - - ELSE -* -* .. two more QR factorizations ( one QRF is not enough, two require -* accumulated product of Jacobi rotations, three are perfect ) -* - CALL ZLASET( 'Lower', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) - CALL ZGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) - CALL ZLACPY( 'Lower', NR, NR, A, LDA, V, LDV ) - CALL ZLASET( 'Upper', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) - CALL ZGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) - DO 8998 p = 1, NR - CALL ZCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) - CALL ZLACGV( NR-p+1, V(p,p), 1 ) - 8998 CONTINUE - CALL ZLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) -* - CALL ZGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U, - $ LDU, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) - CALL ZLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) - CALL ZLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) - END IF -* - CALL ZUNMLQ( 'Left', 'C', N, N, NR, A, LDA, CWORK, - $ V, LDV, CWORK(N+1), LWORK-N, IERR ) -* - END IF -* - DO 8991 p = 1, N - CALL ZCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) - 8991 CONTINUE - CALL ZLACPY( 'All', N, N, A, LDA, V, LDV ) -* - IF ( TRANSP ) THEN - CALL ZLACPY( 'All', N, N, V, LDV, U, LDU ) - END IF -* - ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN -* -* .. Singular Values and Left Singular Vectors .. -* -* .. second preconditioning step to avoid need to accumulate -* Jacobi rotations in the Jacobi iterations. - DO 1965 p = 1, NR - CALL ZCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) - CALL ZLACGV( N-p+1, U(p,p), 1 ) - 1965 CONTINUE - CALL ZLASET( 'Upper', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) -* - CALL ZGEQRF( N, NR, U, LDU, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) -* - DO 1967 p = 1, NR - 1 - CALL ZCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) - CALL ZLACGV( N-p+1, U(p,p), 1 ) - 1967 CONTINUE - CALL ZLASET( 'Upper', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) -* - CALL ZGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, - $ LDA, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) -* - IF ( NR .LT. M ) THEN - CALL ZLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) - IF ( NR .LT. N1 ) THEN - CALL ZLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) - CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) - END IF - END IF -* - CALL ZUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) -* - IF ( ROWPIV ) - $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - DO 1974 p = 1, N1 - XSC = ONE / DZNRM2( M, U(1,p), 1 ) - CALL ZDSCAL( M, XSC, U(1,p), 1 ) - 1974 CONTINUE -* - IF ( TRANSP ) THEN - CALL ZLACPY( 'All', N, N, U, LDU, V, LDV ) - END IF -* - ELSE -* -* .. Full SVD .. -* - IF ( .NOT. JRACC ) THEN -* - IF ( .NOT. ALMORT ) THEN -* -* Second Preconditioning Step (QRF [with pivoting]) -* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is -* equivalent to an LQF CALL. Since in many libraries the QRF -* seems to be better optimized than the LQF, we do explicit -* transpose and use the QRF. This is subject to changes in an -* optimized implementation of ZGEJSV. -* - DO 1968 p = 1, NR - CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL ZLACGV( N-p+1, V(p,p), 1 ) - 1968 CONTINUE -* -* .. the following two loops perturb small entries to avoid -* denormals in the second QR factorization, where they are -* as good as zeros. This is done to avoid painfully slow -* computation with denormals. The relative size of the perturbation -* is a parameter that can be changed by the implementer. -* This perturbation device will be obsolete on machines with -* properly implemented arithmetic. -* To switch it off, set L2PERT=.FALSE. To remove it from the -* code, remove the action under L2PERT=.TRUE., leave the ELSE part. -* The following two loops should be blocked and fused with the -* transposed copy above. -* - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL) - DO 2969 q = 1, NR - CTEMP = DCMPLX(XSC*ABS( V(q,q) ),ZERO) - DO 2968 p = 1, N - IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) - $ .OR. ( p .LT. q ) ) -* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) - $ V(p,q) = CTEMP - IF ( p .LT. q ) V(p,q) = - V(p,q) - 2968 CONTINUE - 2969 CONTINUE - ELSE - CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) - END IF -* -* Estimate the row scaled condition number of R1 -* (If R1 is rectangular, N > NR, then the condition number -* of the leading NR x NR submatrix is estimated.) -* - CALL ZLACPY( 'L', NR, NR, V, LDV, CWORK(2*N+1), NR ) - DO 3950 p = 1, NR - TEMP1 = DZNRM2(NR-p+1,CWORK(2*N+(p-1)*NR+p),1) - CALL ZDSCAL(NR-p+1,ONE/TEMP1,CWORK(2*N+(p-1)*NR+p),1) - 3950 CONTINUE - CALL ZPOCON('Lower',NR,CWORK(2*N+1),NR,ONE,TEMP1, - $ CWORK(2*N+NR*NR+1),RWORK,IERR) - CONDR1 = ONE / DSQRT(TEMP1) -* .. here need a second oppinion on the condition number -* .. then assume worst case scenario -* R1 is OK for inverse <=> CONDR1 .LT. DFLOAT(N) -* more conservative <=> CONDR1 .LT. SQRT(DFLOAT(N)) -* - COND_OK = DSQRT(DSQRT(DFLOAT(NR))) -*[TP] COND_OK is a tuning parameter. -* - IF ( CONDR1 .LT. COND_OK ) THEN -* .. the second QRF without pivoting. Note: in an optimized -* implementation, this QRF should be implemented as the QRF -* of a lower triangular matrix. -* R1^* = Q2 * R2 - CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) -* - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL)/EPSLN - DO 3959 p = 2, NR - DO 3958 q = 1, p - 1 - CTEMP=DCMPLX(XSC*DMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) - IF ( ABS(V(q,p)) .LE. TEMP1 ) -* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) - $ V(q,p) = CTEMP - 3958 CONTINUE - 3959 CONTINUE - END IF -* - IF ( NR .NE. N ) - $ CALL ZLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) -* .. save ... -* -* .. this transposed copy should be better than naive - DO 1969 p = 1, NR - 1 - CALL ZCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) - CALL ZLACGV(NR-p+1, V(p,p), 1 ) - 1969 CONTINUE - V(NR,NR)=DCONJG(V(NR,NR)) -* - CONDR2 = CONDR1 -* - ELSE -* -* .. ill-conditioned case: second QRF with pivoting -* Note that windowed pivoting would be equaly good -* numerically, and more run-time efficient. So, in -* an optimal implementation, the next call to ZGEQP3 -* should be replaced with eg. CALL ZGEQPX (ACM TOMS #782) -* with properly (carefully) chosen parameters. -* -* R1^* * P2 = Q2 * R2 - DO 3003 p = 1, NR - IWORK(N+p) = 0 - 3003 CONTINUE - CALL ZGEQP3( N, NR, V, LDV, IWORK(N+1), CWORK(N+1), - $ CWORK(2*N+1), LWORK-2*N, RWORK, IERR ) -** CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), -** $ LWORK-2*N, IERR ) - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL) - DO 3969 p = 2, NR - DO 3968 q = 1, p - 1 - CTEMP=DCMPLX(XSC*DMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) - IF ( ABS(V(q,p)) .LE. TEMP1 ) -* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) - $ V(q,p) = CTEMP - 3968 CONTINUE - 3969 CONTINUE - END IF -* - CALL ZLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) -* - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL) - DO 8970 p = 2, NR - DO 8971 q = 1, p - 1 - CTEMP=DCMPLX(XSC*DMIN1(ABS(V(p,p)),ABS(V(q,q))), - $ ZERO) -* V(p,q) = - TEMP1*( V(q,p) / ABS(V(q,p)) ) - V(p,q) = - CTEMP - 8971 CONTINUE - 8970 CONTINUE - ELSE - CALL ZLASET( 'L',NR-1,NR-1,CZERO,CZERO,V(2,1),LDV ) - END IF -* Now, compute R2 = L3 * Q3, the LQ factorization. - CALL ZGELQF( NR, NR, V, LDV, CWORK(2*N+N*NR+1), - $ CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) -* .. and estimate the condition number - CALL ZLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) - DO 4950 p = 1, NR - TEMP1 = DZNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) - CALL ZDSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) - 4950 CONTINUE - CALL ZPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, - $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) - CONDR2 = ONE / DSQRT(TEMP1) -* -* - IF ( CONDR2 .GE. COND_OK ) THEN -* .. save the Householder vectors used for Q3 -* (this overwrittes the copy of R2, as it will not be -* needed in this branch, but it does not overwritte the -* Huseholder vectors of Q2.). - CALL ZLACPY( 'U', NR, NR, V, LDV, CWORK(2*N+1), N ) -* .. and the rest of the information on Q3 is in -* WORK(2*N+N*NR+1:2*N+N*NR+N) - END IF -* - END IF -* - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL) - DO 4968 q = 2, NR - CTEMP = XSC * V(q,q) - DO 4969 p = 1, q - 1 -* V(p,q) = - TEMP1*( V(p,q) / ABS(V(p,q)) ) - V(p,q) = - CTEMP - 4969 CONTINUE - 4968 CONTINUE - ELSE - CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) - END IF -* -* Second preconditioning finished; continue with Jacobi SVD -* The input matrix is lower trinagular. -* -* Recover the right singular vectors as solution of a well -* conditioned triangular matrix equation. -* - IF ( CONDR1 .LT. COND_OK ) THEN -* - CALL ZGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, LDU, - $ CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,RWORK, - $ LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 3970 p = 1, NR - CALL ZCOPY( NR, V(1,p), 1, U(1,p), 1 ) - CALL ZDSCAL( NR, SVA(p), V(1,p), 1 ) - 3970 CONTINUE - -* .. pick the right matrix equation and solve it -* - IF ( NR .EQ. N ) THEN -* :)) .. best case, R1 is inverted. The solution of this matrix -* equation is Q2*V2 = the product of the Jacobi rotations -* used in ZGESVJ, premultiplied with the orthogonal matrix -* from the second QR factorization. - CALL ZTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) - ELSE -* .. R1 is well conditioned, but non-square. Adjoint of R2 -* is inverted to get the product of the Jacobi rotations -* used in ZGESVJ. The Q-factor from the second QR -* factorization is then built in explicitly. - CALL ZTRSM('L','U','C','N',NR,NR,CONE,CWORK(2*N+1), - $ N,V,LDV) - IF ( NR .LT. N ) THEN - CALL ZLASET('A',N-NR,NR,ZERO,CZERO,V(NR+1,1),LDV) - CALL ZLASET('A',NR,N-NR,ZERO,CZERO,V(1,NR+1),LDV) - CALL ZLASET('A',N-NR,N-NR,ZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL ZUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) - END IF -* - ELSE IF ( CONDR2 .LT. COND_OK ) THEN -* -* The matrix R2 is inverted. The solution of the matrix equation -* is Q3^* * V3 = the product of the Jacobi rotations (appplied to -* the lower triangular L3 from the LQ factorization of -* R2=L3*Q3), pre-multiplied with the transposed Q3. - CALL ZGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, - $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 3870 p = 1, NR - CALL ZCOPY( NR, V(1,p), 1, U(1,p), 1 ) - CALL ZDSCAL( NR, SVA(p), U(1,p), 1 ) - 3870 CONTINUE - CALL ZTRSM('L','U','N','N',NR,NR,CONE,CWORK(2*N+1),N, - $ U,LDU) -* .. apply the permutation from the second QR factorization - DO 873 q = 1, NR - DO 872 p = 1, NR - CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) - 872 CONTINUE - DO 874 p = 1, NR - U(p,q) = CWORK(2*N+N*NR+NR+p) - 874 CONTINUE - 873 CONTINUE - IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) - ELSE -* Last line of defense. -* #:( This is a rather pathological case: no scaled condition -* improvement after two pivoted QR factorizations. Other -* possibility is that the rank revealing QR factorization -* or the condition estimator has failed, or the COND_OK -* is set very close to ONE (which is unnecessary). Normally, -* this branch should never be executed, but in rare cases of -* failure of the RRQR or condition estimator, the last line of -* defense ensures that ZGEJSV completes the task. -* Compute the full SVD of L3 using ZGESVJ with explicit -* accumulation of Jacobi rotations. - CALL ZGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, - $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) - CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) - CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) - END IF - CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) -* - CALL ZUNMLQ( 'L', 'C', NR, NR, NR, CWORK(2*N+1), N, - $ CWORK(2*N+N*NR+1), U, LDU, CWORK(2*N+N*NR+NR+1), - $ LWORK-2*N-N*NR-NR, IERR ) - DO 773 q = 1, NR - DO 772 p = 1, NR - CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) - 772 CONTINUE - DO 774 p = 1, NR - U(p,q) = CWORK(2*N+N*NR+NR+p) - 774 CONTINUE - 773 CONTINUE -* - END IF -* -* Permute the rows of V using the (column) permutation from the -* first QRF. Also, scale the columns to make them unit in -* Euclidean norm. This applies to all cases. -* - TEMP1 = DSQRT(DFLOAT(N)) * EPSLN - DO 1972 q = 1, N - DO 972 p = 1, N - CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) - 972 CONTINUE - DO 973 p = 1, N - V(p,q) = CWORK(2*N+N*NR+NR+p) - 973 CONTINUE - XSC = ONE / DZNRM2( N, V(1,q), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL ZDSCAL( N, XSC, V(1,q), 1 ) - 1972 CONTINUE -* At this moment, V contains the right singular vectors of A. -* Next, assemble the left singular vector matrix U (M x N). - IF ( NR .LT. M ) THEN - CALL ZLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) - IF ( NR .LT. N1 ) THEN - CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) - CALL ZLASET('A',M-NR,N1-NR,CZERO,CONE, - $ U(NR+1,NR+1),LDU) - END IF - END IF -* -* The Q matrix from the first QRF is built into the left singular -* matrix U. This applies to all cases. -* - CALL ZUNMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) - -* The columns of U are normalized. The cost is O(M*N) flops. - TEMP1 = DSQRT(DFLOAT(M)) * EPSLN - DO 1973 p = 1, NR - XSC = ONE / DZNRM2( M, U(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL ZDSCAL( M, XSC, U(1,p), 1 ) - 1973 CONTINUE -* -* If the initial QRF is computed with row pivoting, the left -* singular vectors must be adjusted. -* - IF ( ROWPIV ) - $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - ELSE -* -* .. the initial matrix A has almost orthogonal columns and -* the second QRF is not needed -* - CALL ZLACPY( 'Upper', N, N, A, LDA, CWORK(N+1), N ) - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL) - DO 5970 p = 2, N - CTEMP = XSC * CWORK( N + (p-1)*N + p ) - DO 5971 q = 1, p - 1 -* CWORK(N+(q-1)*N+p)=-TEMP1 * ( CWORK(N+(p-1)*N+q) / -* $ ABS(CWORK(N+(p-1)*N+q)) ) - CWORK(N+(q-1)*N+p)=-CTEMP - 5971 CONTINUE - 5970 CONTINUE - ELSE - CALL ZLASET( 'Lower',N-1,N-1,CZERO,CZERO,CWORK(N+2),N ) - END IF -* - CALL ZGESVJ( 'Upper', 'U', 'N', N, N, CWORK(N+1), N, SVA, - $ N, U, LDU, CWORK(N+N*N+1), LWORK-N-N*N, RWORK, LRWORK, - $ INFO ) -* - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - DO 6970 p = 1, N - CALL ZCOPY( N, CWORK(N+(p-1)*N+1), 1, U(1,p), 1 ) - CALL ZDSCAL( N, SVA(p), CWORK(N+(p-1)*N+1), 1 ) - 6970 CONTINUE -* - CALL ZTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N, - $ CONE, A, LDA, CWORK(N+1), N ) - DO 6972 p = 1, N - CALL ZCOPY( N, CWORK(N+p), N, V(IWORK(p),1), LDV ) - 6972 CONTINUE - TEMP1 = DSQRT(DFLOAT(N))*EPSLN - DO 6971 p = 1, N - XSC = ONE / DZNRM2( N, V(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL ZDSCAL( N, XSC, V(1,p), 1 ) - 6971 CONTINUE -* -* Assemble the left singular vector matrix U (M x N). -* - IF ( N .LT. M ) THEN - CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) - IF ( N .LT. N1 ) THEN - CALL ZLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) - CALL ZLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) - END IF - END IF - CALL ZUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) - TEMP1 = DSQRT(DFLOAT(M))*EPSLN - DO 6973 p = 1, N1 - XSC = ONE / DZNRM2( M, U(1,p), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL ZDSCAL( M, XSC, U(1,p), 1 ) - 6973 CONTINUE -* - IF ( ROWPIV ) - $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* - END IF -* -* end of the >> almost orthogonal case << in the full SVD -* - ELSE -* -* This branch deploys a preconditioned Jacobi SVD with explicitly -* accumulated rotations. It is included as optional, mainly for -* experimental purposes. It does perfom well, and can also be used. -* In this implementation, this branch will be automatically activated -* if the condition number sigma_max(A) / sigma_min(A) is predicted -* to be greater than the overflow threshold. This is because the -* a posteriori computation of the singular vectors assumes robust -* implementation of BLAS and some LAPACK procedures, capable of working -* in presence of extreme values. Since that is not always the case, ... -* - DO 7968 p = 1, NR - CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) - CALL ZLACGV( N-p+1, V(p,p), 1 ) - 7968 CONTINUE -* - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL/EPSLN) - DO 5969 q = 1, NR - CTEMP = DCMPLX(XSC*ABS( V(q,q) ),ZERO) - DO 5968 p = 1, N - IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) - $ .OR. ( p .LT. q ) ) -* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) - $ V(p,q) = CTEMP - IF ( p .LT. q ) V(p,q) = - V(p,q) - 5968 CONTINUE - 5969 CONTINUE - ELSE - CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) - END IF - - CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), - $ LWORK-2*N, IERR ) - CALL ZLACPY( 'L', N, NR, V, LDV, CWORK(2*N+1), N ) -* - DO 7969 p = 1, NR - CALL ZCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) - CALL ZLACGV( NR-p+1, U(p,p), 1 ) - 7969 CONTINUE - - IF ( L2PERT ) THEN - XSC = DSQRT(SMALL/EPSLN) - DO 9970 q = 2, NR - DO 9971 p = 1, q - 1 - CTEMP = DCMPLX(XSC * DMIN1(ABS(U(p,p)),ABS(U(q,q))), - $ ZERO) -* U(p,q) = - TEMP1 * ( U(q,p) / ABS(U(q,p)) ) - U(p,q) = - CTEMP - 9971 CONTINUE - 9970 CONTINUE - ELSE - CALL ZLASET('U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) - END IF - - CALL ZGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA, - $ N, V, LDV, CWORK(2*N+N*NR+1), LWORK-2*N-N*NR, - $ RWORK, LRWORK, INFO ) - SCALEM = RWORK(1) - NUMRANK = NINT(RWORK(2)) - - IF ( NR .LT. N ) THEN - CALL ZLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) - CALL ZLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) - CALL ZLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) - END IF - - CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), - $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) -* -* Permute the rows of V using the (column) permutation from the -* first QRF. Also, scale the columns to make them unit in -* Euclidean norm. This applies to all cases. -* - TEMP1 = DSQRT(DFLOAT(N)) * EPSLN - DO 7972 q = 1, N - DO 8972 p = 1, N - CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) - 8972 CONTINUE - DO 8973 p = 1, N - V(p,q) = CWORK(2*N+N*NR+NR+p) - 8973 CONTINUE - XSC = ONE / DZNRM2( N, V(1,q), 1 ) - IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) - $ CALL ZDSCAL( N, XSC, V(1,q), 1 ) - 7972 CONTINUE -* -* At this moment, V contains the right singular vectors of A. -* Next, assemble the left singular vector matrix U (M x N). -* - IF ( NR .LT. M ) THEN - CALL ZLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) - IF ( NR .LT. N1 ) THEN - CALL ZLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) - CALL ZLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) - END IF - END IF -* - CALL ZUNMQR( 'Left', 'No Tr', M, N1, N, A, LDA, CWORK, U, - $ LDU, CWORK(N+1), LWORK-N, IERR ) -* - IF ( ROWPIV ) - $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) -* -* - END IF - IF ( TRANSP ) THEN -* .. swap U and V because the procedure worked on A^* - DO 6974 p = 1, N - CALL ZSWAP( N, U(1,p), 1, V(1,p), 1 ) - 6974 CONTINUE - END IF -* - END IF -* end of the full SVD -* -* Undo scaling, if necessary (and possible) -* - IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN - CALL ZLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) - USCAL1 = ONE - USCAL2 = ONE - END IF -* - IF ( NR .LT. N ) THEN - DO 3004 p = NR+1, N - SVA(p) = ZERO - 3004 CONTINUE - END IF -* - RWORK(1) = USCAL2 * SCALEM - RWORK(2) = USCAL1 - IF ( ERREST ) RWORK(3) = SCONDA - IF ( LSVEC .AND. RSVEC ) THEN - RWORK(4) = CONDR1 - RWORK(5) = CONDR2 - END IF - IF ( L2TRAN ) THEN - RWORK(6) = ENTRA - RWORK(7) = ENTRAT - END IF -* - IWORK(1) = NR - IWORK(2) = NUMRANK - IWORK(3) = WARNING -* - RETURN -* .. -* .. END OF ZGEJSV -* .. - END -* +*> \brief \b ZGEJSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEJSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, +* M, N, A, LDA, SVA, U, LDU, V, LDV, +* CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* IMPLICIT NONE +* INTEGER INFO, LDA, LDU, LDV, LWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) +* DOUBLE PRECISION SVA( N ), RWORK( LRWORK ) +* INTEGER IWORK( * ) +* CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEJSV computes the singular value decomposition (SVD) of a complex M-by-N +*> matrix [A], where M >= N. The SVD of [A] is written as +*> +*> [A] = [U] * [SIGMA] * [V]^*, +*> +*> where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N +*> diagonal elements, [U] is an M-by-N (or M-by-M) unitary matrix, and +*> [V] is an N-by-N unitary matrix. The diagonal elements of [SIGMA] are +*> the singular values of [A]. The columns of [U] and [V] are the left and +*> the right singular vectors of [A], respectively. The matrices [U] and [V] +*> are computed and stored in the arrays U and V, respectively. The diagonal +*> of [SIGMA] is computed and stored in the array SVA. +*> \endverbatim +*> +*> Arguments: +*> ========== +*> +*> \param[in] JOBA +*> \verbatim +*> JOBA is CHARACTER*1 +*> Specifies the level of accuracy: +*> = 'C': This option works well (high relative accuracy) if A = B * D, +*> with well-conditioned B and arbitrary diagonal matrix D. +*> The accuracy cannot be spoiled by COLUMN scaling. The +*> accuracy of the computed output depends on the condition of +*> B, and the procedure aims at the best theoretical accuracy. +*> The relative error max_{i=1:N}|d sigma_i| / sigma_i is +*> bounded by f(M,N)*epsilon* cond(B), independent of D. +*> The input matrix is preprocessed with the QRF with column +*> pivoting. This initial preprocessing and preconditioning by +*> a rank revealing QR factorization is common for all values of +*> JOBA. Additional actions are specified as follows: +*> = 'E': Computation as with 'C' with an additional estimate of the +*> condition number of B. It provides a realistic error bound. +*> = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings +*> D1, D2, and well-conditioned matrix C, this option gives +*> higher accuracy than the 'C' option. If the structure of the +*> input matrix is not known, and relative accuracy is +*> desirable, then this option is advisable. The input matrix A +*> is preprocessed with QR factorization with FULL (row and +*> column) pivoting. +*> = 'G' Computation as with 'F' with an additional estimate of the +*> condition number of B, where A=B*D. If A has heavily weighted +*> rows, then using this condition number gives too pessimistic +*> error bound. +*> = 'A': Small singular values are not well determined by the data +*> and are considered as noisy; the matrix is treated as +*> numerically rank defficient. The error in the computed +*> singular values is bounded by f(m,n)*epsilon*||A||. +*> The computed SVD A = U * S * V^* restores A up to +*> f(m,n)*epsilon*||A||. +*> This gives the procedure the licence to discard (set to zero) +*> all singular values below N*epsilon*||A||. +*> = 'R': Similar as in 'A'. Rank revealing property of the initial +*> QR factorization is used do reveal (using triangular factor) +*> a gap sigma_{r+1} < epsilon * sigma_r in which case the +*> numerical RANK is declared to be r. The SVD is computed with +*> absolute error bounds, but more accurately than with 'A'. +*> \endverbatim +*> +*> \param[in] JOBU +*> \verbatim +*> JOBU is CHARACTER*1 +*> Specifies whether to compute the columns of U: +*> = 'U': N columns of U are returned in the array U. +*> = 'F': full set of M left sing. vectors is returned in the array U. +*> = 'W': U may be used as workspace of length M*N. See the description +*> of U. +*> = 'N': U is not computed. +*> \endverbatim +*> +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether to compute the matrix V: +*> = 'V': N columns of V are returned in the array V; Jacobi rotations +*> are not explicitly accumulated. +*> = 'J': N columns of V are returned in the array V, but they are +*> computed as the product of Jacobi rotations, if JOBT .EQ. 'N'. +*> = 'W': V may be used as workspace of length N*N. See the description +*> of V. +*> = 'N': V is not computed. +*> \endverbatim +*> +*> \param[in] JOBR +*> \verbatim +*> JOBR is CHARACTER*1 +*> Specifies the RANGE for the singular values. Issues the licence to +*> set to zero small positive singular values if they are outside +*> specified range. If A .NE. 0 is scaled so that the largest singular +*> value of c*A is around SQRT(BIG), BIG=DLAMCH('O'), then JOBR issues +*> the licence to kill columns of A whose norm in c*A is less than +*> SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, +*> where SFMIN=DLAMCH('S'), EPSLN=DLAMCH('E'). +*> = 'N': Do not kill small columns of c*A. This option assumes that +*> BLAS and QR factorizations and triangular solvers are +*> implemented to work in that range. If the condition of A +*> is greater than BIG, use ZGESVJ. +*> = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] +*> (roughly, as described above). This option is recommended. +*> =========================== +*> For computing the singular values in the FULL range [SFMIN,BIG] +*> use ZGESVJ. +*> \endverbatim +*> +*> \param[in] JOBT +*> \verbatim +*> JOBT is CHARACTER*1 +*> If the matrix is square then the procedure may determine to use +*> transposed A if A^* seems to be better with respect to convergence. +*> If the matrix is not square, JOBT is ignored. +*> The decision is based on two values of entropy over the adjoint +*> orbit of A^* * A. See the descriptions of WORK(6) and WORK(7). +*> = 'T': transpose if entropy test indicates possibly faster +*> convergence of Jacobi process if A^* is taken as input. If A is +*> replaced with A^*, then the row pivoting is included automatically. +*> = 'N': do not speculate. +*> The option 'T' can be used to compute only the singular values, or +*> the full SVD (U, SIGMA and V). For only one set of singular vectors +*> (U or V), the caller should provide both U and V, as one of the +*> matrices is used as workspace if the matrix A is transposed. +*> The implementer can easily remove this constraint and make the +*> code more complicated. See the descriptions of U and V. +*> In general, this option is considered experimental, and 'N'; should +*> be preferred. This is subject to changes in the future. +*> \endverbatim +*> +*> \param[in] JOBP +*> \verbatim +*> JOBP is CHARACTER*1 +*> Issues the licence to introduce structured perturbations to drown +*> denormalized numbers. This licence should be active if the +*> denormals are poorly implemented, causing slow computation, +*> especially in cases of fast convergence (!). For details see [1,2]. +*> For the sake of simplicity, this perturbations are included only +*> when the full SVD or only the singular values are requested. The +*> implementer/user can easily add the perturbation for the cases of +*> computing one set of singular vectors. +*> = 'P': introduce perturbation +*> = 'N': do not perturb +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] SVA +*> \verbatim +*> SVA is DOUBLE PRECISION array, dimension (N) +*> On exit, +*> - For WORK(1)/WORK(2) = ONE: The singular values of A. During the +*> computation SVA contains Euclidean column norms of the +*> iterated matrices in the array A. +*> - For WORK(1) .NE. WORK(2): The singular values of A are +*> (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if +*> sigma_max(A) overflows or if small singular values have been +*> saved from underflow by scaling the input matrix A. +*> - If JOBR='R' then some of the singular values may be returned +*> as exact zeros obtained by "set to zero" because they are +*> below the numerical rank threshold or are denormalized numbers. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array, dimension ( LDU, N ) +*> If JOBU = 'U', then U contains on exit the M-by-N matrix of +*> the left singular vectors. +*> If JOBU = 'F', then U contains on exit the M-by-M matrix of +*> the left singular vectors, including an ONB +*> of the orthogonal complement of the Range(A). +*> If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), +*> then U is used as workspace if the procedure +*> replaces A with A^*. In that case, [V] is computed +*> in U as left singular vectors of A^* and then +*> copied back to the V array. This 'W' option is just +*> a reminder to the caller that in this case U is +*> reserved as workspace of length N*N. +*> If JOBU = 'N' U is not referenced, unless JOBT='T'. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of the array U, LDU >= 1. +*> IF JOBU = 'U' or 'F' or 'W', then LDU >= M. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension ( LDV, N ) +*> If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of +*> the right singular vectors; +*> If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), +*> then V is used as workspace if the pprocedure +*> replaces A with A^*. In that case, [U] is computed +*> in V as right singular vectors of A^* and then +*> copied back to the U array. This 'W' option is just +*> a reminder to the caller that in this case V is +*> reserved as workspace of length N*N. +*> If JOBV = 'N' V is not referenced, unless JOBT='T'. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV >= 1. +*> If JOBV = 'V' or 'J' or 'W', then LDV >= N. +*> \endverbatim +*> +*> \param[out] CWORK +*> \verbatim +*> CWORK is COMPLEX*16 array, dimension (MAX(2,LWORK)) +*> If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit CWORK(1) contains the required length of +*> CWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> Length of CWORK to confirm proper allocation of workspace. +*> LWORK depends on the job: +*> +*> 1. If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and +*> 1.1 .. no scaled condition estimate required (JOBA.NE.'E'.AND.JOBA.NE.'G'): +*> LWORK >= 2*N+1. This is the minimal requirement. +*> ->> For optimal performance (blocked code) the optimal value +*> is LWORK >= N + (N+1)*NB. Here NB is the optimal +*> block size for ZGEQP3 and ZGEQRF. +*> In general, optimal LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF), LWORK(ZGESVJ)). +*> 1.2. .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). In this case, LWORK the minimal +*> requirement is LWORK >= N*N + 2*N. +*> ->> For optimal performance (blocked code) the optimal value +*> is LWORK >= max(N+(N+1)*NB, N*N+2*N)=N**2+2*N. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF), LWORK(ZGESVJ), +*> N*N+LWORK(ZPOCON)). +*> 2. If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), +*> (JOBU.EQ.'N') +*> 2.1 .. no scaled condition estimate requested (JOBE.EQ.'N'): +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance, +*> LWORK >= max(N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for ZGEQP3, ZGEQRF, ZGELQ, +*> ZUNMLQ. In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3), N+LWORK(ZGESVJ), +*> N+LWORK(ZGELQF), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMLQ)). +*> 2.2 .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance, +*> LWORK >= max(N+(N+1)*NB, 2*N,2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for ZGEQP3, ZGEQRF, ZGELQ, +*> ZUNMLQ. In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3), LWORK(ZPOCON), N+LWORK(ZGESVJ), +*> N+LWORK(ZGELQF), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMLQ)). +*> 3. If SIGMA and the left singular vectors are needed +*> 3.1 .. no scaled condition estimate requested (JOBE.EQ.'N'): +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance: +*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for ZGEQP3, ZGEQRF, ZUNMQR. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMQR)). +*> 3.2 .. an estimate of the scaled condition number of A is +*> required (JOBA='E', or 'G'). +*> -> the minimal requirement is LWORK >= 3*N. +*> -> For optimal performance: +*> if JOBU.EQ.'U' :: LWORK >= max(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, +*> where NB is the optimal block size for ZGEQP3, ZGEQRF, ZUNMQR. +*> In general, the optimal length LWORK is computed as +*> LWORK >= max(N+LWORK(ZGEQP3),N+LWORK(ZPOCON), +*> 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMQR)). +*> 4. If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and +*> 4.1. if JOBV.EQ.'V' +*> the minimal requirement is LWORK >= 5*N+2*N*N. +*> 4.2. if JOBV.EQ.'J' the minimal requirement is +*> LWORK >= 4*N+N*N. +*> In both cases, the allocated CWORK can accommodate blocked runs +*> of ZGEQP3, ZGEQRF, ZGELQF, SUNMQR, ZUNMLQ. +*> +*> If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit CWORK(1) contains the optimal and CWORK(2) contains the +*> minimal length of CWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (MAX(7,LWORK)) +*> On exit, +*> RWORK(1) = Determines the scaling factor SCALE = RWORK(2) / RWORK(1) +*> such that SCALE*SVA(1:N) are the computed singular values +*> of A. (See the description of SVA().) +*> RWORK(2) = See the description of RWORK(1). +*> RWORK(3) = SCONDA is an estimate for the condition number of +*> column equilibrated A. (If JOBA .EQ. 'E' or 'G') +*> SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). +*> It is computed using SPOCON. It holds +*> N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA +*> where R is the triangular factor from the QRF of A. +*> However, if R is truncated and the numerical rank is +*> determined to be strictly smaller than N, SCONDA is +*> returned as -1, thus indicating that the smallest +*> singular values might be lost. +*> +*> If full SVD is needed, the following two condition numbers are +*> useful for the analysis of the algorithm. They are provied for +*> a developer/implementer who is familiar with the details of +*> the method. +*> +*> RWORK(4) = an estimate of the scaled condition number of the +*> triangular factor in the first QR factorization. +*> RWORK(5) = an estimate of the scaled condition number of the +*> triangular factor in the second QR factorization. +*> The following two parameters are computed if JOBT .EQ. 'T'. +*> They are provided for a developer/implementer who is familiar +*> with the details of the method. +*> RWORK(6) = the entropy of A^* * A :: this is the Shannon entropy +*> of diag(A^* * A) / Trace(A^* * A) taken as point in the +*> probability simplex. +*> RWORK(7) = the entropy of A * A^*. (See the description of RWORK(6).) +*> If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or +*> LRWORK=-1), then on exit RWORK(1) contains the required length of +*> RWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> Length of RWORK to confirm proper allocation of workspace. +*> LRWORK depends on the job: +*> +*> 1. If only the singular values are requested i.e. if +*> LSAME(JOBU,'N') .AND. LSAME(JOBV,'N') +*> then: +*> 1.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then: LRWORK = max( 7, 2 * M ). +*> 1.2. Otherwise, LRWORK = max( 7, N ). +*> 2. If singular values with the right singular vectors are requested +*> i.e. if +*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) .AND. +*> .NOT.(LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) +*> then: +*> 2.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 2.2. Otherwise, LRWORK = max( 7, N ). +*> 3. If singular values with the left singular vectors are requested, i.e. if +*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. +*> .NOT.(LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) +*> then: +*> 3.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 3.2. Otherwise, LRWORK = max( 7, N ). +*> 4. If singular values with both the left and the right singular vectors +*> are requested, i.e. if +*> (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. +*> (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) +*> then: +*> 4.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), +*> then LRWORK = max( 7, 2 * M ). +*> 4.2. Otherwise, LRWORK = max( 7, N ). +*> +*> If, on entry, LRWORK = -1 or LWORK=-1, a workspace query is assumed and +*> the length of RWORK is returned in RWORK(1). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, of dimension at least 4, that further depends +*> on the job: +*> +*> 1. If only the singular values are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 2. If the singular values and the right singular vectors are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 3. If the singular values and the left singular vectors are requested then: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 4. If the singular values with both the left and the right singular vectors +*> are requested, then: +*> 4.1. If LSAME(JOBV,'J') the length of IWORK is determined as follows: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is N+M; otherwise the length of IWORK is N. +*> 4.2. If LSAME(JOBV,'V') the length of IWORK is determined as follows: +*> If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) +*> then the length of IWORK is 2*N+M; otherwise the length of IWORK is 2*N. +*> +*> On exit, +*> IWORK(1) = the numerical rank determined after the initial +*> QR factorization with pivoting. See the descriptions +*> of JOBA and JOBR. +*> IWORK(2) = the number of the computed nonzero singular values +*> IWORK(3) = if nonzero, a warning message: +*> If IWORK(3).EQ.1 then some of the column norms of A +*> were denormalized floats. The requested high accuracy +*> is not warranted by the data. +*> IWORK(4) = 1 or -1. If IWORK(4) .EQ. 1, then the procedure used A^* to +*> do the job as specified by the JOB parameters. +*> If the call to ZGEJSV is a workspace query (indicated by LWORK .EQ. -1 or +*> LRWORK .EQ. -1), then on exit IWORK(1) contains the required length of +*> IWORK for the job parameters used in the call. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> < 0 : if INFO = -i, then the i-th argument had an illegal value. +*> = 0 : successful exit; +*> > 0 : ZGEJSV did not converge in the maximal allowed number +*> of sweeps. The computed values may be inaccurate. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16GEsing +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> ZGEJSV implements a preconditioned Jacobi SVD algorithm. It uses ZGEQP3, +*> ZGEQRF, and ZGELQF as preprocessors and preconditioners. Optionally, an +*> additional row pivoting can be used as a preprocessor, which in some +*> cases results in much higher accuracy. An example is matrix A with the +*> structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned +*> diagonal matrices and C is well-conditioned matrix. In that case, complete +*> pivoting in the first QR factorizations provides accuracy dependent on the +*> condition number of C, and independent of D1, D2. Such higher accuracy is +*> not completely understood theoretically, but it works well in practice. +*> Further, if A can be written as A = B*D, with well-conditioned B and some +*> diagonal D, then the high accuracy is guaranteed, both theoretically and +*> in software, independent of D. For more details see [1], [2]. +*> The computational range for the singular values can be the full range +*> ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS +*> & LAPACK routines called by ZGEJSV are implemented to work in that range. +*> If that is not the case, then the restriction for safe computation with +*> the singular values in the range of normalized IEEE numbers is that the +*> spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not +*> overflow. This code (ZGEJSV) is best used in this restricted range, +*> meaning that singular values of magnitude below ||A||_2 / DLAMCH('O') are +*> returned as zeros. See JOBR for details on this. +*> Further, this implementation is somewhat slower than the one described +*> in [1,2] due to replacement of some non-LAPACK components, and because +*> the choice of some tuning parameters in the iterative part (ZGESVJ) is +*> left to the implementer on a particular machine. +*> The rank revealing QR factorization (in this code: ZGEQP3) should be +*> implemented as in [3]. We have a new version of ZGEQP3 under development +*> that is more robust than the current one in LAPACK, with a cleaner cut in +*> rank deficient cases. It will be available in the SIGMA library [4]. +*> If M is much larger than N, it is obvious that the initial QRF with +*> column pivoting can be preprocessed by the QRF without pivoting. That +*> well known trick is not used in ZGEJSV because in some cases heavy row +*> weighting can be treated with complete pivoting. The overhead in cases +*> M much larger than N is then only due to pivoting, but the benefits in +*> terms of accuracy have prevailed. The implementer/user can incorporate +*> this extra QRF step easily. The implementer can also improve data movement +*> (matrix transpose, matrix copy, matrix transposed copy) - this +*> implementation of ZGEJSV uses only the simplest, naive data movement. +*> \endverbatim +* +*> \par Contributor: +* ================== +*> +*> Zlatko Drmac, Department of Mathematics, Faculty of Science, +*> University of Zagreb (Zagreb, Croatia); drmac@math.hr +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +*> LAPACK Working note 169. +*> [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +*> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +*> LAPACK Working note 170. +*> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR +*> factorization software - a case study. +*> ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. +*> LAPACK Working note 176. +*> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +*> QSVD, (H,K)-SVD computations. +*> Department of Mathematics, University of Zagreb, 2008, 2016. +*> \endverbatim +* +*> \par Bugs, examples and comments: +* ================================= +*> +*> Please report all bugs and send interesting examples and/or comments to +*> drmac@math.hr. Thank you. +*> +* ===================================================================== + SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, + $ M, N, A, LDA, SVA, U, LDU, V, LDV, + $ CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) +* +* -- LAPACK computational 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 .. + IMPLICIT NONE + INTEGER INFO, LDA, LDU, LDV, LWORK, LRWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), U( LDU, * ), V( LDV, * ), + $ CWORK( LWORK ) + DOUBLE PRECISION SVA( N ), RWORK( LRWORK ) + INTEGER IWORK( * ) + CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* =========================================================================== +* +* .. Local Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + COMPLEX*16 CTEMP + DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, + $ COND_OK, CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, + $ MAXPRJ, SCALEM, SCONDA, SFMIN, SMALL, TEMP1, + $ USCAL1, USCAL2, XSC + INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING + LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LQUERY, + $ LSVEC, L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, NOSCAL, + $ ROWPIV, RSVEC, TRANSP +* + INTEGER OPTWRK, MINWRK, MINRWRK, MINIWRK + INTEGER LWCON, LWLQF, LWQP3, LWQRF, LWUNMLQ, LWUNMQR, LWUNMQRM, + $ LWSVDJ, LWSVDJV, LRWQP3, LRWCON, LRWSVDJ, IWOFF + INTEGER LWRK_ZGELQF, LWRK_ZGEQP3, LWRK_ZGEQP3N, LWRK_ZGEQRF, + $ LWRK_ZGESVJ, LWRK_ZGESVJV, LWRK_ZGESVJU, LWRK_ZUNMLQ, + $ LWRK_ZUNMQR, LWRK_ZUNMQRM +* .. +* .. Local Arrays + COMPLEX*16 CDUMMY(1) + DOUBLE PRECISION RDUMMY(1) +* +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, CONJG, DLOG, MAX, MIN, DBLE, NINT, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DZNRM2 + INTEGER IDAMAX, IZAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, IZAMAX, LSAME, DLAMCH, DZNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ, ZCOPY, ZGELQF, ZGEQP3, ZGEQRF, ZLACPY, ZLAPMR, + $ ZLASCL, DLASCL, ZLASET, ZLASSQ, ZLASWP, ZUNGQR, ZUNMLQ, + $ ZUNMQR, ZPOCON, DSCAL, ZDSCAL, ZSWAP, ZTRSM, ZLACGV, + $ XERBLA +* + EXTERNAL ZGESVJ +* .. +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) + JRACC = LSAME( JOBV, 'J' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC + ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) + L2RANK = LSAME( JOBA, 'R' ) + L2ABER = LSAME( JOBA, 'A' ) + ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) + L2TRAN = LSAME( JOBT, 'T' ) .AND. ( M .EQ. N ) + L2KILL = LSAME( JOBR, 'R' ) + DEFR = LSAME( JOBR, 'N' ) + L2PERT = LSAME( JOBP, 'P' ) +* + LQUERY = ( LWORK .EQ. -1 ) .OR. ( LRWORK .EQ. -1 ) +* + IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. + $ ERREST .OR. LSAME( JOBA, 'C' ) )) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. + $ ( LSAME( JOBU, 'W' ) .AND. RSVEC .AND. L2TRAN ) ) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. + $ ( LSAME( JOBV, 'W' ) .AND. LSVEC .AND. L2TRAN ) ) ) THEN + INFO = - 3 + ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN + INFO = - 4 + ELSE IF ( .NOT. ( LSAME(JOBT,'T') .OR. LSAME(JOBT,'N') ) ) THEN + INFO = - 5 + ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN + INFO = - 6 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 7 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 8 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 10 + ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN + INFO = - 13 + ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN + INFO = - 15 + ELSE +* #:) + INFO = 0 + END IF +* + IF ( INFO .EQ. 0 ) THEN +* .. compute the minimal and the optimal workspace lengths +* [[The expressions for computing the minimal and the optimal +* values of LCWORK, LRWORK are written with a lot of redundancy and +* can be simplified. However, this verbose form is useful for +* maintenance and modifications of the code.]] +* +* .. minimal workspace length for ZGEQP3 of an M x N matrix, +* ZGEQRF of an N x N matrix, ZGELQF of an N x N matrix, +* ZUNMLQ for computing N x N matrix, ZUNMQR for computing N x N +* matrix, ZUNMQR for computing M x N matrix, respectively. + LWQP3 = N+1 + LWQRF = MAX( 1, N ) + LWLQF = MAX( 1, N ) + LWUNMLQ = MAX( 1, N ) + LWUNMQR = MAX( 1, N ) + LWUNMQRM = MAX( 1, M ) +* .. minimal workspace length for ZPOCON of an N x N matrix + LWCON = 2 * N +* .. minimal workspace length for ZGESVJ of an N x N matrix, +* without and with explicit accumulation of Jacobi rotations + LWSVDJ = MAX( 2 * N, 1 ) + LWSVDJV = MAX( 2 * N, 1 ) +* .. minimal REAL workspace length for ZGEQP3, ZPOCON, ZGESVJ + LRWQP3 = N + LRWCON = N + LRWSVDJ = N + IF ( LQUERY ) THEN + CALL ZGEQP3( M, N, A, LDA, IWORK, CDUMMY, CDUMMY, -1, + $ RDUMMY, IERR ) + LWRK_ZGEQP3 = CDUMMY(1) + CALL ZGEQRF( N, N, A, LDA, CDUMMY, CDUMMY,-1, IERR ) + LWRK_ZGEQRF = CDUMMY(1) + CALL ZGELQF( N, N, A, LDA, CDUMMY, CDUMMY,-1, IERR ) + LWRK_ZGELQF = CDUMMY(1) + END IF + MINWRK = 2 + OPTWRK = 2 + MINIWRK = N + IF ( .NOT. (LSVEC .OR. RSVEC ) ) THEN +* .. minimal and optimal sizes of the complex workspace if +* only the singular values are requested + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N**2+LWCON, N+LWQRF, LWSVDJ ) + ELSE + MINWRK = MAX( N+LWQP3, N+LWQRF, LWSVDJ ) + END IF + IF ( LQUERY ) THEN + CALL ZGESVJ( 'L', 'N', 'N', N, N, A, LDA, SVA, N, V, + $ LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_ZGEQP3, N**2+LWCON, + $ N+LWRK_ZGEQRF, LWRK_ZGESVJ ) + ELSE + OPTWRK = MAX( N+LWRK_ZGEQP3, N+LWRK_ZGEQRF, + $ LWRK_ZGESVJ ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWCON, LRWSVDJ ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWCON, LRWSVDJ ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE IF ( RSVEC .AND. (.NOT.LSVEC) ) THEN +* .. minimal and optimal sizes of the complex workspace if the +* singular values and the right singular vectors are requested + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, LWCON, LWSVDJ, N+LWLQF, + $ 2*N+LWQRF, N+LWSVDJ, N+LWUNMLQ ) + ELSE + MINWRK = MAX( N+LWQP3, LWSVDJ, N+LWLQF, 2*N+LWQRF, + $ N+LWSVDJ, N+LWUNMLQ ) + END IF + IF ( LQUERY ) THEN + CALL ZGESVJ( 'L', 'U', 'N', N,N, U, LDU, SVA, N, A, + $ LDA, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJ = CDUMMY(1) + CALL ZUNMLQ( 'L', 'C', N, N, N, A, LDA, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_ZUNMLQ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_ZGEQP3, LWCON, LWRK_ZGESVJ, + $ N+LWRK_ZGELQF, 2*N+LWRK_ZGEQRF, + $ N+LWRK_ZGESVJ, N+LWRK_ZUNMLQ ) + ELSE + OPTWRK = MAX( N+LWRK_ZGEQP3, LWRK_ZGESVJ,N+LWRK_ZGELQF, + $ 2*N+LWRK_ZGEQRF, N+LWRK_ZGESVJ, + $ N+LWRK_ZUNMLQ ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE IF ( LSVEC .AND. (.NOT.RSVEC) ) THEN +* .. minimal and optimal sizes of the complex workspace if the +* singular values and the left singular vectors are requested + IF ( ERREST ) THEN + MINWRK = N + MAX( LWQP3,LWCON,N+LWQRF,LWSVDJ,LWUNMQRM ) + ELSE + MINWRK = N + MAX( LWQP3, N+LWQRF, LWSVDJ, LWUNMQRM ) + END IF + IF ( LQUERY ) THEN + CALL ZGESVJ( 'L', 'U', 'N', N,N, U, LDU, SVA, N, A, + $ LDA, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJ = CDUMMY(1) + CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_ZUNMQRM = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = N + MAX( LWRK_ZGEQP3, LWCON, N+LWRK_ZGEQRF, + $ LWRK_ZGESVJ, LWRK_ZUNMQRM ) + ELSE + OPTWRK = N + MAX( LWRK_ZGEQP3, N+LWRK_ZGEQRF, + $ LWRK_ZGESVJ, LWRK_ZUNMQRM ) + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + IF ( ERREST ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ ) + END IF + ELSE + IF ( ERREST ) THEN + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ ) + END IF + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE +* .. minimal and optimal sizes of the complex workspace if the +* full SVD is requested + IF ( .NOT. JRACC ) THEN + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N+LWCON, 2*N+N**2+LWCON, + $ 2*N+LWQRF, 2*N+LWQP3, + $ 2*N+N**2+N+LWLQF, 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWSVDJ, 2*N+N**2+N+LWSVDJV, + $ 2*N+N**2+N+LWUNMQR,2*N+N**2+N+LWUNMLQ, + $ N+N**2+LWSVDJ, N+LWUNMQRM ) + ELSE + MINWRK = MAX( N+LWQP3, 2*N+N**2+LWCON, + $ 2*N+LWQRF, 2*N+LWQP3, + $ 2*N+N**2+N+LWLQF, 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWSVDJ, 2*N+N**2+N+LWSVDJV, + $ 2*N+N**2+N+LWUNMQR,2*N+N**2+N+LWUNMLQ, + $ N+N**2+LWSVDJ, N+LWUNMQRM ) + END IF + MINIWRK = MINIWRK + N + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + ELSE + IF ( ERREST ) THEN + MINWRK = MAX( N+LWQP3, N+LWCON, 2*N+LWQRF, + $ 2*N+N**2+LWSVDJV, 2*N+N**2+N+LWUNMQR, + $ N+LWUNMQRM ) + ELSE + MINWRK = MAX( N+LWQP3, 2*N+LWQRF, + $ 2*N+N**2+LWSVDJV, 2*N+N**2+N+LWUNMQR, + $ N+LWUNMQRM ) + END IF + IF ( ROWPIV .OR. L2TRAN ) MINIWRK = MINIWRK + M + END IF + IF ( LQUERY ) THEN + CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_ZUNMQRM = CDUMMY(1) + CALL ZUNMQR( 'L', 'N', N, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_ZUNMQR = CDUMMY(1) + IF ( .NOT. JRACC ) THEN + CALL ZGEQP3( N,N, A, LDA, IWORK, CDUMMY,CDUMMY, -1, + $ RDUMMY, IERR ) + LWRK_ZGEQP3N = CDUMMY(1) + CALL ZGESVJ( 'L', 'U', 'N', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJ = CDUMMY(1) + CALL ZGESVJ( 'U', 'U', 'N', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJU = CDUMMY(1) + CALL ZGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJV = CDUMMY(1) + CALL ZUNMLQ( 'L', 'C', N, N, N, A, LDA, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_ZUNMLQ = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_ZGEQP3, N+LWCON, + $ 2*N+N**2+LWCON, 2*N+LWRK_ZGEQRF, + $ 2*N+LWRK_ZGEQP3N, + $ 2*N+N**2+N+LWRK_ZGELQF, + $ 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWRK_ZGESVJ, + $ 2*N+N**2+N+LWRK_ZGESVJV, + $ 2*N+N**2+N+LWRK_ZUNMQR, + $ 2*N+N**2+N+LWRK_ZUNMLQ, + $ N+N**2+LWRK_ZGESVJU, + $ N+LWRK_ZUNMQRM ) + ELSE + OPTWRK = MAX( N+LWRK_ZGEQP3, + $ 2*N+N**2+LWCON, 2*N+LWRK_ZGEQRF, + $ 2*N+LWRK_ZGEQP3N, + $ 2*N+N**2+N+LWRK_ZGELQF, + $ 2*N+N**2+N+N**2+LWCON, + $ 2*N+N**2+N+LWRK_ZGESVJ, + $ 2*N+N**2+N+LWRK_ZGESVJV, + $ 2*N+N**2+N+LWRK_ZUNMQR, + $ 2*N+N**2+N+LWRK_ZUNMLQ, + $ N+N**2+LWRK_ZGESVJU, + $ N+LWRK_ZUNMQRM ) + END IF + ELSE + CALL ZGESVJ( 'L', 'U', 'V', N, N, U, LDU, SVA, + $ N, V, LDV, CDUMMY, -1, RDUMMY, -1, IERR ) + LWRK_ZGESVJV = CDUMMY(1) + CALL ZUNMQR( 'L', 'N', N, N, N, CDUMMY, N, CDUMMY, + $ V, LDV, CDUMMY, -1, IERR ) + LWRK_ZUNMQR = CDUMMY(1) + CALL ZUNMQR( 'L', 'N', M, N, N, A, LDA, CDUMMY, U, + $ LDU, CDUMMY, -1, IERR ) + LWRK_ZUNMQRM = CDUMMY(1) + IF ( ERREST ) THEN + OPTWRK = MAX( N+LWRK_ZGEQP3, N+LWCON, + $ 2*N+LWRK_ZGEQRF, 2*N+N**2, + $ 2*N+N**2+LWRK_ZGESVJV, + $ 2*N+N**2+N+LWRK_ZUNMQR,N+LWRK_ZUNMQRM ) + ELSE + OPTWRK = MAX( N+LWRK_ZGEQP3, 2*N+LWRK_ZGEQRF, + $ 2*N+N**2, 2*N+N**2+LWRK_ZGESVJV, + $ 2*N+N**2+N+LWRK_ZUNMQR, + $ N+LWRK_ZUNMQRM ) + END IF + END IF + END IF + IF ( L2TRAN .OR. ROWPIV ) THEN + MINRWRK = MAX( 7, 2*M, LRWQP3, LRWSVDJ, LRWCON ) + ELSE + MINRWRK = MAX( 7, LRWQP3, LRWSVDJ, LRWCON ) + END IF + END IF + MINWRK = MAX( 2, MINWRK ) + OPTWRK = MAX( 2, OPTWRK ) + IF ( LWORK .LT. MINWRK .AND. (.NOT.LQUERY) ) INFO = - 17 + IF ( LRWORK .LT. MINRWRK .AND. (.NOT.LQUERY) ) INFO = - 19 + END IF +* + IF ( INFO .NE. 0 ) THEN +* #:( + CALL XERBLA( 'ZGEJSV', - INFO ) + RETURN + ELSE IF ( LQUERY ) THEN + CWORK(1) = OPTWRK + CWORK(2) = MINWRK + RWORK(1) = MINRWRK + IWORK(1) = MAX( 4, MINIWRK ) + RETURN + END IF +* +* Quick return for void matrix (Y3K safe) +* #:) + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) THEN + IWORK(1:4) = 0 + RWORK(1:7) = 0 + RETURN + ENDIF +* +* Determine whether the matrix U should be M x N or M x M +* + IF ( LSVEC ) THEN + N1 = N + IF ( LSAME( JOBU, 'F' ) ) N1 = M + END IF +* +* Set numerical parameters +* +*! NOTE: Make sure DLAMCH() does not fail on the target architecture. +* + EPSLN = DLAMCH('Epsilon') + SFMIN = DLAMCH('SafeMinimum') + SMALL = SFMIN / EPSLN + BIG = DLAMCH('O') +* BIG = ONE / SFMIN +* +* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N +* +*(!) If necessary, scale SVA() to protect the largest norm from +* overflow. It is possible that this scaling pushes the smallest +* column norm left from the underflow threshold (extreme case). +* + SCALEM = ONE / SQRT(DBLE(M)*DBLE(N)) + NOSCAL = .TRUE. + GOSCAL = .TRUE. + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ONE + CALL ZLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 9 + CALL XERBLA( 'ZGEJSV', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCAL = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALEM ) + IF ( GOSCAL ) THEN + GOSCAL = .FALSE. + CALL DSCAL( p-1, SCALEM, SVA, 1 ) + END IF + END IF + 1874 CONTINUE +* + IF ( NOSCAL ) SCALEM = ONE +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + AAPP = MAX( AAPP, SVA(p) ) + IF ( SVA(p) .NE. ZERO ) AAQQ = MIN( AAQQ, SVA(p) ) + 4781 CONTINUE +* +* Quick return for zero M x N matrix +* #:) + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL ZLASET( 'G', M, N1, CZERO, CONE, U, LDU ) + IF ( RSVEC ) CALL ZLASET( 'G', N, N, CZERO, CONE, V, LDV ) + RWORK(1) = ONE + RWORK(2) = ONE + IF ( ERREST ) RWORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = ONE + RWORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ZERO + RWORK(7) = ZERO + END IF + IWORK(1) = 0 + IWORK(2) = 0 + IWORK(3) = 0 + IWORK(4) = -1 + RETURN + END IF +* +* Issue warning if denormalized column norms detected. Override the +* high relative accuracy request. Issue licence to kill nonzero columns +* (set them to zero) whose norm is less than sigma_max / BIG (roughly). +* #:( + WARNING = 0 + IF ( AAQQ .LE. SFMIN ) THEN + L2RANK = .TRUE. + L2KILL = .TRUE. + WARNING = 1 + END IF +* +* Quick return for one-column matrix +* #:) + IF ( N .EQ. 1 ) THEN +* + IF ( LSVEC ) THEN + CALL ZLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) + CALL ZLACPY( 'A', M, 1, A, LDA, U, LDU ) +* computing all M left singular vectors of the M x 1 matrix + IF ( N1 .NE. N ) THEN + CALL ZGEQRF( M, N, U,LDU, CWORK, CWORK(N+1),LWORK-N,IERR ) + CALL ZUNGQR( M,N1,1, U,LDU,CWORK,CWORK(N+1),LWORK-N,IERR ) + CALL ZCOPY( M, A(1,1), 1, U(1,1), 1 ) + END IF + END IF + IF ( RSVEC ) THEN + V(1,1) = CONE + END IF + IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + SVA(1) = SVA(1) / SCALEM + SCALEM = ONE + END IF + RWORK(1) = ONE / SCALEM + RWORK(2) = ONE + IF ( SVA(1) .NE. ZERO ) THEN + IWORK(1) = 1 + IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN + IWORK(2) = 1 + ELSE + IWORK(2) = 0 + END IF + ELSE + IWORK(1) = 0 + IWORK(2) = 0 + END IF + IWORK(3) = 0 + IWORK(4) = -1 + IF ( ERREST ) RWORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = ONE + RWORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ZERO + RWORK(7) = ZERO + END IF + RETURN +* + END IF +* + TRANSP = .FALSE. +* + AATMAX = -ONE + AATMIN = BIG + IF ( ROWPIV .OR. L2TRAN ) THEN +* +* Compute the row norms, needed to determine row pivoting sequence +* (in the case of heavily row weighted A, row pivoting is strongly +* advised) and to collect information needed to compare the +* structures of A * A^* and A^* * A (in the case L2TRAN.EQ..TRUE.). +* + IF ( L2TRAN ) THEN + DO 1950 p = 1, M + XSC = ZERO + TEMP1 = ONE + CALL ZLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) +* ZLASSQ gets both the ell_2 and the ell_infinity norm +* in one pass through the vector + RWORK(M+p) = XSC * SCALEM + RWORK(p) = XSC * (SCALEM*SQRT(TEMP1)) + AATMAX = MAX( AATMAX, RWORK(p) ) + IF (RWORK(p) .NE. ZERO) + $ AATMIN = MIN(AATMIN,RWORK(p)) + 1950 CONTINUE + ELSE + DO 1904 p = 1, M + RWORK(M+p) = SCALEM*ABS( A(p,IZAMAX(N,A(p,1),LDA)) ) + AATMAX = MAX( AATMAX, RWORK(M+p) ) + AATMIN = MIN( AATMIN, RWORK(M+p) ) + 1904 CONTINUE + END IF +* + END IF +* +* For square matrix A try to determine whether A^* would be better +* input for the preconditioned Jacobi SVD, with faster convergence. +* The decision is based on an O(N) function of the vector of column +* and row norms of A, based on the Shannon entropy. This should give +* the right choice in most cases when the difference actually matters. +* It may fail and pick the slower converging side. +* + ENTRA = ZERO + ENTRAT = ZERO + IF ( L2TRAN ) THEN +* + XSC = ZERO + TEMP1 = ONE + CALL DLASSQ( N, SVA, 1, XSC, TEMP1 ) + TEMP1 = ONE / TEMP1 +* + ENTRA = ZERO + DO 1113 p = 1, N + BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1) + 1113 CONTINUE + ENTRA = - ENTRA / DLOG(DBLE(N)) +* +* Now, SVA().^2/Trace(A^* * A) is a point in the probability simplex. +* It is derived from the diagonal of A^* * A. Do the same with the +* diagonal of A * A^*, compute the entropy of the corresponding +* probability distribution. Note that A * A^* and A^* * A have the +* same trace. +* + ENTRAT = ZERO + DO 1114 p = 1, M + BIG1 = ( ( RWORK(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1) + 1114 CONTINUE + ENTRAT = - ENTRAT / DLOG(DBLE(M)) +* +* Analyze the entropies and decide A or A^*. Smaller entropy +* usually means better input for the algorithm. +* + TRANSP = ( ENTRAT .LT. ENTRA ) +* +* If A^* is better than A, take the adjoint of A. This is allowed +* only for square matrices, M=N. + IF ( TRANSP ) THEN +* In an optimal implementation, this trivial transpose +* should be replaced with faster transpose. + DO 1115 p = 1, N - 1 + A(p,p) = CONJG(A(p,p)) + DO 1116 q = p + 1, N + CTEMP = CONJG(A(q,p)) + A(q,p) = CONJG(A(p,q)) + A(p,q) = CTEMP + 1116 CONTINUE + 1115 CONTINUE + A(N,N) = CONJG(A(N,N)) + DO 1117 p = 1, N + RWORK(M+p) = SVA(p) + SVA(p) = RWORK(p) +* previously computed row 2-norms are now column 2-norms +* of the transposed matrix + 1117 CONTINUE + TEMP1 = AAPP + AAPP = AATMAX + AATMAX = TEMP1 + TEMP1 = AAQQ + AAQQ = AATMIN + AATMIN = TEMP1 + KILL = LSVEC + LSVEC = RSVEC + RSVEC = KILL + IF ( LSVEC ) N1 = N +* + ROWPIV = .TRUE. + END IF +* + END IF +* END IF L2TRAN +* +* Scale the matrix so that its maximal singular value remains less +* than SQRT(BIG) -- the matrix is scaled so that its maximal column +* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep +* SQRT(BIG) instead of BIG is the fact that ZGEJSV uses LAPACK and +* BLAS routines that, in some implementations, are not capable of +* working in the full interval [SFMIN,BIG] and that they may provoke +* overflows in the intermediate results. If the singular values spread +* from SFMIN to BIG, then ZGESVJ will compute them. So, in that case, +* one should use ZGESVJ instead of ZGEJSV. +* >> change in the April 2016 update: allow bigger range, i.e. the +* largest column is allowed up to BIG/N and ZGESVJ will do the rest. + BIG1 = SQRT( BIG ) + TEMP1 = SQRT( BIG / DBLE(N) ) +* TEMP1 = BIG/DBLE(N) +* + CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) + IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN + AAQQ = ( AAQQ / AAPP ) * TEMP1 + ELSE + AAQQ = ( AAQQ * TEMP1 ) / AAPP + END IF + TEMP1 = TEMP1 * SCALEM + CALL ZLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) +* +* To undo scaling at the end of this procedure, multiply the +* computed singular values with USCAL2 / USCAL1. +* + USCAL1 = TEMP1 + USCAL2 = AAPP +* + IF ( L2KILL ) THEN +* L2KILL enforces computation of nonzero singular values in +* the restricted range of condition number of the initial A, +* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). + XSC = SQRT( SFMIN ) + ELSE + XSC = SMALL +* +* Now, if the condition number of A is too big, +* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, +* as a precaution measure, the full SVD is computed using ZGESVJ +* with accumulated Jacobi rotations. This provides numerically +* more robust computation, at the cost of slightly increased run +* time. Depending on the concrete implementation of BLAS and LAPACK +* (i.e. how they behave in presence of extreme ill-conditioning) the +* implementor may decide to remove this switch. + IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN + JRACC = .TRUE. + END IF +* + END IF + IF ( AAQQ .LT. XSC ) THEN + DO 700 p = 1, N + IF ( SVA(p) .LT. XSC ) THEN + CALL ZLASET( 'A', M, 1, CZERO, CZERO, A(1,p), LDA ) + SVA(p) = ZERO + END IF + 700 CONTINUE + END IF +* +* Preconditioning using QR factorization with pivoting +* + IF ( ROWPIV ) THEN +* Optional row permutation (Bjoerck row pivoting): +* A result by Cox and Higham shows that the Bjoerck's +* row pivoting combined with standard column pivoting +* has similar effect as Powell-Reid complete pivoting. +* The ell-infinity norms of A are made nonincreasing. + IF ( ( LSVEC .AND. RSVEC ) .AND. .NOT.( JRACC ) ) THEN + IWOFF = 2*N + ELSE + IWOFF = N + END IF + DO 1952 p = 1, M - 1 + q = IDAMAX( M-p+1, RWORK(M+p), 1 ) + p - 1 + IWORK(IWOFF+p) = q + IF ( p .NE. q ) THEN + TEMP1 = RWORK(M+p) + RWORK(M+p) = RWORK(M+q) + RWORK(M+q) = TEMP1 + END IF + 1952 CONTINUE + CALL ZLASWP( N, A, LDA, 1, M-1, IWORK(IWOFF+1), 1 ) + END IF +* +* End of the preparation phase (scaling, optional sorting and +* transposing, optional flushing of small columns). +* +* Preconditioning +* +* If the full SVD is needed, the right singular vectors are computed +* from a matrix equation, and for that we need theoretical analysis +* of the Businger-Golub pivoting. So we use ZGEQP3 as the first RR QRF. +* In all other cases the first RR QRF can be chosen by other criteria +* (eg speed by replacing global with restricted window pivoting, such +* as in xGEQPX from TOMS # 782). Good results will be obtained using +* xGEQPX with properly (!) chosen numerical parameters. +* Any improvement of ZGEQP3 improves overal performance of ZGEJSV. +* +* A * P1 = Q1 * [ R1^* 0]^*: + DO 1963 p = 1, N +* .. all columns are free columns + IWORK(p) = 0 + 1963 CONTINUE + CALL ZGEQP3( M, N, A, LDA, IWORK, CWORK, CWORK(N+1), LWORK-N, + $ RWORK, IERR ) +* +* The upper triangular matrix R1 from the first QRF is inspected for +* rank deficiency and possibilities for deflation, or possible +* ill-conditioning. Depending on the user specified flag L2RANK, +* the procedure explores possibilities to reduce the numerical +* rank by inspecting the computed upper triangular factor. If +* L2RANK or L2ABER are up, then ZGEJSV will compute the SVD of +* A + dA, where ||dA|| <= f(M,N)*EPSLN. +* + NR = 1 + IF ( L2ABER ) THEN +* Standard absolute error bound suffices. All sigma_i with +* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an +* agressive enforcement of lower numerical rank by introducing a +* backward error of the order of N*EPSLN*||A||. + TEMP1 = SQRT(DBLE(N))*EPSLN + DO 3001 p = 2, N + IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN + NR = NR + 1 + ELSE + GO TO 3002 + END IF + 3001 CONTINUE + 3002 CONTINUE + ELSE IF ( L2RANK ) THEN +* .. similarly as above, only slightly more gentle (less agressive). +* Sudden drop on the diagonal of R1 is used as the criterion for +* close-to-rank-deficient. + TEMP1 = SQRT(SFMIN) + DO 3401 p = 2, N + IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. + $ ( ABS(A(p,p)) .LT. SMALL ) .OR. + $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 + NR = NR + 1 + 3401 CONTINUE + 3402 CONTINUE +* + ELSE +* The goal is high relative accuracy. However, if the matrix +* has high scaled condition number the relative accuracy is in +* general not feasible. Later on, a condition number estimator +* will be deployed to estimate the scaled condition number. +* Here we just remove the underflowed part of the triangular +* factor. This prevents the situation in which the code is +* working hard to get the accuracy not warranted by the data. + TEMP1 = SQRT(SFMIN) + DO 3301 p = 2, N + IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR. + $ ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 + NR = NR + 1 + 3301 CONTINUE + 3302 CONTINUE +* + END IF +* + ALMORT = .FALSE. + IF ( NR .EQ. N ) THEN + MAXPRJ = ONE + DO 3051 p = 2, N + TEMP1 = ABS(A(p,p)) / SVA(IWORK(p)) + MAXPRJ = MIN( MAXPRJ, TEMP1 ) + 3051 CONTINUE + IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE. + END IF +* +* + SCONDA = - ONE + CONDR1 = - ONE + CONDR2 = - ONE +* + IF ( ERREST ) THEN + IF ( N .EQ. NR ) THEN + IF ( RSVEC ) THEN +* .. V is available as workspace + CALL ZLACPY( 'U', N, N, A, LDA, V, LDV ) + DO 3053 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL ZDSCAL( p, ONE/TEMP1, V(1,p), 1 ) + 3053 CONTINUE + IF ( LSVEC )THEN + CALL ZPOCON( 'U', N, V, LDV, ONE, TEMP1, + $ CWORK(N+1), RWORK, IERR ) + ELSE + CALL ZPOCON( 'U', N, V, LDV, ONE, TEMP1, + $ CWORK, RWORK, IERR ) + END IF +* + ELSE IF ( LSVEC ) THEN +* .. U is available as workspace + CALL ZLACPY( 'U', N, N, A, LDA, U, LDU ) + DO 3054 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL ZDSCAL( p, ONE/TEMP1, U(1,p), 1 ) + 3054 CONTINUE + CALL ZPOCON( 'U', N, U, LDU, ONE, TEMP1, + $ CWORK(N+1), RWORK, IERR ) + ELSE + CALL ZLACPY( 'U', N, N, A, LDA, CWORK, N ) +*[] CALL ZLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) +* Change: here index shifted by N to the left, CWORK(1:N) +* not needed for SIGMA only computation + DO 3052 p = 1, N + TEMP1 = SVA(IWORK(p)) +*[] CALL ZDSCAL( p, ONE/TEMP1, CWORK(N+(p-1)*N+1), 1 ) + CALL ZDSCAL( p, ONE/TEMP1, CWORK((p-1)*N+1), 1 ) + 3052 CONTINUE +* .. the columns of R are scaled to have unit Euclidean lengths. +*[] CALL ZPOCON( 'U', N, CWORK(N+1), N, ONE, TEMP1, +*[] $ CWORK(N+N*N+1), RWORK, IERR ) + CALL ZPOCON( 'U', N, CWORK, N, ONE, TEMP1, + $ CWORK(N*N+1), RWORK, IERR ) +* + END IF + IF ( TEMP1 .NE. ZERO ) THEN + SCONDA = ONE / SQRT(TEMP1) + ELSE + SCONDA = - ONE + END IF +* SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA + ELSE + SCONDA = - ONE + END IF + END IF +* + L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) ) +* If there is no violent scaling, artificial perturbation is not needed. +* +* Phase 3: +* + IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN +* +* Singular Values only +* +* .. transpose A(1:NR,1:N) + DO 1946 p = 1, MIN( N-1, NR ) + CALL ZCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) + CALL ZLACGV( N-p+1, A(p,p), 1 ) + 1946 CONTINUE + IF ( NR .EQ. N ) A(N,N) = CONJG(A(N,N)) +* +* The following two DO-loops introduce small relative perturbation +* into the strict upper triangle of the lower triangular matrix. +* Small entries below the main diagonal are also changed. +* This modification is useful if the computing environment does not +* provide/allow FLUSH TO ZERO underflow, for it prevents many +* annoying denormalized numbers in case of strongly scaled matrices. +* The perturbation is structured so that it does not introduce any +* new perturbation of the singular values, and it does not destroy +* the job done by the preconditioner. +* The licence for this perturbation is in the variable L2PERT, which +* should be .FALSE. if FLUSH TO ZERO underflow is active. +* + IF ( .NOT. ALMORT ) THEN +* + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / DBLE(N) + DO 4947 q = 1, NR + CTEMP = DCMPLX(XSC*ABS(A(q,q)),ZERO) + DO 4949 p = 1, N + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + $ .OR. ( p .LT. q ) ) +* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) + $ A(p,q) = CTEMP + 4949 CONTINUE + 4947 CONTINUE + ELSE + CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, A(1,2),LDA ) + END IF +* +* .. second preconditioning using the QR factorization +* + CALL ZGEQRF( N,NR, A,LDA, CWORK, CWORK(N+1),LWORK-N, IERR ) +* +* .. and transpose upper to lower triangular + DO 1948 p = 1, NR - 1 + CALL ZCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) + CALL ZLACGV( NR-p+1, A(p,p), 1 ) + 1948 CONTINUE +* + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* +* .. again some perturbation (a "background noise") is added +* to drown denormals + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / DBLE(N) + DO 1947 q = 1, NR + CTEMP = DCMPLX(XSC*ABS(A(q,q)),ZERO) + DO 1949 p = 1, NR + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + $ .OR. ( p .LT. q ) ) +* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) + $ A(p,q) = CTEMP + 1949 CONTINUE + 1947 CONTINUE + ELSE + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, A(1,2), LDA ) + END IF +* +* .. and one-sided Jacobi rotations are started on a lower +* triangular matrix (plus perturbation which is ignored in +* the part which destroys triangular form (confusing?!)) +* + CALL ZGESVJ( 'L', 'N', 'N', NR, NR, A, LDA, SVA, + $ N, V, LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) +* + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) +* +* + ELSE IF ( ( RSVEC .AND. ( .NOT. LSVEC ) .AND. ( .NOT. JRACC ) ) + $ .OR. + $ ( JRACC .AND. ( .NOT. LSVEC ) .AND. ( NR .NE. N ) ) ) THEN +* +* -> Singular Values and Right Singular Vectors <- +* + IF ( ALMORT ) THEN +* +* .. in this case NR equals N + DO 1998 p = 1, NR + CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL ZLACGV( N-p+1, V(p,p), 1 ) + 1998 CONTINUE + CALL ZLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) +* + CALL ZGESVJ( 'L','U','N', N, NR, V, LDV, SVA, NR, A, LDA, + $ CWORK, LWORK, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + + ELSE +* +* .. two more QR factorizations ( one QRF is not enough, two require +* accumulated product of Jacobi rotations, three are perfect ) +* + CALL ZLASET( 'L', NR-1,NR-1, CZERO, CZERO, A(2,1), LDA ) + CALL ZGELQF( NR,N, A, LDA, CWORK, CWORK(N+1), LWORK-N, IERR) + CALL ZLACPY( 'L', NR, NR, A, LDA, V, LDV ) + CALL ZLASET( 'U', NR-1,NR-1, CZERO, CZERO, V(1,2), LDV ) + CALL ZGEQRF( NR, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) + DO 8998 p = 1, NR + CALL ZCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) + CALL ZLACGV( NR-p+1, V(p,p), 1 ) + 8998 CONTINUE + CALL ZLASET('U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV) +* + CALL ZGESVJ( 'L', 'U','N', NR, NR, V,LDV, SVA, NR, U, + $ LDU, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + IF ( NR .LT. N ) THEN + CALL ZLASET( 'A',N-NR, NR, CZERO,CZERO, V(NR+1,1), LDV ) + CALL ZLASET( 'A',NR, N-NR, CZERO,CZERO, V(1,NR+1), LDV ) + CALL ZLASET( 'A',N-NR,N-NR,CZERO,CONE, V(NR+1,NR+1),LDV ) + END IF +* + CALL ZUNMLQ( 'L', 'C', N, N, NR, A, LDA, CWORK, + $ V, LDV, CWORK(N+1), LWORK-N, IERR ) +* + END IF +* .. permute the rows of V +* DO 8991 p = 1, N +* CALL ZCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) +* 8991 CONTINUE +* CALL ZLACPY( 'All', N, N, A, LDA, V, LDV ) + CALL ZLAPMR( .FALSE., N, N, V, LDV, IWORK ) +* + IF ( TRANSP ) THEN + CALL ZLACPY( 'A', N, N, V, LDV, U, LDU ) + END IF +* + ELSE IF ( JRACC .AND. (.NOT. LSVEC) .AND. ( NR.EQ. N ) ) THEN +* + CALL ZLASET( 'L', N-1,N-1, CZERO, CZERO, A(2,1), LDA ) +* + CALL ZGESVJ( 'U','N','V', N, N, A, LDA, SVA, N, V, LDV, + $ CWORK, LWORK, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + CALL ZLAPMR( .FALSE., N, N, V, LDV, IWORK ) +* + ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN +* +* .. Singular Values and Left Singular Vectors .. +* +* .. second preconditioning step to avoid need to accumulate +* Jacobi rotations in the Jacobi iterations. + DO 1965 p = 1, NR + CALL ZCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) + CALL ZLACGV( N-p+1, U(p,p), 1 ) + 1965 CONTINUE + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) +* + CALL ZGEQRF( N, NR, U, LDU, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) +* + DO 1967 p = 1, NR - 1 + CALL ZCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) + CALL ZLACGV( N-p+1, U(p,p), 1 ) + 1967 CONTINUE + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) +* + CALL ZGESVJ( 'L', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, + $ LDA, CWORK(N+1), LWORK-N, RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) +* + IF ( NR .LT. M ) THEN + CALL ZLASET( 'A', M-NR, NR,CZERO, CZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL ZLASET( 'A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU ) + CALL ZLASET( 'A',M-NR,N1-NR,CZERO,CONE,U(NR+1,NR+1),LDU ) + END IF + END IF +* + CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + DO 1974 p = 1, N1 + XSC = ONE / DZNRM2( M, U(1,p), 1 ) + CALL ZDSCAL( M, XSC, U(1,p), 1 ) + 1974 CONTINUE +* + IF ( TRANSP ) THEN + CALL ZLACPY( 'A', N, N, U, LDU, V, LDV ) + END IF +* + ELSE +* +* .. Full SVD .. +* + IF ( .NOT. JRACC ) THEN +* + IF ( .NOT. ALMORT ) THEN +* +* Second Preconditioning Step (QRF [with pivoting]) +* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is +* equivalent to an LQF CALL. Since in many libraries the QRF +* seems to be better optimized than the LQF, we do explicit +* transpose and use the QRF. This is subject to changes in an +* optimized implementation of ZGEJSV. +* + DO 1968 p = 1, NR + CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL ZLACGV( N-p+1, V(p,p), 1 ) + 1968 CONTINUE +* +* .. the following two loops perturb small entries to avoid +* denormals in the second QR factorization, where they are +* as good as zeros. This is done to avoid painfully slow +* computation with denormals. The relative size of the perturbation +* is a parameter that can be changed by the implementer. +* This perturbation device will be obsolete on machines with +* properly implemented arithmetic. +* To switch it off, set L2PERT=.FALSE. To remove it from the +* code, remove the action under L2PERT=.TRUE., leave the ELSE part. +* The following two loops should be blocked and fused with the +* transposed copy above. +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 2969 q = 1, NR + CTEMP = DCMPLX(XSC*ABS( V(q,q) ),ZERO) + DO 2968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + $ .OR. ( p .LT. q ) ) +* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) + $ V(p,q) = CTEMP + IF ( p .LT. q ) V(p,q) = - V(p,q) + 2968 CONTINUE + 2969 CONTINUE + ELSE + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + END IF +* +* Estimate the row scaled condition number of R1 +* (If R1 is rectangular, N > NR, then the condition number +* of the leading NR x NR submatrix is estimated.) +* + CALL ZLACPY( 'L', NR, NR, V, LDV, CWORK(2*N+1), NR ) + DO 3950 p = 1, NR + TEMP1 = DZNRM2(NR-p+1,CWORK(2*N+(p-1)*NR+p),1) + CALL ZDSCAL(NR-p+1,ONE/TEMP1,CWORK(2*N+(p-1)*NR+p),1) + 3950 CONTINUE + CALL ZPOCON('L',NR,CWORK(2*N+1),NR,ONE,TEMP1, + $ CWORK(2*N+NR*NR+1),RWORK,IERR) + CONDR1 = ONE / SQRT(TEMP1) +* .. here need a second oppinion on the condition number +* .. then assume worst case scenario +* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N) +* more conservative <=> CONDR1 .LT. SQRT(DBLE(N)) +* + COND_OK = SQRT(SQRT(DBLE(NR))) +*[TP] COND_OK is a tuning parameter. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* .. the second QRF without pivoting. Note: in an optimized +* implementation, this QRF should be implemented as the QRF +* of a lower triangular matrix. +* R1^* = Q2 * R2 + CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL)/EPSLN + DO 3959 p = 2, NR + DO 3958 q = 1, p - 1 + CTEMP=DCMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) + IF ( ABS(V(q,p)) .LE. TEMP1 ) +* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) + $ V(q,p) = CTEMP + 3958 CONTINUE + 3959 CONTINUE + END IF +* + IF ( NR .NE. N ) + $ CALL ZLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) +* .. save ... +* +* .. this transposed copy should be better than naive + DO 1969 p = 1, NR - 1 + CALL ZCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) + CALL ZLACGV(NR-p+1, V(p,p), 1 ) + 1969 CONTINUE + V(NR,NR)=CONJG(V(NR,NR)) +* + CONDR2 = CONDR1 +* + ELSE +* +* .. ill-conditioned case: second QRF with pivoting +* Note that windowed pivoting would be equaly good +* numerically, and more run-time efficient. So, in +* an optimal implementation, the next call to ZGEQP3 +* should be replaced with eg. CALL ZGEQPX (ACM TOMS #782) +* with properly (carefully) chosen parameters. +* +* R1^* * P2 = Q2 * R2 + DO 3003 p = 1, NR + IWORK(N+p) = 0 + 3003 CONTINUE + CALL ZGEQP3( N, NR, V, LDV, IWORK(N+1), CWORK(N+1), + $ CWORK(2*N+1), LWORK-2*N, RWORK, IERR ) +** CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), +** $ LWORK-2*N, IERR ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 3969 p = 2, NR + DO 3968 q = 1, p - 1 + CTEMP=DCMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) + IF ( ABS(V(q,p)) .LE. TEMP1 ) +* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) + $ V(q,p) = CTEMP + 3968 CONTINUE + 3969 CONTINUE + END IF +* + CALL ZLACPY( 'A', N, NR, V, LDV, CWORK(2*N+1), N ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 8970 p = 2, NR + DO 8971 q = 1, p - 1 + CTEMP=DCMPLX(XSC*MIN(ABS(V(p,p)),ABS(V(q,q))), + $ ZERO) +* V(p,q) = - TEMP1*( V(q,p) / ABS(V(q,p)) ) + V(p,q) = - CTEMP + 8971 CONTINUE + 8970 CONTINUE + ELSE + CALL ZLASET( 'L',NR-1,NR-1,CZERO,CZERO,V(2,1),LDV ) + END IF +* Now, compute R2 = L3 * Q3, the LQ factorization. + CALL ZGELQF( NR, NR, V, LDV, CWORK(2*N+N*NR+1), + $ CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) +* .. and estimate the condition number + CALL ZLACPY( 'L',NR,NR,V,LDV,CWORK(2*N+N*NR+NR+1),NR ) + DO 4950 p = 1, NR + TEMP1 = DZNRM2( p, CWORK(2*N+N*NR+NR+p), NR ) + CALL ZDSCAL( p, ONE/TEMP1, CWORK(2*N+N*NR+NR+p), NR ) + 4950 CONTINUE + CALL ZPOCON( 'L',NR,CWORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, + $ CWORK(2*N+N*NR+NR+NR*NR+1),RWORK,IERR ) + CONDR2 = ONE / SQRT(TEMP1) +* +* + IF ( CONDR2 .GE. COND_OK ) THEN +* .. save the Householder vectors used for Q3 +* (this overwrittes the copy of R2, as it will not be +* needed in this branch, but it does not overwritte the +* Huseholder vectors of Q2.). + CALL ZLACPY( 'U', NR, NR, V, LDV, CWORK(2*N+1), N ) +* .. and the rest of the information on Q3 is in +* WORK(2*N+N*NR+1:2*N+N*NR+N) + END IF +* + END IF +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 4968 q = 2, NR + CTEMP = XSC * V(q,q) + DO 4969 p = 1, q - 1 +* V(p,q) = - TEMP1*( V(p,q) / ABS(V(p,q)) ) + V(p,q) = - CTEMP + 4969 CONTINUE + 4968 CONTINUE + ELSE + CALL ZLASET( 'U', NR-1,NR-1, CZERO,CZERO, V(1,2), LDV ) + END IF +* +* Second preconditioning finished; continue with Jacobi SVD +* The input matrix is lower trinagular. +* +* Recover the right singular vectors as solution of a well +* conditioned triangular matrix equation. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* + CALL ZGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, LDU, + $ CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,RWORK, + $ LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 3970 p = 1, NR + CALL ZCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL ZDSCAL( NR, SVA(p), V(1,p), 1 ) + 3970 CONTINUE + +* .. pick the right matrix equation and solve it +* + IF ( NR .EQ. N ) THEN +* :)) .. best case, R1 is inverted. The solution of this matrix +* equation is Q2*V2 = the product of the Jacobi rotations +* used in ZGESVJ, premultiplied with the orthogonal matrix +* from the second QR factorization. + CALL ZTRSM('L','U','N','N', NR,NR,CONE, A,LDA, V,LDV) + ELSE +* .. R1 is well conditioned, but non-square. Adjoint of R2 +* is inverted to get the product of the Jacobi rotations +* used in ZGESVJ. The Q-factor from the second QR +* factorization is then built in explicitly. + CALL ZTRSM('L','U','C','N',NR,NR,CONE,CWORK(2*N+1), + $ N,V,LDV) + IF ( NR .LT. N ) THEN + CALL ZLASET('A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV) + CALL ZLASET('A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL ZUNMQR('L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) + END IF +* + ELSE IF ( CONDR2 .LT. COND_OK ) THEN +* +* The matrix R2 is inverted. The solution of the matrix equation +* is Q3^* * V3 = the product of the Jacobi rotations (appplied to +* the lower triangular L3 from the LQ factorization of +* R2=L3*Q3), pre-multiplied with the transposed Q3. + CALL ZGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 3870 p = 1, NR + CALL ZCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL ZDSCAL( NR, SVA(p), U(1,p), 1 ) + 3870 CONTINUE + CALL ZTRSM('L','U','N','N',NR,NR,CONE,CWORK(2*N+1),N, + $ U,LDU) +* .. apply the permutation from the second QR factorization + DO 873 q = 1, NR + DO 872 p = 1, NR + CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 872 CONTINUE + DO 874 p = 1, NR + U(p,q) = CWORK(2*N+N*NR+NR+p) + 874 CONTINUE + 873 CONTINUE + IF ( NR .LT. N ) THEN + CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) + ELSE +* Last line of defense. +* #:( This is a rather pathological case: no scaled condition +* improvement after two pivoted QR factorizations. Other +* possibility is that the rank revealing QR factorization +* or the condition estimator has failed, or the COND_OK +* is set very close to ONE (which is unnecessary). Normally, +* this branch should never be executed, but in rare cases of +* failure of the RRQR or condition estimator, the last line of +* defense ensures that ZGEJSV completes the task. +* Compute the full SVD of L3 using ZGESVJ with explicit +* accumulation of Jacobi rotations. + CALL ZGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + $ LDU, CWORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + IF ( NR .LT. N ) THEN + CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL ZLASET('A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV) + END IF + CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* + CALL ZUNMLQ( 'L', 'C', NR, NR, NR, CWORK(2*N+1), N, + $ CWORK(2*N+N*NR+1), U, LDU, CWORK(2*N+N*NR+NR+1), + $ LWORK-2*N-N*NR-NR, IERR ) + DO 773 q = 1, NR + DO 772 p = 1, NR + CWORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 772 CONTINUE + DO 774 p = 1, NR + U(p,q) = CWORK(2*N+N*NR+NR+p) + 774 CONTINUE + 773 CONTINUE +* + END IF +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(DBLE(N)) * EPSLN + DO 1972 q = 1, N + DO 972 p = 1, N + CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 972 CONTINUE + DO 973 p = 1, N + V(p,q) = CWORK(2*N+N*NR+NR+p) + 973 CONTINUE + XSC = ONE / DZNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL ZDSCAL( N, XSC, V(1,q), 1 ) + 1972 CONTINUE +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). + IF ( NR .LT. M ) THEN + CALL ZLASET('A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU) + IF ( NR .LT. N1 ) THEN + CALL ZLASET('A',NR,N1-NR,CZERO,CZERO,U(1,NR+1),LDU) + CALL ZLASET('A',M-NR,N1-NR,CZERO,CONE, + $ U(NR+1,NR+1),LDU) + END IF + END IF +* +* The Q matrix from the first QRF is built into the left singular +* matrix U. This applies to all cases. +* + CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) + +* The columns of U are normalized. The cost is O(M*N) flops. + TEMP1 = SQRT(DBLE(M)) * EPSLN + DO 1973 p = 1, NR + XSC = ONE / DZNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL ZDSCAL( M, XSC, U(1,p), 1 ) + 1973 CONTINUE +* +* If the initial QRF is computed with row pivoting, the left +* singular vectors must be adjusted. +* + IF ( ROWPIV ) + $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + ELSE +* +* .. the initial matrix A has almost orthogonal columns and +* the second QRF is not needed +* + CALL ZLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 5970 p = 2, N + CTEMP = XSC * CWORK( N + (p-1)*N + p ) + DO 5971 q = 1, p - 1 +* CWORK(N+(q-1)*N+p)=-TEMP1 * ( CWORK(N+(p-1)*N+q) / +* $ ABS(CWORK(N+(p-1)*N+q)) ) + CWORK(N+(q-1)*N+p)=-CTEMP + 5971 CONTINUE + 5970 CONTINUE + ELSE + CALL ZLASET( 'L',N-1,N-1,CZERO,CZERO,CWORK(N+2),N ) + END IF +* + CALL ZGESVJ( 'U', 'U', 'N', N, N, CWORK(N+1), N, SVA, + $ N, U, LDU, CWORK(N+N*N+1), LWORK-N-N*N, RWORK, LRWORK, + $ INFO ) +* + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + DO 6970 p = 1, N + CALL ZCOPY( N, CWORK(N+(p-1)*N+1), 1, U(1,p), 1 ) + CALL ZDSCAL( N, SVA(p), CWORK(N+(p-1)*N+1), 1 ) + 6970 CONTINUE +* + CALL ZTRSM( 'L', 'U', 'N', 'N', N, N, + $ CONE, A, LDA, CWORK(N+1), N ) + DO 6972 p = 1, N + CALL ZCOPY( N, CWORK(N+p), N, V(IWORK(p),1), LDV ) + 6972 CONTINUE + TEMP1 = SQRT(DBLE(N))*EPSLN + DO 6971 p = 1, N + XSC = ONE / DZNRM2( N, V(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL ZDSCAL( N, XSC, V(1,p), 1 ) + 6971 CONTINUE +* +* Assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U(N+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL ZLASET('A',N, N1-N, CZERO, CZERO, U(1,N+1),LDU) + CALL ZLASET( 'A',M-N,N1-N, CZERO, CONE,U(N+1,N+1),LDU) + END IF + END IF + CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) + TEMP1 = SQRT(DBLE(M))*EPSLN + DO 6973 p = 1, N1 + XSC = ONE / DZNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL ZDSCAL( M, XSC, U(1,p), 1 ) + 6973 CONTINUE +* + IF ( ROWPIV ) + $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* + END IF +* +* end of the >> almost orthogonal case << in the full SVD +* + ELSE +* +* This branch deploys a preconditioned Jacobi SVD with explicitly +* accumulated rotations. It is included as optional, mainly for +* experimental purposes. It does perfom well, and can also be used. +* In this implementation, this branch will be automatically activated +* if the condition number sigma_max(A) / sigma_min(A) is predicted +* to be greater than the overflow threshold. This is because the +* a posteriori computation of the singular vectors assumes robust +* implementation of BLAS and some LAPACK procedures, capable of working +* in presence of extreme values, e.g. when the singular values spread from +* the underflow to the overflow threshold. +* + DO 7968 p = 1, NR + CALL ZCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + CALL ZLACGV( N-p+1, V(p,p), 1 ) + 7968 CONTINUE +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 5969 q = 1, NR + CTEMP = DCMPLX(XSC*ABS( V(q,q) ),ZERO) + DO 5968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + $ .OR. ( p .LT. q ) ) +* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) + $ V(p,q) = CTEMP + IF ( p .LT. q ) V(p,q) = - V(p,q) + 5968 CONTINUE + 5969 CONTINUE + ELSE + CALL ZLASET( 'U', NR-1, NR-1, CZERO, CZERO, V(1,2), LDV ) + END IF + + CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), + $ LWORK-2*N, IERR ) + CALL ZLACPY( 'L', N, NR, V, LDV, CWORK(2*N+1), N ) +* + DO 7969 p = 1, NR + CALL ZCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) + CALL ZLACGV( NR-p+1, U(p,p), 1 ) + 7969 CONTINUE + + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 9970 q = 2, NR + DO 9971 p = 1, q - 1 + CTEMP = DCMPLX(XSC * MIN(ABS(U(p,p)),ABS(U(q,q))), + $ ZERO) +* U(p,q) = - TEMP1 * ( U(q,p) / ABS(U(q,p)) ) + U(p,q) = - CTEMP + 9971 CONTINUE + 9970 CONTINUE + ELSE + CALL ZLASET('U', NR-1, NR-1, CZERO, CZERO, U(1,2), LDU ) + END IF + + CALL ZGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA, + $ N, V, LDV, CWORK(2*N+N*NR+1), LWORK-2*N-N*NR, + $ RWORK, LRWORK, INFO ) + SCALEM = RWORK(1) + NUMRANK = NINT(RWORK(2)) + + IF ( NR .LT. N ) THEN + CALL ZLASET( 'A',N-NR,NR,CZERO,CZERO,V(NR+1,1),LDV ) + CALL ZLASET( 'A',NR,N-NR,CZERO,CZERO,V(1,NR+1),LDV ) + CALL ZLASET( 'A',N-NR,N-NR,CZERO,CONE,V(NR+1,NR+1),LDV ) + END IF + + CALL ZUNMQR( 'L','N',N,N,NR,CWORK(2*N+1),N,CWORK(N+1), + $ V,LDV,CWORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(DBLE(N)) * EPSLN + DO 7972 q = 1, N + DO 8972 p = 1, N + CWORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 8972 CONTINUE + DO 8973 p = 1, N + V(p,q) = CWORK(2*N+N*NR+NR+p) + 8973 CONTINUE + XSC = ONE / DZNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + $ CALL ZDSCAL( N, XSC, V(1,q), 1 ) + 7972 CONTINUE +* +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). +* + IF ( NR .LT. M ) THEN + CALL ZLASET( 'A', M-NR, NR, CZERO, CZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL ZLASET('A',NR, N1-NR, CZERO, CZERO, U(1,NR+1),LDU) + CALL ZLASET('A',M-NR,N1-NR, CZERO, CONE,U(NR+1,NR+1),LDU) + END IF + END IF +* + CALL ZUNMQR( 'L', 'N', M, N1, N, A, LDA, CWORK, U, + $ LDU, CWORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + $ CALL ZLASWP( N1, U, LDU, 1, M-1, IWORK(IWOFF+1), -1 ) +* +* + END IF + IF ( TRANSP ) THEN +* .. swap U and V because the procedure worked on A^* + DO 6974 p = 1, N + CALL ZSWAP( N, U(1,p), 1, V(1,p), 1 ) + 6974 CONTINUE + END IF +* + END IF +* end of the full SVD +* +* Undo scaling, if necessary (and possible) +* + IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN + CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + USCAL1 = ONE + USCAL2 = ONE + END IF +* + IF ( NR .LT. N ) THEN + DO 3004 p = NR+1, N + SVA(p) = ZERO + 3004 CONTINUE + END IF +* + RWORK(1) = USCAL2 * SCALEM + RWORK(2) = USCAL1 + IF ( ERREST ) RWORK(3) = SCONDA + IF ( LSVEC .AND. RSVEC ) THEN + RWORK(4) = CONDR1 + RWORK(5) = CONDR2 + END IF + IF ( L2TRAN ) THEN + RWORK(6) = ENTRA + RWORK(7) = ENTRAT + END IF +* + IWORK(1) = NR + IWORK(2) = NUMRANK + IWORK(3) = WARNING + IF ( TRANSP ) THEN + IWORK(4) = 1 + ELSE + IWORK(4) = -1 + END IF + +* + RETURN +* .. +* .. END OF ZGEJSV +* .. + END +* diff --git a/lapack-netlib/SRC/zgelq.f b/lapack-netlib/SRC/zgelq.f new file mode 100644 index 0000000000..656396536f --- /dev/null +++ b/lapack-netlib/SRC/zgelq.f @@ -0,0 +1,306 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZGELQ computes a LQ factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-min(M,N) lower trapezoidal matrix L +*> (L is lower triangular if M <= N); +*> the elements above the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any LQ factorization algorithm they wish. The triangular +*> (trapezoidal) L has to be stored in the lower part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> ZLASWLQ or ZGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, ZGELQ will use either +*> ZLASWLQ (if the matrix is short-and-wide) or ZGELQT to compute +*> the LQ factorization. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGELQT, ZLASWLQ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'ZGELQ ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'ZGELQ ', ' ', M, N, 2, -1 ) + ELSE + MB = 1 + NB = N + END IF + IF( MB.GT.MIN( M, N ) .OR. MB.LT.1 ) MB = 1 + IF( NB.GT.N .OR. NB.LE.M ) NB = N + MINTSZ = M + 5 + IF ( NB.GT.M .AND. N.GT.M ) THEN + IF( MOD( N - M, NB - M ).EQ.0 ) THEN + NBLCKS = ( N - M ) / ( NB - M ) + ELSE + NBLCKS = ( N - M ) / ( NB - M ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) .OR. LWORK.LT.MB*M ) + $ .AND. ( LWORK.GE.M ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + MB = 1 + NB = N + END IF + IF( LWORK.LT.MB*M ) THEN + LMINWS = .TRUE. + MB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, MB*M*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, M*MB ) ) .AND .( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = MB*M*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, MB*M ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF( ( N.LE.M ) .OR. ( NB.LE.M ) .OR. ( NB.GE.N ) ) THEN + CALL ZGELQT( M, N, MB, A, LDA, T( 6 ), MB, WORK, INFO ) + ELSE + CALL ZLASWLQ( M, N, MB, NB, A, LDA, T( 6 ), MB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, MB*M ) +* + RETURN +* +* End of ZGELQ +* + END diff --git a/lapack-netlib/SRC/zgelq2.f b/lapack-netlib/SRC/zgelq2.f index 5877e98316..188c8f8c81 100644 --- a/lapack-netlib/SRC/zgelq2.f +++ b/lapack-netlib/SRC/zgelq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgelqf.f b/lapack-netlib/SRC/zgelqf.f index 4ef8ab679f..8d9341a61f 100644 --- a/lapack-netlib/SRC/zgelqf.f +++ b/lapack-netlib/SRC/zgelqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -135,10 +135,10 @@ * ===================================================================== SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgelqt.f b/lapack-netlib/SRC/zgelqt.f new file mode 100644 index 0000000000..c8afd1c56e --- /dev/null +++ b/lapack-netlib/SRC/zgelqt.f @@ -0,0 +1,210 @@ +*> \brief \b ZGELQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A +*> using the compact WY representation of Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is +*> lower triangular if M <= N); the elements above the diagonal +*> are the rows of V. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,MIN(M,N)) +*> The upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MB*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. +*> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each +*> block is of order NB except for the last block, which is of order +*> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> for the last block) T's are stored in the NB-by-N matrix T as +*> +*> T = (T1 T2 ... TB). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDT, M, N, MB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, IINFO, K +* .. +* .. External Subroutines .. + EXTERNAL ZGELQT3, ZLARFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. (MB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ))THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + K = MIN( M, N ) + IF( K.EQ.0 ) RETURN +* +* Blocked loop of length K +* + DO I = 1, K, MB + IB = MIN( K-I+1, MB ) +* +* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) +* + CALL ZGELQT3( IB, N-I+1, A(I,I), LDA, T(1,I), LDT, IINFO ) + IF( I+IB.LE.M ) THEN +* +* Update by applying H**T to A(I:M,I+IB:N) from the right +* + CALL ZLARFB( 'R', 'N', 'F', 'R', M-I-IB+1, N-I+1, IB, + $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, WORK , M-I-IB+1 ) + END IF + END DO + RETURN +* +* End of ZGELQT +* + END diff --git a/lapack-netlib/SRC/zgelqt3.f b/lapack-netlib/SRC/zgelqt3.f new file mode 100644 index 0000000000..14063544f2 --- /dev/null +++ b/lapack-netlib/SRC/zgelqt3.f @@ -0,0 +1,261 @@ +*> \brief \b ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQT3 recursively computes a LQ factorization of a complex M-by-N +*> matrix A, using the compact WY representation of Q. +*> +*> Based on the algorithm of Elmroth and Gustavson, +*> IBM J. Res. Develop. Vol 44 No. 4 July 2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M =< N. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the real M-by-N matrix A. On exit, the elements on and +*> below the diagonal contain the N-by-N lower triangular matrix L; the +*> elements above the diagonal are the rows of V. See below for +*> further details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> The N-by-N upper triangular factor of the block reflector. +*> The elements on and above the diagonal contain the block +*> reflector T; the elements below the diagonal are not used. +*> See below for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix V stores the elementary reflectors H(i) in the i-th column +*> below the diagonal. For example, if M=5 and N=3, the matrix V is +*> +*> V = ( 1 v1 v1 v1 v1 ) +*> ( 1 v2 v2 v2 ) +*> ( 1 v3 v3 v3 ) +*> +*> +*> where the vi's represent the vectors which define H(i), which are returned +*> in the matrix A. The 1's along the diagonal of V are not stored in A. The +*> block reflector H is then given by +*> +*> H = I - V * T * V**T +*> +*> where V**T is the transpose of V. +*> +*> For details of the algorithm, see Elmroth and Gustavson (cited above). +*> \endverbatim +*> +* ===================================================================== + RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, LDT +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = (1.0D+00,0.0D+00) ) + PARAMETER ( ZERO = (0.0D+00,0.0D+00)) +* .. +* .. Local Scalars .. + INTEGER I, I1, J, J1, M1, M2, N1, N2, IINFO +* .. +* .. External Subroutines .. + EXTERNAL ZLARFG, ZTRMM, ZGEMM, XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( N .LT. M ) THEN + INFO = -2 + ELSE IF( LDA .LT. MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( LDT .LT. MAX( 1, M ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELQT3', -INFO ) + RETURN + END IF +* + IF( M.EQ.1 ) THEN +* +* Compute Householder transform when N=1 +* + CALL ZLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T ) + T(1,1)=CONJG(T(1,1)) +* + ELSE +* +* Otherwise, split A into blocks... +* + M1 = M/2 + M2 = M-M1 + I1 = MIN( M1+1, M ) + J1 = MIN( M+1, N ) +* +* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H +* + CALL ZGELQT3( M1, N, A, LDA, T, LDT, IINFO ) +* +* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)] +* + DO I=1,M2 + DO J=1,M1 + T( I+M1, J ) = A( I+M1, J ) + END DO + END DO + CALL ZTRMM( 'R', 'U', 'C', 'U', M2, M1, ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + CALL ZGEMM( 'N', 'C', M2, M1, N-M1, ONE, A( I1, I1 ), LDA, + & A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT) +* + CALL ZTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE, + & T, LDT, T( I1, 1 ), LDT ) +* + CALL ZGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT, + & A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA ) +* + CALL ZTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE, + & A, LDA, T( I1, 1 ), LDT ) +* + DO I=1,M2 + DO J=1,M1 + A( I+M1, J ) = A( I+M1, J ) - T( I+M1, J ) + T( I+M1, J )= ZERO + END DO + END DO +* +* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H +* + CALL ZGELQT3( M2, N-M1, A( I1, I1 ), LDA, + & T( I1, I1 ), LDT, IINFO ) +* +* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 +* + DO I=1,M2 + DO J=1,M1 + T( J, I+M1 ) = (A( J, I+M1 )) + END DO + END DO +* + CALL ZTRMM( 'R', 'U', 'C', 'U', M1, M2, ONE, + & A( I1, I1 ), LDA, T( 1, I1 ), LDT ) +* + CALL ZGEMM( 'N', 'C', M1, M2, N-M, ONE, A( 1, J1 ), LDA, + & A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT ) +* + CALL ZTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT, + & T( 1, I1 ), LDT ) +* + CALL ZTRMM( 'R', 'U', 'N', 'N', M1, M2, ONE, + & T( I1, I1 ), LDT, T( 1, I1 ), LDT ) +* +* +* +* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] +* [ A(1:N1,J1:N) L2 ] [ 0 T2] +* + END IF +* + RETURN +* +* End of ZGELQT3 +* + END diff --git a/lapack-netlib/SRC/zgels.f b/lapack-netlib/SRC/zgels.f index 4546582fba..8e2794fa46 100644 --- a/lapack-netlib/SRC/zgels.f +++ b/lapack-netlib/SRC/zgels.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,7 +49,7 @@ *> an underdetermined system A * X = B. *> *> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of -*> an undetermined system A**H * X = B. +*> an underdetermined system A**H * X = B. *> *> 4. If TRANS = 'C' and m < n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEsolve * @@ -182,10 +182,10 @@ SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -380,7 +380,7 @@ SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * ELSE * -* Overdetermined system of equations A**H * X = B +* Underdetermined system of equations A**T * X = B * * B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS) * diff --git a/lapack-netlib/SRC/zgelsd.f b/lapack-netlib/SRC/zgelsd.f index aeaa96edb2..ce574173ae 100644 --- a/lapack-netlib/SRC/zgelsd.f +++ b/lapack-netlib/SRC/zgelsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), S( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,10 +50,10 @@ *> *> The problem is solved in three steps: *> (1) Reduce the coefficient matrix A to bidiagonal form with -*> Householder tranformations, reducing the original problem +*> Householder transformations, reducing the original problem *> into a "bidiagonal least squares problem" (BLS) *> (2) Solve the BLS using a divide and conquer approach. -*> (3) Apply back all the Householder tranformations to solve +*> (3) Apply back all the Householder transformations to solve *> the original least squares problem. *> *> The effective rank of A is determined by treating as zero those @@ -205,12 +205,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEsolve * @@ -225,10 +225,10 @@ SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/zgelss.f b/lapack-netlib/SRC/zgelss.f index 56e58ddfe5..df436b48be 100644 --- a/lapack-netlib/SRC/zgelss.f +++ b/lapack-netlib/SRC/zgelss.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELSS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELSS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), S( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16GEsolve * @@ -178,10 +178,10 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -285,8 +285,8 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * Path 1 - overdetermined or exactly determined * * Compute space needed for ZGEBRD - CALL ZGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL ZGEBRD( MM, N, A, LDA, S, S, DUM(1), DUM(1), DUM(1), + $ -1, INFO ) LWORK_ZGEBRD=DUM(1) * Compute space needed for ZUNMBR CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, DUM(1), @@ -296,7 +296,7 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL ZUNGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_ZUNGBR=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZGEBRD ) MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR ) MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR ) @@ -315,11 +315,11 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ -1, INFO ) LWORK_ZGELQF=DUM(1) * Compute space needed for ZGEBRD - CALL ZGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL ZGEBRD( M, M, A, LDA, S, S, DUM(1), DUM(1), + $ DUM(1), -1, INFO ) LWORK_ZGEBRD=DUM(1) * Compute space needed for ZUNMBR - CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, + CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_ZUNMBR=DUM(1) * Compute space needed for ZUNGBR @@ -330,7 +330,7 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_ZUNMLQ=DUM(1) -* Compute total workspace needed +* Compute total workspace needed MAXWRK = M + LWORK_ZGELQF MAXWRK = MAX( MAXWRK, 3*M + M*M + LWORK_ZGEBRD ) MAXWRK = MAX( MAXWRK, 3*M + M*M + LWORK_ZUNMBR ) @@ -346,11 +346,11 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * Path 2 - underdetermined * * Compute space needed for ZGEBRD - CALL ZGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) + CALL ZGEBRD( M, N, A, LDA, S, S, DUM(1), DUM(1), + $ DUM(1), -1, INFO ) LWORK_ZGEBRD=DUM(1) * Compute space needed for ZUNMBR - CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, A, LDA, + CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_ZUNMBR=DUM(1) * Compute space needed for ZUNGBR diff --git a/lapack-netlib/SRC/zgelsy.f b/lapack-netlib/SRC/zgelsy.f index 2e8999a503..79cb7936bc 100644 --- a/lapack-netlib/SRC/zgelsy.f +++ b/lapack-netlib/SRC/zgelsy.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGELSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGELSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -190,19 +190,19 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEsolve * *> \par Contributors: * ================== *> -*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n *> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> @@ -210,10 +210,10 @@ SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK diff --git a/lapack-netlib/SRC/zgemlq.f b/lapack-netlib/SRC/zgemlq.f new file mode 100644 index 0000000000..aa07e0feb4 --- /dev/null +++ b/lapack-netlib/SRC/zgemlq.f @@ -0,0 +1,282 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMLQ overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> where Q is a complex unitary matrix defined as the product +*> of blocked elementary reflectors computed by short wide +*> LQ factorization (ZGELQ) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> Part of the data structure to represent Q as returned by ZGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by ZGELQ. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> ZLASWLQ or ZGELQT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, ZGELQ will use either +*> ZLASWLQ (if the matrix is wide-and-short) or ZGELQT to compute +*> the LQ factorization. +*> This version of ZGEMLQ will use either ZLAMSWLQ or ZGEMLQT to +*> multiply matrix Q by another matrix. +*> Further Details in ZLAMSWLQ or ZGEMLQT. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLAMSWLQ, ZGEMLQT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * MB + MN = M + ELSE + LW = M * MB + MN = N + END IF +* + IF( ( NB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, NB - K ) .EQ. 0 ) THEN + NBLCKS = ( MN - K ) / ( NB - K ) + ELSE + NBLCKS = ( MN - K ) / ( NB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( NB.LE.K ) .OR. ( NB.GE.MAX( M, N, K ) ) ) THEN + CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T( 6 ), MB, C, LDC, WORK, INFO ) + ELSE + CALL ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ MB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of ZGEMLQ +* + END diff --git a/lapack-netlib/SRC/zgemlqt.f b/lapack-netlib/SRC/zgemlqt.f new file mode 100644 index 0000000000..569713c717 --- /dev/null +++ b/lapack-netlib/SRC/zgemlqt.f @@ -0,0 +1,289 @@ +*> \brief \b ZGEMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, +* C, LDC, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMQRT overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q C C Q +*> TRANS = 'C': Q**C C C Q**C +*> +*> where Q is a complex orthogonal matrix defined as the product of K +*> elementary reflectors: +*> +*> Q = H(1) H(2) . . . H(K) = I - V C V**C +*> +*> generated using the compact WY representation as returned by ZGELQT. +*> +*> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**C from the Left; +*> = 'R': apply Q or Q**C from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DGELQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQT in the first K rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DGELQT, stored as a MB-by-M matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q C, Q**C C, C Q**C or C Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array. The dimension of +*> WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, + $ C, LDC, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDC, M, N, MB, LDT +* .. +* .. Array Arguments .. + COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, LDWORK, KF, Q +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'C' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF( LEFT ) THEN + LDWORK = MAX( 1, N ) + ELSE IF ( RIGHT ) THEN + LDWORK = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0) THEN + INFO = -5 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0)) THEN + INFO = -6 + ELSE IF( LDV.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL ZLARFB( 'L', 'C', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + CALL ZLARFB( 'R', 'N', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL ZLARFB( 'L', 'N', 'F', 'R', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( I, 1 ), LDC, WORK, LDWORK ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + CALL ZLARFB( 'R', 'C', 'F', 'R', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, + $ C( 1, I ), LDC, WORK, LDWORK ) + END DO +* + END IF +* + RETURN +* +* End of ZGEMLQT +* + END diff --git a/lapack-netlib/SRC/zgemqr.f b/lapack-netlib/SRC/zgemqr.f new file mode 100644 index 0000000000..32f1bf4d5e --- /dev/null +++ b/lapack-netlib/SRC/zgemqr.f @@ -0,0 +1,285 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, +* $ TSIZE, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMQR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (ZGEQR) +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> Part of the data structure to represent Q as returned by ZGEQR. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (MAX(5,TSIZE)). +*> Part of the data structure to represent Q as returned by ZGEQR. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> The dimension of the array T. TSIZE >= 5. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1, then a workspace query is assumed. The routine +*> only calculates the size of the WORK array, returns this +*> value as WORK(1), and no error message related to WORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> ZLATSQR or ZGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, ZGEQR will use either +*> ZLATSQR (if the matrix is tall-and-skinny) or ZGEQRT to compute +*> the QR factorization. +*> This version of ZGEMQR will use either ZLAMTSQR or ZGEMQRT to +*> multiply matrix Q by another matrix. +*> Further Details in ZLAMTSQR or ZGEMQRT. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, + $ C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, TSIZE, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER MB, NB, LW, NBLCKS, MN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMQRT, ZLAMTSQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.EQ.-1 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) +* + MB = INT( T( 2 ) ) + NB = INT( T( 3 ) ) + IF( LEFT ) THEN + LW = N * NB + MN = M + ELSE + LW = MB * NB + MN = N + END IF +* + IF( ( MB.GT.K ) .AND. ( MN.GT.K ) ) THEN + IF( MOD( MN - K, MB - K ).EQ.0 ) THEN + NBLCKS = ( MN - K ) / ( MB - K ) + ELSE + NBLCKS = ( MN - K ) / ( MB - K ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.MN ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, MN ) ) THEN + INFO = -7 + ELSE IF( TSIZE.LT.5 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( LWORK.LT.MAX( 1, LW ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N, K ).EQ.0 ) THEN + RETURN + END IF +* + IF( ( LEFT .AND. M.LE.K ) .OR. ( RIGHT .AND. N.LE.K ) + $ .OR. ( MB.LE.K ) .OR. ( MB.GE.MAX( M, N, K ) ) ) THEN + CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, INFO ) + ELSE + CALL ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T( 6 ), + $ NB, C, LDC, WORK, LWORK, INFO ) + END IF +* + WORK( 1 ) = LW +* + RETURN +* +* End of ZGEMQR +* + END diff --git a/lapack-netlib/SRC/zgemqrt.f b/lapack-netlib/SRC/zgemqrt.f index 19d684f733..7ceb77fe32 100644 --- a/lapack-netlib/SRC/zgemqrt.f +++ b/lapack-netlib/SRC/zgemqrt.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, +* SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * C, LDC, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDC, M, N, NB, LDT @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -46,7 +46,7 @@ *> *> Q = H(1) H(2) . . . H(K) = I - V T V**H *> -*> generated using the compact WY representation as returned by ZGEQRT. +*> generated using the compact WY representation as returned by ZGEQRT. *> *> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. *> \endverbatim @@ -155,23 +155,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== - SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, + SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -207,7 +207,7 @@ SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF( LEFT ) THEN LDWORK = MAX( 1, N ) Q = M @@ -248,17 +248,17 @@ SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL ZLARFB( 'L', 'C', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL ZLARFB( 'L', 'C', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) - CALL ZLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + CALL ZLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * @@ -266,9 +266,9 @@ SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL ZLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL ZLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * @@ -276,9 +276,9 @@ SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) - CALL ZLARFB( 'R', 'C', 'F', 'C', M, N-I+1, IB, - $ V( I, I ), LDV, T( 1, I ), LDT, + IB = MIN( NB, K-I+1 ) + CALL ZLARFB( 'R', 'C', 'F', 'C', M, N-I+1, IB, + $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * diff --git a/lapack-netlib/SRC/zgeql2.f b/lapack-netlib/SRC/zgeql2.f index 6f9d10f4db..90008c49a6 100644 --- a/lapack-netlib/SRC/zgeql2.f +++ b/lapack-netlib/SRC/zgeql2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgeqlf.f b/lapack-netlib/SRC/zgeqlf.f index 83fcb3cad8..82bb9d1f7e 100644 --- a/lapack-netlib/SRC/zgeqlf.f +++ b/lapack-netlib/SRC/zgeqlf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQLF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQLF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgeqp3.f b/lapack-netlib/SRC/zgeqp3.f index 5b6e8a9bcc..ea069ee74e 100644 --- a/lapack-netlib/SRC/zgeqp3.f +++ b/lapack-netlib/SRC/zgeqp3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -159,10 +159,10 @@ SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgeqr.f b/lapack-netlib/SRC/zgeqr.f new file mode 100644 index 0000000000..1aa457f563 --- /dev/null +++ b/lapack-netlib/SRC/zgeqr.f @@ -0,0 +1,307 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZGEQR computes a QR factorization of an M-by-N matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(M,N)-by-N upper trapezoidal matrix R +*> (R is upper triangular if M >= N); +*> the elements below the diagonal are used to store part of the +*> data structure to represent Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (MAX(5,TSIZE)) +*> On exit, if INFO = 0, T(1) returns optimal (or either minimal +*> or optimal, if query is assumed) TSIZE. See TSIZE for details. +*> Remaining T contains part of the data structure used to represent Q. +*> If one wants to apply or construct Q, then one needs to keep T +*> (in addition to A) and pass it to further subroutines. +*> \endverbatim +*> +*> \param[in] TSIZE +*> \verbatim +*> TSIZE is INTEGER +*> If TSIZE >= 5, the dimension of the array T. +*> If TSIZE = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If TSIZE = -1, the routine calculates optimal size of T for the +*> optimum performance and returns this value in T(1). +*> If TSIZE = -2, the routine calculates minimal size of T and +*> returns this value in T(1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. The routine +*> only calculates the sizes of the T and WORK arrays, returns these +*> values as the first entries of the T and WORK arrays, and no error +*> message related to T or WORK is issued by XERBLA. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details +* ==================== +*> +*> \verbatim +*> +*> The goal of the interface is to give maximum freedom to the developers for +*> creating any QR factorization algorithm they wish. The triangular +*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A +*> and the array T can be used to store any relevant information for applying or +*> constructing the Q factor. The WORK array can safely be discarded after exit. +*> +*> Caution: One should not expect the sizes of T and WORK to be the same from one +*> LAPACK implementation to the other, or even from one execution to the other. +*> A workspace query (for T and WORK) is needed at each execution. However, +*> for a given execution, the size of T and WORK are fixed and will not change +*> from one query to the next. +*> +*> \endverbatim +*> +*> \par Further Details particular to this LAPACK implementation: +* ============================================================== +*> +*> \verbatim +*> +*> These details are particular for this LAPACK implementation. Users should not +*> take them for granted. These details may change in the future, and are unlikely not +*> true for another LAPACK implementation. These details are relevant if one wants +*> to try to understand the code. They are not part of the interface. +*> +*> In this version, +*> +*> T(2): row block size (MB) +*> T(3): column block size (NB) +*> T(6:TSIZE): data structure needed for Q, computed by +*> ZLATSQR or ZGEQRT +*> +*> Depending on the matrix dimensions M and N, and row and column +*> block sizes MB and NB returned by ILAENV, ZGEQR will use either +*> ZLATSQR (if the matrix is tall-and-skinny) or ZGEQRT to compute +*> the QR factorization. +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, TSIZE, LWORK +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY, LMINWS, MINT, MINW + INTEGER MB, NB, MINTSZ, NBLCKS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLATSQR, ZGEQRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR. + $ LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) +* + MINT = .FALSE. + MINW = .FALSE. + IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN + IF( TSIZE.NE.-1 ) MINT = .TRUE. + IF( LWORK.NE.-1 ) MINW = .TRUE. + END IF +* +* Determine the block size +* + IF( MIN ( M, N ).GT.0 ) THEN + MB = ILAENV( 1, 'ZGEQR ', ' ', M, N, 1, -1 ) + NB = ILAENV( 1, 'ZGEQR ', ' ', M, N, 2, -1 ) + ELSE + MB = M + NB = 1 + END IF + IF( MB.GT.M .OR. MB.LE.N ) MB = M + IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1 + MINTSZ = N + 5 + IF( MB.GT.N .AND. M.GT.N ) THEN + IF( MOD( M - N, MB - N ).EQ.0 ) THEN + NBLCKS = ( M - N ) / ( MB - N ) + ELSE + NBLCKS = ( M - N ) / ( MB - N ) + 1 + END IF + ELSE + NBLCKS = 1 + END IF +* +* Determine if the workspace size satisfies minimal size +* + LMINWS = .FALSE. + IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N ) + $ .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ ) + $ .AND. ( .NOT.LQUERY ) ) THEN + IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN + LMINWS = .TRUE. + NB = 1 + MB = M + END IF + IF( LWORK.LT.NB*N ) THEN + LMINWS = .TRUE. + NB = 1 + END IF + END IF +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) + $ .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN + INFO = -6 + ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY ) + $ .AND. ( .NOT.LMINWS ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( MINT ) THEN + T( 1 ) = MINTSZ + ELSE + T( 1 ) = NB*N*NBLCKS + 5 + END IF + T( 2 ) = MB + T( 3 ) = NB + IF( MINW ) THEN + WORK( 1 ) = MAX( 1, N ) + ELSE + WORK( 1 ) = MAX( 1, NB*N ) + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN( M, N ).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN + CALL ZGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO ) + ELSE + CALL ZLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK, + $ LWORK, INFO ) + END IF +* + WORK( 1 ) = MAX( 1, NB*N ) +* + RETURN +* +* End of ZGEQR +* + END diff --git a/lapack-netlib/SRC/zgeqr2.f b/lapack-netlib/SRC/zgeqr2.f index f7775bbe37..d2774d7889 100644 --- a/lapack-netlib/SRC/zgeqr2.f +++ b/lapack-netlib/SRC/zgeqr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgeqr2p.f b/lapack-netlib/SRC/zgeqr2p.f index e057247d3f..0e5e55486e 100644 --- a/lapack-netlib/SRC/zgeqr2p.f +++ b/lapack-netlib/SRC/zgeqr2p.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQR2P + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> On entry, the m by n matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the min(m,n) by n upper trapezoidal matrix R (R is -*> upper triangular if m >= n). The diagonal entries of R +*> upper triangular if m >= n). The diagonal entries of R *> are real and nonnegative; the elements below the diagonal, *> with the array TAU, represent the unitary matrix Q as a *> product of elementary reflectors (see Further Details). @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -124,10 +124,10 @@ * ===================================================================== SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgeqrf.f b/lapack-netlib/SRC/zgeqrf.f index 9ba1553ac2..3ea1e71e1f 100644 --- a/lapack-netlib/SRC/zgeqrf.f +++ b/lapack-netlib/SRC/zgeqrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -136,10 +136,10 @@ * ===================================================================== SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgeqrfp.f b/lapack-netlib/SRC/zgeqrfp.f index fcf9bded61..cdc4bfa94f 100644 --- a/lapack-netlib/SRC/zgeqrfp.f +++ b/lapack-netlib/SRC/zgeqrfp.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQRFP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQRFP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -139,10 +139,10 @@ * ===================================================================== SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgeqrt.f b/lapack-netlib/SRC/zgeqrt.f index 0603c4fe9d..4f872c5be1 100644 --- a/lapack-netlib/SRC/zgeqrt.f +++ b/lapack-netlib/SRC/zgeqrt.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> ZGEQRT computes a blocked QR factorization of a complex M-by-N matrix A -*> using the compact WY representation of Q. +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -130,9 +130,9 @@ *> in the matrix A. The 1's along the diagonal of V are not stored in A. *> *> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = (T1 T2 ... TB). @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -194,7 +194,7 @@ SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * DO I = 1, K, NB IB = MIN( K-I+1, NB ) -* +* * Compute the QR factorization of the current block A(I:M,I:I+IB-1) * IF( USE_RECURSIVE_QR ) THEN @@ -207,12 +207,12 @@ SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * Update by applying H**H to A(I:M,I+IB:N) from the left * CALL ZLARFB( 'L', 'C', 'F', 'C', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, T( 1, I ), LDT, + $ A( I, I ), LDA, T( 1, I ), LDT, $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN -* +* * End of ZGEQRT * END diff --git a/lapack-netlib/SRC/zgeqrt2.f b/lapack-netlib/SRC/zgeqrt2.f index d3400afda0..bad7084988 100644 --- a/lapack-netlib/SRC/zgeqrt2.f +++ b/lapack-netlib/SRC/zgeqrt2.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZGEQRT2 computes a QR factorization of a complex M-by-N matrix A, -*> using the compact WY representation of Q. +*> ZGEQRT2 computes a QR factorization of a complex M-by-N matrix A, +*> using the compact WY representation of Q. *> \endverbatim * * Arguments: @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -127,10 +127,10 @@ * ===================================================================== SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N @@ -170,7 +170,7 @@ SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) CALL XERBLA( 'ZGEQRT2', -INFO ) RETURN END IF -* +* K = MIN( M, N ) * DO I = 1, K @@ -188,13 +188,13 @@ SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)] * - CALL ZGEMV( 'C',M-I+1, N-I, ONE, A( I, I+1 ), LDA, + CALL ZGEMV( 'C',M-I+1, N-I, ONE, A( I, I+1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) * * A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H * ALPHA = -CONJG(T( I, 1 )) - CALL ZGERC( M-I+1, N-I, ALPHA, A( I, I ), 1, + CALL ZGERC( M-I+1, N-I, ALPHA, A( I, I ), 1, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF @@ -207,7 +207,7 @@ SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) * T(1:I-1,I) := alpha * A(I:M,1:I-1)**H * A(I:M,I) * ALPHA = -T( I, 1 ) - CALL ZGEMV( 'C', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, + CALL ZGEMV( 'C', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * @@ -220,7 +220,7 @@ SUBROUTINE ZGEQRT2( M, N, A, LDA, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO - + * * End of ZGEQRT2 * diff --git a/lapack-netlib/SRC/zgeqrt3.f b/lapack-netlib/SRC/zgeqrt3.f index 8926b9980b..e0f2281a11 100644 --- a/lapack-netlib/SRC/zgeqrt3.f +++ b/lapack-netlib/SRC/zgeqrt3.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGEQRT3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGEQRT3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZGEQRT3 recursively computes a QR factorization of a complex M-by-N -*> matrix A, using the compact WY representation of Q. +*> ZGEQRT3 recursively computes a QR factorization of a complex M-by-N +*> matrix A, using the compact WY representation of Q. *> -*> Based on the algorithm of Elmroth and Gustavson, +*> Based on the algorithm of Elmroth and Gustavson, *> IBM J. Res. Develop. Vol 44 No. 4 July 2000. *> \endverbatim * @@ -58,7 +58,7 @@ *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the complex M-by-N matrix A. On exit, the elements on +*> On entry, the complex M-by-N matrix A. On exit, the elements on *> and above the diagonal contain the N-by-N upper triangular matrix R; *> the elements below the diagonal are the columns of V. See below for *> further details. @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16GEcomputational * @@ -132,10 +132,10 @@ * ===================================================================== RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT @@ -177,8 +177,8 @@ RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute Householder transform when N=1 * - CALL ZLARFG( M, A, A( MIN( 2, M ), 1 ), 1, T ) -* + CALL ZLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) +* ELSE * * Otherwise, split A into blocks... @@ -199,7 +199,7 @@ RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) T( I, J+N1 ) = A( I, J+N1 ) END DO END DO - CALL ZTRMM( 'L', 'L', 'C', 'U', N1, N2, ONE, + CALL ZTRMM( 'L', 'L', 'C', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * CALL ZGEMM( 'C', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, @@ -208,7 +208,7 @@ RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL ZTRMM( 'L', 'U', 'C', 'N', N1, N2, ONE, & T, LDT, T( 1, J1 ), LDT ) * - CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, + CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL ZTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, @@ -222,7 +222,7 @@ RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H * - CALL ZGEQRT3( M-N1, N2, A( J1, J1 ), LDA, + CALL ZGEQRT3( M-N1, N2, A( J1, J1 ), LDA, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 @@ -236,13 +236,13 @@ RECURSIVE SUBROUTINE ZGEQRT3( M, N, A, LDA, T, LDT, INFO ) CALL ZTRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) * - CALL ZGEMM( 'C', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, + CALL ZGEMM( 'C', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) * - CALL ZTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, + CALL ZTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, & T( 1, J1 ), LDT ) * - CALL ZTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, + CALL ZTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] diff --git a/lapack-netlib/SRC/zgerfs.f b/lapack-netlib/SRC/zgerfs.f index e3a0c5d049..4d09922405 100644 --- a/lapack-netlib/SRC/zgerfs.f +++ b/lapack-netlib/SRC/zgerfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,12 +173,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -186,10 +186,10 @@ SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgerfsx.f b/lapack-netlib/SRC/zgerfsx.f index 549c32f0bc..5aabe50ed5 100644 --- a/lapack-netlib/SRC/zgerfsx.f +++ b/lapack-netlib/SRC/zgerfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,7 +143,7 @@ *> R is DOUBLE PRECISION array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R -*> is not accessed. +*> is not accessed. *> If R is accessed, each element of R should be a power of the radix *> to ensure a reliable solution and error estimates. Scaling by *> powers of the radix does not cause rounding errors unless the @@ -399,12 +399,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -414,10 +414,10 @@ SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, EQUED @@ -475,11 +475,10 @@ SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILATRANS, ILAPREC EXTERNAL DLAMCH, ZLANGE, ZLA_GERCOND_X, ZLA_GERCOND_C DOUBLE PRECISION DLAMCH, ZLANGE, ZLA_GERCOND_X, ZLA_GERCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X INTEGER ILATRANS, ILAPREC * .. * .. Executable Statements .. diff --git a/lapack-netlib/SRC/zgerq2.f b/lapack-netlib/SRC/zgerq2.f index 6d628a1f75..73c1e53ed4 100644 --- a/lapack-netlib/SRC/zgerq2.f +++ b/lapack-netlib/SRC/zgerq2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGERQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -123,10 +123,10 @@ * ===================================================================== SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgerqf.f b/lapack-netlib/SRC/zgerqf.f index 51e8b3462f..ebc7d38aa3 100644 --- a/lapack-netlib/SRC/zgerqf.f +++ b/lapack-netlib/SRC/zgerqf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGERQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGERQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -138,10 +138,10 @@ * ===================================================================== SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zgesc2.f b/lapack-netlib/SRC/zgesc2.f index ce969550d6..e5bea14302 100644 --- a/lapack-netlib/SRC/zgesc2.f +++ b/lapack-netlib/SRC/zgesc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, N * DOUBLE PRECISION SCALE @@ -28,7 +28,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 A( LDA, * ), RHS( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEauxiliary * @@ -115,10 +115,10 @@ * ===================================================================== SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, N diff --git a/lapack-netlib/SRC/zgesdd.f b/lapack-netlib/SRC/zgesdd.f index ea08dbc6db..bb9d2c26e7 100644 --- a/lapack-netlib/SRC/zgesdd.f +++ b/lapack-netlib/SRC/zgesdd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESDD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESDD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, -* LWORK, RWORK, IWORK, INFO ) -* +* SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, +* WORK, LWORK, RWORK, IWORK, INFO ) +* * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,8 +135,8 @@ *> \param[in] LDU *> \verbatim *> LDU is INTEGER -*> The leading dimension of the array U. LDU >= 1; if -*> JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. +*> The leading dimension of the array U. LDU >= 1; +*> if JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. *> \endverbatim *> *> \param[out] VT @@ -152,8 +152,8 @@ *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; +*> The leading dimension of the array VT. LDVT >= 1; +*> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; *> if JOBZ = 'S', LDVT >= min(M,N). *> \endverbatim *> @@ -167,24 +167,28 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. -*> if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N). -*> if JOBZ = 'O', -*> LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). -*> if JOBZ = 'S' or 'A', -*> LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). -*> For good performance, LWORK should generally be larger. -*> *> If LWORK = -1, a workspace query is assumed. The optimal *> size for the WORK array is calculated and stored in WORK(1), *> and no other work except argument checking is performed. +*> +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LWORK >= 2*mn + mx. +*> If JOBZ = 'O', LWORK >= 2*mn*mn + 2*mn + mx. +*> If JOBZ = 'S', LWORK >= mn*mn + 3*mn. +*> If JOBZ = 'A', LWORK >= mn*mn + 2*mn + mx. +*> These are not tight minimums in all cases; see comments inside code. +*> For good performance, LWORK should generally be larger; +*> a query is recommended. *> \endverbatim *> *> \param[out] RWORK *> \verbatim *> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) -*> If JOBZ = 'N', LRWORK >= 7*min(M,N). -*> Otherwise, -*> LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1) +*> Let mx = max(M,N) and mn = min(M,N). +*> If JOBZ = 'N', LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn); +*> else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn; +*> else LRWORK >= max( 5*mn*mn + 5*mn, +*> 2*mx*mn + 2*mn*mn + mn ). *> \endverbatim *> *> \param[out] IWORK @@ -203,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16GEsing * @@ -219,13 +223,14 @@ *> California at Berkeley, USA *> * ===================================================================== - SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, - $ LWORK, RWORK, IWORK, INFO ) + SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, RWORK, IWORK, INFO ) + implicit none * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ @@ -241,8 +246,6 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ===================================================================== * * .. Parameters .. - INTEGER LQUERV - PARAMETER ( LQUERV = -1 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) @@ -250,16 +253,27 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS INTEGER BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT, $ ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, $ MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL + INTEGER LWORK_ZGEBRD_MN, LWORK_ZGEBRD_MM, + $ LWORK_ZGEBRD_NN, LWORK_ZGELQF_MN, + $ LWORK_ZGEQRF_MN, + $ LWORK_ZUNGBR_P_MN, LWORK_ZUNGBR_P_NN, + $ LWORK_ZUNGBR_Q_MN, LWORK_ZUNGBR_Q_MM, + $ LWORK_ZUNGLQ_MN, LWORK_ZUNGLQ_NN, + $ LWORK_ZUNGQR_MM, LWORK_ZUNGQR_MN, + $ LWORK_ZUNMBR_PRC_MM, LWORK_ZUNMBR_QLN_MM, + $ LWORK_ZUNMBR_PRC_MN, LWORK_ZUNMBR_QLN_MN, + $ LWORK_ZUNMBR_PRC_NN, LWORK_ZUNMBR_QLN_NN DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) + COMPLEX*16 CDUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM, @@ -268,9 +282,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE + EXTERNAL LSAME, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -279,15 +292,16 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Test the input arguments * - INFO = 0 - MINMN = MIN( M, N ) + INFO = 0 + MINMN = MIN( M, N ) MNTHR1 = INT( MINMN*17.0D0 / 9.0D0 ) MNTHR2 = INT( MINMN*5.0D0 / 3.0D0 ) - WNTQA = LSAME( JOBZ, 'A' ) - WNTQS = LSAME( JOBZ, 'S' ) + WNTQA = LSAME( JOBZ, 'A' ) + WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS - WNTQO = LSAME( JOBZ, 'O' ) - WNTQN = LSAME( JOBZ, 'N' ) + WNTQO = LSAME( JOBZ, 'O' ) + WNTQN = LSAME( JOBZ, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) MINWRK = 1 MAXWRK = 1 * @@ -309,244 +323,296 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF * * Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, +* Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace allocated at that point in the code, * as well as the preferred amount for good performance. * CWorkspace refers to complex workspace, and RWorkspace to * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN - IF( M.GE.N ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC -* for computing singular values and singular vectors; BDSPAN -* for computing singular values only. -* BDSPAC = 5*N*N + 7*N -* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) +* The real work space needed for bidiagonal SVD (dbdsdc) is +* BDSPAC = 3*N*N + 4*N for singular values and vectors; +* BDSPAC = 4*N for singular values only; +* not including e, RU, and RVT matrices. +* +* Compute space preferred for each routine + CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGEBRD_MN = INT( CDUM(1) ) +* + CALL ZGEBRD( N, N, CDUM(1), N, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGEBRD_NN = INT( CDUM(1) ) +* + CALL ZGEQRF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGEQRF_MN = INT( CDUM(1) ) +* + CALL ZUNGBR( 'P', N, N, N, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_P_NN = INT( CDUM(1) ) +* + CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_Q_MM = INT( CDUM(1) ) +* + CALL ZUNGBR( 'Q', M, N, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_Q_MN = INT( CDUM(1) ) +* + CALL ZUNGQR( M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGQR_MM = INT( CDUM(1) ) +* + CALL ZUNGQR( M, N, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGQR_MN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'P', 'R', 'C', N, N, N, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) ) +* + CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_QLN_MN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_QLN_NN = INT( CDUM(1) ) * IF( M.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * - MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) + MAXWRK = N + LWORK_ZGEQRF_MN + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZGEBRD_NN ) MINWRK = 3*N ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 2 (M >> N, JOBZ='O') +* + WRKBL = N + LWORK_ZGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN ) MAXWRK = M*N + N*N + WRKBL MINWRK = 2*N*N + 3*N ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 3 (M >> N, JOBZ='S') +* + WRKBL = N + LWORK_ZGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN ) MAXWRK = N*N + WRKBL MINWRK = N*N + 3*N ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) ) +* Path 4 (M >> N, JOBZ='A') +* + WRKBL = N + LWORK_ZGEQRF_MN + WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MM ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN ) + WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN ) MAXWRK = N*N + WRKBL - MINWRK = N*N + 2*N + M + MINWRK = N*N + MAX( 3*N, N + M ) END IF ELSE IF( M.GE.MNTHR2 ) THEN * -* Path 5 (M much larger than N, but not as much as MNTHR1) +* Path 5 (M >> N, but not as much as MNTHR1) * - MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*N + LWORK_ZGEBRD_MN MINWRK = 2*N + M IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) ) +* Path 5o (M >> N, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + N*N ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) ) +* Path 5s (M >> N, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5a (M >> N, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MM ) END IF ELSE * -* Path 6 (M at least N, but not much larger) +* Path 6 (M >= N, but not much larger) * - MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*N + LWORK_ZGEBRD_MN MINWRK = 2*N + M IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) ) +* Path 6o (M >= N, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + N*N ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) ) +* Path 6s (M >= N, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'PRC', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+M* - $ ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6a (M >= N, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN ) END IF END IF - ELSE + ELSE IF( MINMN.GT.0 ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC -* for computing singular values and singular vectors; BDSPAN -* for computing singular values only. -* BDSPAC = 5*M*M + 7*M -* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) +* The real work space needed for bidiagonal SVD (dbdsdc) is +* BDSPAC = 3*M*M + 4*M for singular values and vectors; +* BDSPAC = 4*M for singular values only; +* not including e, RU, and RVT matrices. +* +* Compute space preferred for each routine + CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGEBRD_MN = INT( CDUM(1) ) +* + CALL ZGEBRD( M, M, CDUM(1), M, DUM(1), DUM(1), CDUM(1), + $ CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGEBRD_MM = INT( CDUM(1) ) +* + CALL ZGELQF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1, IERR ) + LWORK_ZGELQF_MN = INT( CDUM(1) ) +* + CALL ZUNGBR( 'P', M, N, M, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_P_MN = INT( CDUM(1) ) +* + CALL ZUNGBR( 'P', N, N, M, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_P_NN = INT( CDUM(1) ) +* + CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGBR_Q_MM = INT( CDUM(1) ) +* + CALL ZUNGLQ( M, N, M, CDUM(1), M, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGLQ_MN = INT( CDUM(1) ) +* + CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), + $ -1, IERR ) + LWORK_ZUNGLQ_NN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'P', 'R', 'C', M, M, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_PRC_MM = INT( CDUM(1) ) +* + CALL ZUNMBR( 'P', 'R', 'C', M, N, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_PRC_MN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'P', 'R', 'C', N, N, M, CDUM(1), N, CDUM(1), + $ CDUM(1), N, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) ) +* + CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, CDUM(1), M, CDUM(1), + $ CDUM(1), M, CDUM(1), -1, IERR ) + LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) ) * IF( N.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * - MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = M + LWORK_ZGELQF_MN + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZGEBRD_MM ) MINWRK = 3*M ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 2t (N >> M, JOBZ='O') +* + WRKBL = M + LWORK_ZGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_MN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM ) MAXWRK = M*N + M*M + WRKBL MINWRK = 2*M*M + 3*M ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 3t (N >> M, JOBZ='S') +* + WRKBL = M + LWORK_ZGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_MN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM ) MAXWRK = M*M + WRKBL MINWRK = M*M + 3*M ELSE IF( WNTQA ) THEN * -* Path 4t (N much larger than M, JOBZ='A') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) ) +* Path 4t (N >> M, JOBZ='A') +* + WRKBL = M + LWORK_ZGELQF_MN + WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_NN ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM ) + WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM ) MAXWRK = M*M + WRKBL - MINWRK = M*M + 2*M + N + MINWRK = M*M + MAX( 3*M, M + N ) END IF ELSE IF( N.GE.MNTHR2 ) THEN * -* Path 5t (N much larger than M, but not as much as MNTHR1) +* Path 5t (N >> M, but not as much as MNTHR1) * - MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*M + LWORK_ZGEBRD_MN MINWRK = 2*M + N IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5to (N >> M, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + M*M ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5ts (N >> M, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*M+N* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) +* Path 5ta (N >> M, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_NN ) END IF ELSE * -* Path 6t (N greater than M, but not much larger) +* Path 6t (N > M, but not much larger) * - MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) + MAXWRK = 2*M + LWORK_ZGEBRD_MN MINWRK = 2*M + N IF( WNTQO ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'PRC', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNMBR', 'QLN', M, M, N, -1 ) ) +* Path 6to (N > M, JOBZ='O') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN ) MAXWRK = MAXWRK + M*N MINWRK = MINWRK + M*M ELSE IF( WNTQS ) THEN - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'PRC', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6ts (N > M, JOBZ='S') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN ) ELSE IF( WNTQA ) THEN - MAXWRK = MAX( MAXWRK, 2*M+N* - $ ILAENV( 1, 'ZUNGBR', 'PRC', N, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) ) +* Path 6ta (N > M, JOBZ='A') + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM ) + MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_NN ) END IF END IF END IF @@ -554,18 +620,20 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK - IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) - $ INFO = -13 + IF( LWORK.LT.MINWRK .AND. .NOT. LQUERY ) THEN + INFO = -12 + END IF END IF -* -* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESDD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF - IF( LWORK.EQ.LQUERV ) - $ RETURN +* +* Quick return if possible +* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF @@ -598,15 +666,16 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1 (M much larger than N, JOBZ='N') +* Path 1 (M >> N, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: need 0) +* CWorkspace: need N [tau] + N [work] +* CWorkspace: prefer N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -621,8 +690,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -630,15 +700,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NRWORK = IE + N * * Perform bidiagonal SVD, compute singular values only -* (CWorkspace: 0) -* (RWorkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2 (M much larger than N, JOBZ='O') +* Path 2 (M >> N, JOBZ='O') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * @@ -648,20 +718,21 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * LDWRKU = N IR = IU + LDWRKU*N - IF( LWORK.GE.M*N+N*N+3*N ) THEN + IF( LWORK .GE. M*N + N*N + 3*N ) THEN * * WORK(IR) is M by N * LDWRKR = M ELSE - LDWRKR = ( LWORK-N*N-3*N ) / N + LDWRKR = ( LWORK - N*N - 3*N ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -673,8 +744,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LDWRKR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -684,8 +756,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -694,8 +767,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of R in WORK(IRU) and computing right singular vectors * of R in WORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = IE + N IRVT = IRU + N*N @@ -706,8 +779,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by the left singular vectors of R -* (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ), $ LDWRKU ) @@ -717,8 +791,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by the right singular vectors of R -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR, @@ -727,8 +802,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in WORK(IR) and copying to A -* (CWorkspace: need 2*N*N, prefer N*N+M*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N*N [R] +* CWorkspace: prefer N*N [U] + M*N [R] +* RWorkspace: need 0 * DO 10 I = 1, M, LDWRKR CHUNK = MIN( M-I+1, LDWRKR ) @@ -741,7 +817,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3 (M much larger than N, JOBZ='S') +* Path 3 (M >> N, JOBZ='S') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -754,8 +830,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -767,8 +844,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LDWRKR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + N [tau] + N [work] +* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -778,8 +856,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -788,8 +867,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = IE + N IRVT = IRU + N*N @@ -800,8 +879,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, @@ -810,8 +890,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR, @@ -820,8 +901,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U -* (CWorkspace: need N*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [R] +* RWorkspace: need 0 * CALL ZLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ), @@ -829,7 +910,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 4 (M much larger than N, JOBZ='A') +* Path 4 (M >> N, JOBZ='A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * @@ -842,16 +923,18 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + N * * Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N [tau] + N [work] +* CWorkspace: prefer N*N [U] + N [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (CWorkspace: need N+M, prefer N+M*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + N [tau] + M [work] +* CWorkspace: prefer N*N [U] + N [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -866,8 +949,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + 2*N*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -879,8 +963,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -888,8 +972,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by left singular vectors of R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ), $ LDWRKU ) @@ -899,8 +984,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of R -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] + 2*N [tauq, taup] + N [work] +* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -909,8 +995,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A -* (CWorkspace: need N*N) -* (RWorkspace: 0) +* CWorkspace: need N*N [U] +* RWorkspace: need 0 * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, WORK( IU ), $ LDWRKU, CZERO, A, LDA ) @@ -925,7 +1011,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * MNTHR2 <= M < MNTHR1 * -* Path 5 (M much larger than N, but not as much as MNTHR1) +* Path 5 (M >> N, but not as much as MNTHR1) * Reduce to bidiagonal form without QR decomposition, use * ZUNGBR and matrix multiplication to compute singular vectors * @@ -936,19 +1022,21 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 5n (M >> N, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK @@ -956,22 +1044,25 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, IRVT = IRU + N*N NRWORK = IRVT + N*N * +* Path 5o (M >> N, JOBZ='O') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * * WORK( IU ) is M by N * @@ -980,15 +1071,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK(IU) is LDWRKU by N * - LDWRKU = ( LWORK-3*N ) / N + LDWRKU = ( LWORK - 3*N ) / N END IF NWORK = IU + LDWRKU*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -996,8 +1087,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in WORK(IU), copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, $ WORK( IU ), LDWRKU, RWORK( NRWORK ) ) @@ -1005,8 +1096,10 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need N*N, prefer M*N) -* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] +* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork] +* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT DO 20 I = 1, M, LDWRKU @@ -1019,17 +1112,20 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * +* Path 5s (M >> N, JOBZ='S') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to U, generate Q -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, N, N, U, LDU, WORK( ITAUQ ), @@ -1038,8 +1134,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1050,8 +1146,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) @@ -1059,8 +1155,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need N*N+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA, @@ -1068,17 +1164,20 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) ELSE * +* Path 5a (M >> N, JOBZ='A') * Copy A to VT, generate P**H -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to U, generate Q -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), @@ -1087,8 +1186,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1099,8 +1198,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork] * CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) @@ -1108,8 +1207,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: 0) -* (Rworkspace: need 3*N*N) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA, @@ -1121,7 +1220,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * M .LT. MNTHR2 * -* Path 6 (M at least N, but not much larger) +* Path 6 (M >= N, but not much larger) * Reduce to bidiagonal form without QR decomposition * Use ZUNMBR to compute singular vectors * @@ -1132,26 +1231,28 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + N * * Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: need N) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need N [e] * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 6n (M >= N, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need N [e] + BDSPAC * - CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK IRU = NRWORK IRVT = IRU + N*N NRWORK = IRVT + N*N - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * * WORK( IU ) is M by N * @@ -1160,15 +1261,16 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK( IU ) is LDWRKU by N * - LDWRKU = ( LWORK-3*N ) / N + LDWRKU = ( LWORK - 3*N ) / N END IF NWORK = IU + LDWRKU*N * +* Path 6o (M >= N, JOBZ='O') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ), $ N, RWORK( IRVT ), N, DUM, IDUM, @@ -1176,21 +1278,24 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N ) THEN + IF( LWORK .GE. M*N + 3*N ) THEN * -* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) -* Overwrite WORK(IU) by left singular vectors of A, copying -* to A -* (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB) -* (Rworkspace: need 0) +* Path 6o-fast +* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) +* Overwrite WORK(IU) by left singular vectors of A, copying +* to A +* CWorkspace: need 2*N [tauq, taup] + M*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] * CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IU ), $ LDWRKU ) @@ -1202,17 +1307,21 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, CALL ZLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) ELSE * +* Path 6o-slow * Generate Q in A -* (Cworkspace: need 2*N, prefer N+N*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work] +* RWorkspace: need 0 * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need N*N, prefer M*N) -* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) +* CWorkspace: need 2*N [tauq, taup] + N*N [U] +* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] +* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork] +* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here * NRWORK = IRVT DO 30 I = 1, M, LDWRKU @@ -1227,11 +1336,12 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * +* Path 6s (M >= N, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1242,8 +1352,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL ZLASET( 'F', M, N, CZERO, CZERO, U, LDU ) CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) @@ -1253,8 +1364,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -1262,11 +1374,12 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK-NWORK+1, IERR ) ELSE * +* Path 6a (M >= N, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC * IRU = NRWORK IRVT = IRU + N*N @@ -1285,8 +1398,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + M [work] +* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -1295,8 +1409,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need 2*N [tauq, taup] + N [work] +* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work] +* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] * CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA, @@ -1316,15 +1431,16 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * -* Path 1t (N much larger than M, JOBZ='N') +* Path 1t (N >> M, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M [tau] + M [work] +* CWorkspace: prefer M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1339,8 +1455,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1348,15 +1465,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NRWORK = IE + M * * Perform bidiagonal SVD, compute singular values only -* (CWorkspace: 0) -* (RWorkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * -* Path 2t (N much larger than M, JOBZ='O') +* Path 2t (N >> M, JOBZ='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * @@ -1366,7 +1483,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * WORK(IVT) is M by M * IL = IVT + LDWKVT*M - IF( LWORK.GE.M*N+M*M+3*M ) THEN + IF( LWORK .GE. M*N + M*M + 3*M ) THEN * * WORK(IL) M by N * @@ -1377,14 +1494,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * WORK(IL) is M by CHUNK * LDWRKL = M - CHUNK = ( LWORK-M*M-3*M ) / M + CHUNK = ( LWORK - M*M - 3*M ) / M END IF ITAU = IL + LDWRKL*CHUNK NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1396,8 +1514,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ WORK( IL+LDWRKL ), LDWRKL ) * * Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1407,8 +1526,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -1417,8 +1537,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1429,8 +1549,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix WORK(IU) * Overwrite WORK(IU) by the left singular vectors of L -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, @@ -1439,8 +1560,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) * Overwrite WORK(IVT) by the right singular vectors of L -* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1450,8 +1572,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply right singular vectors of L in WORK(IL) by Q * in A, storing result in WORK(IL) and copying to A -* (CWorkspace: need 2*M*M, prefer M*M+M*N)) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M*M [L] +* CWorkspace: prefer M*M [VT] + M*N [L] +* RWorkspace: need 0 * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) @@ -1464,9 +1587,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQS ) THEN * -* Path 3t (N much larger than M, JOBZ='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U +* Path 3t (N >> M, JOBZ='S') +* M right singular vectors to be computed in VT and +* M left singular vectors to be computed in U * IL = 1 * @@ -1477,8 +1600,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) @@ -1490,8 +1614,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ WORK( IL+LDWRKL ), LDWRKL ) * * Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + M [tau] + M [work] +* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1501,8 +1626,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), @@ -1511,8 +1637,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1523,8 +1649,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, @@ -1533,8 +1660,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by left singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL, @@ -1543,8 +1671,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy VT to WORK(IL), multiply right singular vectors of L * in WORK(IL) by Q in A, storing result in VT -* (CWorkspace: need M*M) -* (RWorkspace: 0) +* CWorkspace: need M*M [L] +* RWorkspace: need 0 * CALL ZLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL, @@ -1552,7 +1680,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * ELSE IF( WNTQA ) THEN * -* Path 9t (N much larger than M, JOBZ='A') +* Path 4t (N >> M, JOBZ='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * @@ -1565,16 +1693,18 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAU + M * * Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M [tau] + M [work] +* CWorkspace: prefer M*M [VT] + M [tau] + M*NB [work] +* RWorkspace: need 0 * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (CWorkspace: need M+N, prefer M+N*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + M [tau] + N [work] +* CWorkspace: prefer M*M [VT] + M [tau] + N*NB [work] +* RWorkspace: need 0 * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1589,8 +1719,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize L in A -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + 2*M*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1599,8 +1730,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RU] + M*M [RVT] + BDSPAC * IRU = IE + M IRVT = IRU + M*M @@ -1611,8 +1742,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of L -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, A, LDA, @@ -1621,8 +1753,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) * Overwrite WORK(IVT) by right singular vectors of L -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] + 2*M [tauq, taup] + M [work] +* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1632,8 +1765,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply right singular vectors of L in WORK(IVT) by * Q in VT, storing result in A -* (CWorkspace: need M*M) -* (RWorkspace: 0) +* CWorkspace: need M*M [VT] +* RWorkspace: need 0 * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), LDWKVT, $ VT, LDVT, CZERO, A, LDA ) @@ -1648,10 +1781,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * MNTHR2 <= N < MNTHR1 * -* Path 5t (N much larger than M, but not as much as MNTHR1) +* Path 5t (N >> M, but not as much as MNTHR1) * Reduce to bidiagonal form without QR decomposition, use * ZUNGBR and matrix multiplication to compute singular vectors -* * IE = 1 NRWORK = IE + M @@ -1660,8 +1792,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, @@ -1669,11 +1802,12 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * IF( WNTQN ) THEN * +* Path 5tn (N >> M, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IRVT = NRWORK @@ -1681,23 +1815,26 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NRWORK = IRU + M*M IVT = NWORK * +* Path 5to (N >> M, JOBZ='O') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Generate P**H in A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * LDWKVT = M - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * * WORK( IVT ) is M by N * @@ -1707,15 +1844,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK( IVT ) is M by CHUNK * - CHUNK = ( LWORK-3*M ) / M + CHUNK = ( LWORK - 3*M ) / M NWORK = IVT + LDWKVT*CHUNK END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ), $ M, RWORK( IRVT ), M, DUM, IDUM, @@ -1723,8 +1860,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by real matrix RWORK(IRVT) * storing the result in WORK(IVT), copying to U -* (Cworkspace: need 0) -* (Rworkspace: need 2*M*M) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ), $ LDWKVT, RWORK( NRWORK ) ) @@ -1732,8 +1869,10 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply RWORK(IRVT) by P**H in A, storing the * result in WORK(IVT), copying to A -* (CWorkspace: need M*M, prefer M*N) -* (Rworkspace: need 2*M*M, prefer 2*M*N) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] +* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork] +* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU DO 50 I = 1, N, CHUNK @@ -1745,17 +1884,20 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, 50 CONTINUE ELSE IF( WNTQS ) THEN * +* Path 5ts (N >> M, JOBZ='S') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to VT, generate P**H -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', M, N, M, VT, LDVT, WORK( ITAUP ), @@ -1764,8 +1906,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1776,8 +1918,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need 3*M*M) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA, $ RWORK( NRWORK ) ) @@ -1785,8 +1927,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need M*M+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA, @@ -1794,17 +1936,20 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) ELSE * +* Path 5ta (N >> M, JOBZ='A') * Copy A to U, generate Q -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Copy A to VT, generate P**H -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: 0) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work] +* RWorkspace: need 0 * CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', N, N, M, VT, LDVT, WORK( ITAUP ), @@ -1813,8 +1958,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1825,8 +1970,8 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply Q in U by real matrix RWORK(IRU), storing the * result in A, copying to U -* (CWorkspace: need 0) -* (Rworkspace: need 3*M*M) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork] * CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA, $ RWORK( NRWORK ) ) @@ -1834,9 +1979,10 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Multiply real matrix RWORK(IRVT) by P**H in VT, * storing the result in A, copying to VT -* (Cworkspace: need 0) -* (Rworkspace: need M*M+2*M*N) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * + NRWORK = IRU CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA, $ RWORK( NRWORK ) ) CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) @@ -1846,7 +1992,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * N .LT. MNTHR2 * -* Path 6t (N greater than M, but not much larger) +* Path 6t (N > M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * Use ZUNMBR to compute singular vectors * @@ -1857,24 +2003,27 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, NWORK = ITAUP + M * * Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work] +* RWorkspace: need M [e] * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * +* Path 6tn (N > M, JOBZ='N') * Compute singular values only -* (Cworkspace: 0) -* (Rworkspace: need BDSPAN) +* CWorkspace: need 0 +* RWorkspace: need M [e] + BDSPAC * - CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, + CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN +* Path 6to (N > M, JOBZ='O') LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * * WORK( IVT ) is M by N * @@ -1885,15 +2034,15 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * WORK( IVT ) is M by CHUNK * - CHUNK = ( LWORK-3*M ) / M + CHUNK = ( LWORK - 3*M ) / M NWORK = IVT + LDWKVT*CHUNK END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1904,21 +2053,24 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*M ) THEN + IF( LWORK .GE. M*N + 3*M ) THEN * -* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) -* Overwrite WORK(IVT) by right singular vectors of A, -* copying to A -* (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB) -* (Rworkspace: need 0) +* Path 6to-fast +* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) +* Overwrite WORK(IVT) by right singular vectors of A, +* copying to A +* CWorkspace: need 2*M [tauq, taup] + M*N [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ), $ LDWKVT ) @@ -1928,17 +2080,21 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, CALL ZLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) ELSE * +* Path 6to-slow * Generate P**H in A -* (Cworkspace: need 2*M, prefer M+M*NB) -* (Rworkspace: need 0) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work] +* RWorkspace: need 0 * CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * * Multiply Q in A by real matrix RWORK(IRU), storing the * result in WORK(IU), copying to A -* (CWorkspace: need M*M, prefer M*N) -* (Rworkspace: need 3*M*M, prefer M*M+2*M*N) +* CWorkspace: need 2*M [tauq, taup] + M*M [VT] +* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] +* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork] +* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here * NRWORK = IRU DO 60 I = 1, N, CHUNK @@ -1952,11 +2108,12 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, END IF ELSE IF( WNTQS ) THEN * +* Path 6ts (N > M, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -1967,8 +2124,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -1977,8 +2135,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL ZLASET( 'F', M, N, CZERO, CZERO, VT, LDVT ) CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) @@ -1987,11 +2146,12 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK-NWORK+1, IERR ) ELSE * +* Path 6ta (N > M, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in RWORK(IRU) and computing right * singular vectors of bidiagonal matrix in RWORK(IRVT) -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) +* CWorkspace: need 0 +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC * IRVT = NRWORK IRU = IRVT + M*M @@ -2003,8 +2163,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRU) to complex matrix U * Overwrite U by left singular vectors of A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + M [work] +* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work] +* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] * CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU ) CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA, @@ -2017,8 +2178,9 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, * * Copy real matrix RWORK(IRVT) to complex matrix VT * Overwrite VT by right singular vectors of A -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: M*M) +* CWorkspace: need 2*M [tauq, taup] + N [work] +* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work] +* RWorkspace: need M [e] + M*M [RVT] * CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT ) CALL ZUNMBR( 'P', 'R', 'C', N, N, M, A, LDA, diff --git a/lapack-netlib/SRC/zgesv.f b/lapack-netlib/SRC/zgesv.f index e6df7958ee..316965ac71 100644 --- a/lapack-netlib/SRC/zgesv.f +++ b/lapack-netlib/SRC/zgesv.f @@ -1,25 +1,25 @@ -*> \brief ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) +*> \brief ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,22 +110,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEsolve * * ===================================================================== SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zgesvd.f b/lapack-netlib/SRC/zgesvd.f index 966e02273f..b4dbf037fc 100644 --- a/lapack-netlib/SRC/zgesvd.f +++ b/lapack-netlib/SRC/zgesvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -201,20 +201,20 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * *> \ingroup complex16GEsing * * ===================================================================== - SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, + SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * April 2012 @@ -322,23 +322,23 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) * Compute space needed for ZGEQRF CALL ZGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGEQRF=CDUM(1) + LWORK_ZGEQRF = INT( CDUM(1) ) * Compute space needed for ZUNGQR CALL ZUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZUNGQR_N=CDUM(1) + LWORK_ZUNGQR_N = INT( CDUM(1) ) CALL ZUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZUNGQR_M=CDUM(1) + LWORK_ZUNGQR_M = INT( CDUM(1) ) * Compute space needed for ZGEBRD CALL ZGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGEBRD=CDUM(1) + LWORK_ZGEBRD = INT( CDUM(1) ) * Compute space needed for ZUNGBR CALL ZUNGBR( 'P', N, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_P=CDUM(1) + LWORK_ZUNGBR_P = INT( CDUM(1) ) CALL ZUNGBR( 'Q', N, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_Q=CDUM(1) + LWORK_ZUNGBR_Q = INT( CDUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN @@ -445,24 +445,24 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGEBRD=CDUM(1) + LWORK_ZGEBRD = INT( CDUM(1) ) MAXWRK = 2*N + LWORK_ZGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL ZUNGBR( 'Q', M, N, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_Q=CDUM(1) + LWORK_ZUNGBR_Q = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q ) END IF IF( WNTUA ) THEN CALL ZUNGBR( 'Q', M, M, N, A, LDA, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_Q=CDUM(1) + LWORK_ZUNGBR_Q = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q ) END IF IF( .NOT.WNTVN ) THEN MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P ) - MINWRK = 2*N + M END IF + MINWRK = 2*N + M END IF ELSE IF( MINMN.GT.0 ) THEN * @@ -471,25 +471,25 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) * Compute space needed for ZGELQF CALL ZGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGELQF=CDUM(1) + LWORK_ZGELQF = INT( CDUM(1) ) * Compute space needed for ZUNGLQ CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1, $ IERR ) - LWORK_ZUNGLQ_N=CDUM(1) + LWORK_ZUNGLQ_N = INT( CDUM(1) ) CALL ZUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZUNGLQ_M=CDUM(1) + LWORK_ZUNGLQ_M = INT( CDUM(1) ) * Compute space needed for ZGEBRD CALL ZGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGEBRD=CDUM(1) + LWORK_ZGEBRD = INT( CDUM(1) ) * Compute space needed for ZUNGBR P CALL ZUNGBR( 'P', M, M, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_P=CDUM(1) + LWORK_ZUNGBR_P = INT( CDUM(1) ) * Compute space needed for ZUNGBR Q CALL ZUNGBR( 'Q', M, M, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_Q=CDUM(1) + LWORK_ZUNGBR_Q = INT( CDUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * @@ -595,25 +595,25 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1), $ CDUM(1), CDUM(1), -1, IERR ) - LWORK_ZGEBRD=CDUM(1) + LWORK_ZGEBRD = INT( CDUM(1) ) MAXWRK = 2*M + LWORK_ZGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for ZUNGBR P CALL ZUNGBR( 'P', M, N, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_P=CDUM(1) + LWORK_ZUNGBR_P = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P ) END IF IF( WNTVA ) THEN CALL ZUNGBR( 'P', N, N, M, A, N, CDUM(1), $ CDUM(1), -1, IERR ) - LWORK_ZUNGBR_P=CDUM(1) + LWORK_ZUNGBR_P = INT( CDUM(1) ) MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P ) END IF IF( .NOT.WNTUN ) THEN MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q ) - MINWRK = 2*M + N END IF + MINWRK = 2*M + N END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) @@ -680,8 +680,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R * - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), - $ LDA ) + IF( N .GT. 1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), + $ LDA ) + END IF IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N @@ -1144,8 +1146,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1321,8 +1325,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1649,8 +1655,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) @@ -1830,8 +1838,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, * * Zero out below R in A * - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) + IF( N .GT. 1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ A( 2, 1 ), LDA ) + END IF * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) diff --git a/lapack-netlib/SRC/zgesvdx.f b/lapack-netlib/SRC/zgesvdx.f index 6f7d5ba04d..1643b109eb 100644 --- a/lapack-netlib/SRC/zgesvdx.f +++ b/lapack-netlib/SRC/zgesvdx.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESVDX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESVDX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, -* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, +* SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, +* $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, * $ LWORK, RWORK, IWORK, INFO ) -* +* * * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT, RANGE @@ -31,33 +31,36 @@ * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION S( * ), RWORK( * ) -* COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), +* COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. * * -* Purpose -* ======= -* -* ZGESVDX computes the singular value decomposition (SVD) of a complex -* M-by-N matrix A, optionally computing the left and/or right singular -* vectors. The SVD is written -* -* A = U * SIGMA * transpose(V) -* -* where SIGMA is an M-by-N matrix which is zero except for its -* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and -* V is an N-by-N unitary matrix. The diagonal elements of SIGMA -* are the singular values of A; they are real and non-negative, and -* are returned in descending order. The first min(m,n) columns of -* U and V are the left and right singular vectors of A. -* -* ZGESVDX uses an eigenvalue problem for obtaining the SVD, which -* allows for the computation of a subset of singular values and -* vectors. See DBDSVDX for details. -* -* Note that the routine returns V**T, not V. -* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGESVDX computes the singular value decomposition (SVD) of a complex +*> M-by-N matrix A, optionally computing the left and/or right singular +*> vectors. The SVD is written +*> +*> A = U * SIGMA * transpose(V) +*> +*> where SIGMA is an M-by-N matrix which is zero except for its +*> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and +*> V is an N-by-N unitary matrix. The diagonal elements of SIGMA +*> are the singular values of A; they are real and non-negative, and +*> are returned in descending order. The first min(m,n) columns of +*> U and V are the left and right singular vectors of A. +*> +*> ZGESVDX uses an eigenvalue problem for obtaining the SVD, which +*> allows for the computation of a subset of singular values and +*> vectors. See DBDSVDX for details. +*> +*> Note that the routine returns V**T, not V. +*> \endverbatim +* * Arguments: * ========== * @@ -66,7 +69,7 @@ *> JOBU is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'V': the first min(m,n) columns of U (the left singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array U; *> = 'N': no columns of U (no left singular vectors) are *> computed. @@ -78,7 +81,7 @@ *> Specifies options for computing all or part of the matrix *> V**T: *> = 'V': the first min(m,n) rows of V**T (the right singular -*> vectors) or as specified by RANGE are returned in +*> vectors) or as specified by RANGE are returned in *> the array VT; *> = 'N': no rows of V**T (no right singular vectors) are *> computed. @@ -90,7 +93,7 @@ *> = 'A': all singular values will be found. *> = 'V': all singular values in the half-open interval (VL,VU] *> will be found. -*> = 'I': the IL-th through IU-th singular values will be found. +*> = 'I': the IL-th through IU-th singular values will be found. *> \endverbatim *> *> \param[in] M @@ -107,7 +110,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is COMPLEX array, dimension (LDA,N) +*> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, the contents of A are destroyed. *> \endverbatim @@ -121,13 +124,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION -*> VL >=0. +*> If RANGE='V', the lower bound of the interval to +*> be searched for singular values. VU > VL. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for singular values. VU > VL. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -135,13 +140,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest singular value to be returned. +*> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest singular values to be returned. +*> If RANGE='I', the index of the +*> largest singular value to be returned. *> 1 <= IL <= IU <= min(M,N), if min(M,N) > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -149,7 +158,7 @@ *> \param[out] NS *> \verbatim *> NS is INTEGER -*> The total number of singular values found, +*> The total number of singular values found, *> 0 <= NS <= min(M,N). *> If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1. *> \endverbatim @@ -163,11 +172,11 @@ *> \param[out] U *> \verbatim *> U is COMPLEX*16 array, dimension (LDU,UCOL) -*> If JOBU = 'V', U contains columns of U (the left singular -*> vectors, stored columnwise) as specified by RANGE; if +*> If JOBU = 'V', U contains columns of U (the left singular +*> vectors, stored columnwise) as specified by RANGE; if *> JOBU = 'N', U is not referenced. -*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', -*> the exact value of NS is not known ILQFin advance and an upper +*> Note: The user must ensure that UCOL >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -181,11 +190,11 @@ *> \param[out] VT *> \verbatim *> VT is COMPLEX*16 array, dimension (LDVT,N) -*> If JOBVT = 'V', VT contains the rows of V**T (the right singular -*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', +*> If JOBVT = 'V', VT contains the rows of V**T (the right singular +*> vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N', *> VT is not referenced. -*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', -*> the exact value of NS is not known in advance and an upper +*> Note: The user must ensure that LDVT >= NS; if RANGE = 'V', +*> the exact value of NS is not known in advance and an upper *> bound must be used. *> \endverbatim *> @@ -206,9 +215,9 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see +*> LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see *> comments inside the code): -*> - PATH 1 (M much larger than N) +*> - PATH 1 (M much larger than N) *> - PATH 1t (N much larger than M) *> LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths. *> For good performance, LWORK should generally be larger. @@ -228,8 +237,8 @@ *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (12*MIN(M,N)) -*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, -*> then IWORK contains the indices of the eigenvectors that failed +*> If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0, +*> then IWORK contains the indices of the eigenvectors that failed *> to converge in DBDSVDX/DSTEVX. *> \endverbatim *> @@ -247,24 +256,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16GEsing * * ===================================================================== - SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, - $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, + SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, + $ IL, IU, NS, S, U, LDU, VT, LDVT, WORK, $ LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT, RANGE @@ -274,7 +283,7 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION S( * ), RWORK( * ) - COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), + COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), $ WORK( * ) * .. * @@ -291,8 +300,8 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, CHARACTER JOBZ, RNGTGK LOGICAL ALLS, INDS, LQUERY, VALS, WANTU, WANTVT INTEGER I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL, - $ ITAU, ITAUP, ITAUQ, ITEMP, ITGKZ, IUTGK, - $ J, K, MAXWRK, MINMN, MINWRK, MNTHR + $ ITAU, ITAUP, ITAUQ, ITEMP, ITEMPR, ITGKZ, + $ IUTGK, J, K, MAXWRK, MINMN, MINWRK, MNTHR DOUBLE PRECISION ABSTOL, ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. @@ -364,8 +373,14 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( INFO.EQ.0 ) THEN IF( WANTU .AND. LDU.LT.M ) THEN INFO = -15 - ELSE IF( WANTVT .AND. LDVT.LT.MINMN ) THEN - INFO = -16 + ELSE IF( WANTVT ) THEN + IF( INDS ) THEN + IF( LDVT.LT.IU-IL+1 ) THEN + INFO = -17 + END IF + ELSE IF( LDVT.LT.MINMN ) THEN + INFO = -17 + END IF END IF END IF END IF @@ -387,18 +402,24 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1 (M much larger than N) * - MAXWRK = N + N* - $ ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, N*N + N + 2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - MINWRK = N*(N+4) + MINWRK = N*(N+5) + MAXWRK = N + N*ILAENV(1,'ZGEQRF',' ',M,N,-1,-1) + MAXWRK = MAX(MAXWRK, + $ N*N+2*N+2*N*ILAENV(1,'ZGEBRD',' ',N,N,-1,-1)) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ N*N+2*N+N*ILAENV(1,'ZUNMQR','LN',N,N,N,-1)) + END IF ELSE * * Path 2 (M at least N, but not much larger) * - MAXWRK = 2*N + ( M+N )* - $ ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) - MINWRK = 2*N + M + MINWRK = 3*N + M + MAXWRK = 2*N + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ 2*N+N*ILAENV(1,'ZUNMQR','LN',N,N,N,-1)) + END IF END IF ELSE MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) @@ -406,18 +427,25 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Path 1t (N much larger than M) * - MAXWRK = M + M* - $ ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M + M + 2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - MINWRK = M*(M+4) + MINWRK = M*(M+5) + MAXWRK = M + M*ILAENV(1,'ZGELQF',' ',M,N,-1,-1) + MAXWRK = MAX(MAXWRK, + $ M*M+2*M+2*M*ILAENV(1,'ZGEBRD',' ',M,M,-1,-1)) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ M*M+2*M+M*ILAENV(1,'ZUNMQR','LN',M,M,M,-1)) + END IF ELSE * * Path 2t (N greater than M, but not much larger) * - MAXWRK = M*(M*2+19) + ( M+N )* - $ ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) - MINWRK = 2*M + N +* + MINWRK = 3*M + N + MAXWRK = 2*M + (M+N)*ILAENV(1,'ZGEBRD',' ',M,N,-1,-1) + IF (WANTU .OR. WANTVT) THEN + MAXWRK = MAX(MAXWRK, + $ 2*M+M*ILAENV(1,'ZUNMQR','LN',M,M,M,-1)) + END IF END IF END IF END IF @@ -444,8 +472,6 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * * Set singular values indices accord to RANGE='A'. * - ALLS = LSAME( RANGE, 'A' ) - INDS = LSAME( RANGE, 'I' ) IF( ALLS ) THEN RNGTGK = 'I' ILTGK = 1 @@ -454,7 +480,7 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, RNGTGK = 'I' ILTGK = IL IUTGK = IU - ELSE + ELSE RNGTGK = 'V' ILTGK = 0 IUTGK = 0 @@ -498,31 +524,31 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, ITEMP = ITAU + N CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) -* +* * Copy R into WORK and bidiagonalize it: * (Workspace: need N*N+3*N, prefer N*N+N+2*N*NB) -* +* IQRF = ITEMP ITAUQ = ITEMP + N*N ITAUP = ITAUQ + N ITEMP = ITAUP + N - ID = 1 + ID = 1 IE = ID + N ITGKZ = IE + N CALL ZLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IQRF+1 ), N ) - CALL ZGEBRD( N, N, WORK( IQRF ), N, RWORK( ID ), + CALL ZGEBRD( N, N, WORK( IQRF ), N, RWORK( ID ), $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), $ WORK( ITEMP ), LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + N*(N*2+1) + ITEMPR = ITGKZ + N*(N*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*N*N+14*N) -* +* (Workspace: need 2*N*N+14*N) +* CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ), $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), N*2, RWORK( ITEMP ), + $ RWORK( ITGKZ ), N*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -536,23 +562,23 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + N END DO - CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U( N+1,1 ), LDU ) + CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) * * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL ZUNMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL ZUNMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call ZUNMQR to compute Q*(QB*UB). * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL ZUNMQR( 'L', 'N', M, NS, N, A, LDA, + CALL ZUNMQR( 'L', 'N', M, NS, N, A, LDA, $ WORK( ITAU ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -568,7 +594,7 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call ZUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL ZUNMBR( 'P', 'R', 'C', NS, N, N, WORK( IQRF ), N, + CALL ZUNMBR( 'P', 'R', 'C', NS, N, N, WORK( IQRF ), N, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) END IF @@ -584,21 +610,21 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * ITAUQ = 1 ITAUP = ITAUQ + N - ITEMP = ITAUP + N + ITEMP = ITAUP + N ID = 1 IE = ID + N ITGKZ = IE + N - CALL ZGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), + CALL ZGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + N*(N*2+1) + ITEMPR = ITGKZ + N*(N*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*N*N+14*N) -* +* (Workspace: need 2*N*N+14*N) +* CALL DBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), N*2, RWORK( ITEMP ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), N*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -606,22 +632,22 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( WANTU ) THEN K = ITGKZ DO I = 1, NS - DO J = 1, N + DO J = 1, N U( J, I ) = DCMPLX( RWORK( K ), ZERO ) K = K + 1 END DO K = K + N END DO - CALL ZLASET( 'A', M-N, N, CZERO, CZERO, U( N+1,1 ), LDU ) + CALL ZLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU) * * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need N, prefer N*NB) -* - CALL ZUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), +* + CALL ZUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -637,11 +663,11 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call ZUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need N, prefer N*NB) * - CALL ZUNMBR( 'P', 'R', 'C', NS, N, N, A, LDA, + CALL ZUNMBR( 'P', 'R', 'C', NS, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, IERR ) END IF - END IF + END IF ELSE * * A has more columns than rows. If A has sufficiently more @@ -650,7 +676,7 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IF( N.GE.MNTHR ) THEN * * Path 1t (N much larger than M): -* A = L * Q = ( QB * B * PB**T ) * Q +* A = L * Q = ( QB * B * PB**T ) * Q * = ( QB * ( UB * S * VB**T ) * PB**T ) * Q * U = QB * UB ; V**T = VB**T * PB**T * Q * @@ -665,7 +691,7 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Copy L into WORK and bidiagonalize it: * (Workspace in WORK( ITEMP ): need M*M+3*M, prefer M*M+M+2*M*NB) * - ILQF = ITEMP + ILQF = ITEMP ITAUQ = ILQF + M*M ITAUP = ITAUQ + M ITEMP = ITAUP + M @@ -673,19 +699,19 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IE = ID + M ITGKZ = IE + M CALL ZLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( ILQF+M ), M ) CALL ZGEBRD( M, M, WORK( ILQF ), M, RWORK( ID ), - $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), + $ RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ), $ WORK( ITEMP ), LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + M*(M*2+1) + ITEMPR = ITGKZ + M*(M*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) +* (Workspace: need 2*M*M+14*M) * CALL DBDSVDX( 'U', JOBZ, RNGTGK, M, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), M*2, RWORK( ITEMP ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), M*2, RWORK( ITEMPR ), $ IWORK, INFO) * * If needed, compute left singular vectors. @@ -703,11 +729,11 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL ZUNMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL ZUNMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -719,52 +745,52 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + M END DO - CALL ZLASET( 'A', M, N-M, CZERO, CZERO, + CALL ZLASET( 'A', NS, N-M, CZERO, CZERO, $ VT( 1,M+1 ), LDVT ) * * Call ZUNMBR to compute (VB**T)*(PB**T) * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL ZUNMBR( 'P', 'R', 'C', NS, M, M, WORK( ILQF ), M, + CALL ZUNMBR( 'P', 'R', 'C', NS, M, M, WORK( ILQF ), M, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) * * Call ZUNMLQ to compute ((VB**T)*(PB**T))*Q. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL ZUNMLQ( 'R', 'N', NS, N, M, A, LDA, + CALL ZUNMLQ( 'R', 'N', NS, N, M, A, LDA, $ WORK( ITAU ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF ELSE * * Path 2t (N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T -* U = QB * UB; V**T = VB**T * PB**T +* U = QB * UB; V**T = VB**T * PB**T * * Bidiagonalize A * (Workspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* +* ITAUQ = 1 ITAUP = ITAUQ + M ITEMP = ITAUP + M ID = 1 IE = ID + M ITGKZ = IE + M - CALL ZGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), + CALL ZGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - ITEMP = ITGKZ + M*(M*2+1) + ITEMPR = ITGKZ + M*(M*2+1) * * Solve eigenvalue problem TGK*Z=Z*S. -* (Workspace: need 2*M*M+14*M) -* - CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, RWORK( ID ), - $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, - $ RWORK( ITGKZ ), M*2, RWORK( ITEMP ), +* (Workspace: need 2*M*M+14*M) +* + CALL DBDSVDX( 'L', JOBZ, RNGTGK, M, RWORK( ID ), + $ RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S, + $ RWORK( ITGKZ ), M*2, RWORK( ITEMPR ), $ IWORK, INFO) -* +* * If needed, compute left singular vectors. * IF( WANTU ) THEN @@ -780,11 +806,11 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, * Call ZUNMBR to compute QB*UB. * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL ZUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), + CALL ZUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA, + $ WORK( ITAUQ ), U, LDU, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF -* + END IF +* * If needed, compute right singular vectors. * IF( WANTVT) THEN @@ -796,16 +822,16 @@ SUBROUTINE ZGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, END DO K = K + M END DO - CALL ZLASET( 'A', M, N-M, CZERO, CZERO, + CALL ZLASET( 'A', NS, N-M, CZERO, CZERO, $ VT( 1,M+1 ), LDVT ) * * Call ZUNMBR to compute VB**T * PB**T * (Workspace in WORK( ITEMP ): need M, prefer M*NB) * - CALL ZUNMBR( 'P', 'R', 'C', NS, N, M, A, LDA, + CALL ZUNMBR( 'P', 'R', 'C', NS, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( ITEMP ), $ LWORK-ITEMP+1, INFO ) - END IF + END IF END IF END IF * diff --git a/lapack-netlib/SRC/zgesvj.f b/lapack-netlib/SRC/zgesvj.f index 930a353095..d08cfa5552 100644 --- a/lapack-netlib/SRC/zgesvj.f +++ b/lapack-netlib/SRC/zgesvj.f @@ -1,26 +1,26 @@ -*> \brief \b ZGESVJ +*> \brief ZGESVJ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESVJ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESVJ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, LRWORK, M, MV, N * CHARACTER*1 JOBA, JOBU, JOBV @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), V( LDV, * ), CWORK( LWORK ) * DOUBLE PRECISION RWORK( LRWORK ), SVA( N ) * .. -* +* * *> \par Purpose: * ============= @@ -64,11 +64,11 @@ *> JOBU is CHARACTER*1 *> Specifies whether to compute the left singular vectors *> (columns of U): -*> = 'U': The left singular vectors corresponding to the nonzero +*> = 'U' or 'F': The left singular vectors corresponding to the nonzero *> singular values are computed and returned in the leading *> columns of A. See more details in the description of A. *> The default numerical orthogonality threshold is set to -*> approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E'). +*> approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=DLAMCH('E'). *> = 'C': Analogous to JOBU='U', except that user can control the *> level of numerical orthogonality of the computed left *> singular vectors. TOL can be set to TOL = CTOL*EPS, where @@ -88,10 +88,10 @@ *> JOBV is CHARACTER*1 *> Specifies whether to compute the right singular vectors, that *> is, the matrix V: -*> = 'V' : the matrix V is computed and returned in the array V +*> = 'V' or 'J': the matrix V is computed and returned in the array V *> = 'A' : the Jacobi rotations are applied to the MV-by-N *> array V. In other words, the right singular vector -*> matrix V is not computed explicitly, instead it is +*> matrix V is not computed explicitly; instead it is *> applied to an MV-by-N matrix initially stored in the *> first MV rows of V. *> = 'N' : the matrix V is not computed and the array V is not @@ -101,7 +101,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. +*> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. *> \endverbatim *> *> \param[in] N @@ -206,8 +206,11 @@ *> *> \param[in,out] CWORK *> \verbatim -*> CWORK is COMPLEX*16 array, dimension M+N. -*> Used as work space. +*> CWORK is COMPLEX*16 array, dimension max(1,LWORK). +*> Used as workspace. +*> If on entry LWORK .EQ. -1, then a workspace query is assumed and +*> no computation is done; CWORK(1) is set to the minial (and optimal) +*> length of CWORK. *> \endverbatim *> *> \param[in] LWORK @@ -218,7 +221,7 @@ *> *> \param[in,out] RWORK *> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension max(6,M+N). +*> RWORK is DOUBLE PRECISION array, dimension max(6,LRWORK). *> On entry, *> If JOBU .EQ. 'C' : *> RWORK(1) = CTOL, where CTOL defines the threshold for convergence. @@ -244,11 +247,14 @@ *> RWORK(6) = the largest absolute value over all sines of the *> Jacobi rotation angles in the last sweep. It can be *> useful for a post festum analysis. +*> If on entry LRWORK .EQ. -1, then a workspace query is assumed and +*> no computation is done; RWORK(1) is set to the minial (and optimal) +*> length of RWORK. *> \endverbatim *> *> \param[in] LRWORK *> \verbatim -*> LRWORK is INTEGER +*> LRWORK is INTEGER *> Length of RWORK, LRWORK >= MAX(6,N). *> \endverbatim *> @@ -257,22 +263,22 @@ *> INFO is INTEGER *> = 0 : successful exit. *> < 0 : if INFO = -i, then the i-th argument had an illegal value -*> > 0 : ZGESVJ did not converge in the maximal allowed number -*> (NSWEEP=30) of sweeps. The output may still be useful. +*> > 0 : ZGESVJ did not converge in the maximal allowed number +*> (NSWEEP=30) of sweeps. The output may still be useful. *> See the description of RWORK. *> \endverbatim *> * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * -*> \ingroup doubleGEcomputational +*> \ingroup complex16GEcomputational * *> \par Further Details: * ===================== @@ -291,29 +297,30 @@ *> procedure is achieved if used in an accelerated version of Drmac and *> Veselic [4,5], and it is the kernel routine in the SIGMA library [6]. *> Some tunning parameters (marked with [TP]) are available for the -*> implementer. +*> implementer. *> The computational range for the nonzero singular values is the machine *> number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even *> denormalized singular values can be computed with the corresponding *> gradual loss of accurate digits. *> \endverbatim * -*> \par Contributors: +*> \par Contributor: * ================== *> *> \verbatim *> *> ============ *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> Zlatko Drmac (Zagreb, Croatia) +*> *> \endverbatim * *> \par References: * ================ *> *> [1] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the -*> singular value decomposition on a vector computer. -*> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. +*> singular value decomposition on a vector computer. +*> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. *> [2] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. *> [3] Z. Drmac: Implementation of Jacobi rotations for accurate singular *> value computation in floating point arithmetic. @@ -329,8 +336,8 @@ *> Department of Mathematics, University of Zagreb, 2008, 2015. *> \endverbatim * -*> \par Bugs, examples and comments: -* ================================= +*> \par Bugs, examples and comments: +* ================================= *> *> \verbatim *> =========================== @@ -339,15 +346,15 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, + SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, CWORK, LWORK, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * - IMPLICIT NONE + IMPLICIT NONE * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, LRWORK, M, MV, N CHARACTER*1 JOBA, JOBU, JOBV @@ -369,20 +376,19 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * .. * .. Local Scalars .. COMPLEX*16 AAPQ, OMPQ - DOUBLE PRECISION AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, - $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, - $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, - $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, THSIGN, TOL + DOUBLE PRECISION AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, + $ BIGTHETA, CS, CTOL, EPSLN, MXAAPQ, + $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, + $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, THSIGN, TOL INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, - $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, + $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND - LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, + LOGICAL APPLV, GOSCALE, LOWER, LQUERY, LSVEC, NOSCALE, ROTOK, $ RSVEC, UCTOL, UPPER * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DMAX1, DMIN1, DCONJG, DFLOAT, MIN0, MAX0, - $ DSIGN, DSQRT + INTRINSIC ABS, MAX, MIN, CONJG, DBLE, SIGN, SQRT * .. * .. External Functions .. * .. @@ -403,20 +409,21 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * from BLAS EXTERNAL ZCOPY, ZROT, ZDSCAL, ZSWAP * from LAPACK - EXTERNAL ZLASCL, ZLASET, ZLASSQ, XERBLA + EXTERNAL DLASCL, ZLASCL, ZLASET, ZLASSQ, XERBLA EXTERNAL ZGSVJ0, ZGSVJ1 * .. * .. Executable Statements .. * * Test the input arguments * - LSVEC = LSAME( JOBU, 'U' ) + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) UCTOL = LSAME( JOBU, 'C' ) - RSVEC = LSAME( JOBV, 'V' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'J' ) APPLV = LSAME( JOBV, 'A' ) UPPER = LSAME( JOBA, 'U' ) LOWER = LSAME( JOBA, 'L' ) * + LQUERY = ( LWORK .EQ. -1 ) .OR. ( LRWORK .EQ. -1 ) IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN @@ -436,10 +443,10 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, INFO = -11 ELSE IF( UCTOL .AND. ( RWORK( 1 ).LE.ONE ) ) THEN INFO = -12 - ELSE IF( LWORK.LT.( M+N ) ) THEN + ELSE IF( ( LWORK.LT.( M+N ) ) .AND. ( .NOT.LQUERY ) ) THEN INFO = -13 - ELSE IF( LRWORK.LT.MAX0( N, 6 ) ) THEN - INFO = -15 + ELSE IF( ( LRWORK.LT.MAX( N, 6 ) ) .AND. ( .NOT.LQUERY ) ) THEN + INFO = -15 ELSE INFO = 0 END IF @@ -448,6 +455,10 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVJ', -INFO ) RETURN + ELSE IF ( LQUERY ) THEN + CWORK(1) = M + N + RWORK(1) = MAX( N, 6 ) + RETURN END IF * * #:) Quick return for void matrix @@ -467,29 +478,29 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN - CTOL = DSQRT( DFLOAT( M ) ) + CTOL = SQRT( DBLE( M ) ) ELSE - CTOL = DFLOAT( M ) + CTOL = DBLE( M ) END IF END IF * ... and the machine dependent parameters are -*[!] (Make sure that DLAMCH() works properly on the target machine.) +*[!] (Make sure that SLAMCH() works properly on the target machine.) * EPSLN = DLAMCH( 'Epsilon' ) - ROOTEPS = DSQRT( EPSLN ) + ROOTEPS = SQRT( EPSLN ) SFMIN = DLAMCH( 'SafeMinimum' ) - ROOTSFMIN = DSQRT( SFMIN ) + ROOTSFMIN = SQRT( SFMIN ) SMALL = SFMIN / EPSLN BIG = DLAMCH( 'Overflow' ) * BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN - LARGE = BIG / DSQRT( DFLOAT( M*N ) ) +* LARGE = BIG / SQRT( DBLE( M*N ) ) BIGTHETA = ONE / ROOTEPS * TOL = CTOL*EPSLN - ROOTTOL = DSQRT( TOL ) + ROOTTOL = SQRT( TOL ) * - IF( DFLOAT( M )*EPSLN.GE.ONE ) THEN + IF( DBLE( M )*EPSLN.GE.ONE ) THEN INFO = -4 CALL XERBLA( 'ZGESVJ', -INFO ) RETURN @@ -514,7 +525,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries * in A are detected, the procedure returns with INFO=-6. * - SKL = ONE / DSQRT( DFLOAT( M )*DFLOAT( N ) ) + SKL = ONE / SQRT( DBLE( M )*DBLE( N ) ) NOSCALE = .TRUE. GOSCALE = .TRUE. * @@ -529,7 +540,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL XERBLA( 'ZGESVJ', -INFO ) RETURN END IF - AAQQ = DSQRT( AAQQ ) + AAQQ = SQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE @@ -554,7 +565,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL XERBLA( 'ZGESVJ', -INFO ) RETURN END IF - AAQQ = DSQRT( AAQQ ) + AAQQ = SQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE @@ -579,7 +590,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL XERBLA( 'ZGESVJ', -INFO ) RETURN END IF - AAQQ = DSQRT( AAQQ ) + AAQQ = SQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE @@ -604,8 +615,8 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = ZERO AAQQ = BIG DO 4781 p = 1, N - IF( SVA( p ).NE.ZERO )AAQQ = DMIN1( AAQQ, SVA( p ) ) - AAPP = DMAX1( AAPP, SVA( p ) ) + IF( SVA( p ).NE.ZERO )AAQQ = MIN( AAQQ, SVA( p ) ) + AAPP = MAX( AAPP, SVA( p ) ) 4781 CONTINUE * * #:) Quick return for zero matrix @@ -642,23 +653,23 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * Protect small singular values from underflow, and try to * avoid underflows/overflows in computing Jacobi rotations. * - SN = DSQRT( SFMIN / EPSLN ) - TEMP1 = DSQRT( BIG / DFLOAT( N ) ) - IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. + SN = SQRT( SFMIN / EPSLN ) + TEMP1 = SQRT( BIG / DBLE( N ) ) + IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. $ ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN - TEMP1 = DMIN1( BIG, TEMP1 / AAPP ) + TEMP1 = MIN( BIG, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN - TEMP1 = DMIN1( SN / AAQQ, BIG / (AAPP*DSQRT( DFLOAT(N)) ) ) + TEMP1 = MIN( SN / AAQQ, BIG / (AAPP*SQRT( DBLE(N)) ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN - TEMP1 = DMAX1( SN / AAQQ, TEMP1 / AAPP ) + TEMP1 = MAX( SN / AAQQ, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN - TEMP1 = DMIN1( SN / AAQQ, BIG / ( DSQRT( DFLOAT( N ) )*AAPP ) ) + TEMP1 = MIN( SN / AAQQ, BIG / ( SQRT( DBLE( N ) )*AAPP ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE @@ -668,7 +679,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * Scale, if necessary * IF( TEMP1.NE.ONE ) THEN - CALL ZLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) + CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) END IF SKL = TEMP1*SKL IF( SKL.NE.ONE ) THEN @@ -680,10 +691,10 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * EMPTSW = ( N*( N-1 ) ) / 2 NOTROT = 0 - + DO 1868 q = 1, N CWORK( q ) = CONE - 1868 CONTINUE + 1868 CONTINUE * * * @@ -695,7 +706,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * The boundaries are determined dynamically, based on the number of * pivots above a threshold. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the @@ -707,7 +718,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, BLSKIP = KBL**2 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. * - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. * LKAHEAD = 1 @@ -718,7 +729,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * invokes cubic convergence. Big part of this cycle is done inside * canonical subspaces of dimensions less than M. * - IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX0( 64, 4*KBL ) ) ) THEN + IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX( 64, 4*KBL ) ) ) THEN *[TP] The number of partition levels and the actual partition are * tuning parameters. N4 = N / 4 @@ -816,18 +827,18 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * igl = ( ibr-1 )*KBL + 1 * - DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr ) + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * - DO 2001 p = igl, MIN0( igl+KBL-1, N-1 ) + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * * .. de Rijk's pivoting * q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL ZSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) - IF( RSVEC )CALL ZSWAP( MVL, V( 1, p ), 1, + IF( RSVEC )CALL ZSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) @@ -851,14 +862,14 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * If properly implemented SCNRM2 is available, the IF-THEN-ELSE-END IF * below should be replaced with "AAPP = DZNRM2( M, A(1,p), 1 )". * - IF( ( SVA( p ).LT.ROOTBIG ) .AND. + IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = DZNRM2( M, A( 1, p ), 1 ) ELSE TEMP1 = ZERO AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) - SVA( p ) = TEMP1*DSQRT( AAPP ) + SVA( p ) = TEMP1*SQRT( AAPP ) END IF AAPP = SVA( p ) ELSE @@ -869,7 +880,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * PSKIPPED = 0 * - DO 2002 q = p + 1, MIN0( igl+KBL-1, N ) + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) * @@ -879,12 +890,12 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, + AAPQ = ( ZDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE - CALL ZCOPY( M, A( 1, p ), 1, + CALL ZCOPY( M, A( 1, p ), 1, $ CWORK(N+1), 1 ) - CALL ZLASCL( 'G', 0, 0, AAPP, ONE, + CALL ZLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, CWORK(N+1), LDA, IERR ) AAPQ = ZDOTC( M, CWORK(N+1), 1, $ A( 1, q ), 1 ) / AAQQ @@ -892,10 +903,10 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( ZDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / AAPP ) / AAQQ ELSE - CALL ZCOPY( M, A( 1, q ), 1, + CALL ZCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) CALL ZLASCL( 'G', 0, 0, AAQQ, $ ONE, M, 1, @@ -905,14 +916,15 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * DCONJG( CWORK(p) ) * CWORK(q) - AAPQ1 = -ABS(AAPQ) - MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 ) + +* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) + AAPQ1 = -ABS(AAPQ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) * * .. rotate *[RTD] ROTATED = ROTATED + ONE @@ -930,47 +942,47 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, THETA = -HALF*ABS( AQOAP-APOAQ )/AAPQ1 * IF( ABS( THETA ).GT.BIGTHETA ) THEN -* +* T = HALF / THETA CS = ONE CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*T ) + $ CS, CONJG(OMPQ)*T ) IF ( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*T ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * - THSIGN = -DSIGN( ONE, AAPQ1 ) - T = ONE / ( THETA+THSIGN* - $ DSQRT( ONE+THETA*THETA ) ) - CS = DSQRT( ONE / ( ONE+T*T ) ) + THSIGN = -SIGN( ONE, AAPQ1 ) + T = ONE / ( THETA+THSIGN* + $ SQRT( ONE+THETA*THETA ) ) + CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS * - MXSINJ = DMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF ( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*SN ) - END IF - END IF - CWORK(p) = -CWORK(q) * OMPQ + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) + END IF + END IF + CWORK(p) = -CWORK(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -985,9 +997,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ A( 1, q ), 1 ) CALL ZLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * @@ -1004,7 +1016,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAQQ = ONE CALL ZLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) - SVA( q ) = T*DSQRT( AAQQ ) + SVA( q ) = T*SQRT( AAQQ ) END IF END IF IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN @@ -1016,7 +1028,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, T, $ AAPP ) - AAPP = T*DSQRT( AAPP ) + AAPP = T*SQRT( AAPP ) END IF SVA( p ) = AAPP END IF @@ -1051,7 +1063,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) - $ NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE @@ -1071,14 +1083,14 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N ) + DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -1095,7 +1107,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, + AAPQ = ( ZDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL ZCOPY( M, A( 1, p ), 1, @@ -1113,8 +1125,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( ZDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) @@ -1126,14 +1139,15 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * DCONJG(CWORK(p))*CWORK(q) + +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -1148,42 +1162,42 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*T ) + $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*T ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * - THSIGN = -DSIGN( ONE, AAPQ1 ) + THSIGN = -SIGN( ONE, AAPQ1 ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* - $ DSQRT( ONE+THETA*THETA ) ) - CS = DSQRT( ONE / ( ONE+T*T ) ) + $ SQRT( ONE+THETA*THETA ) ) + CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = DMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*SN ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF - CWORK(p) = -CWORK(q) * OMPQ + CWORK(p) = -CWORK(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -1201,9 +1215,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL ZLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ CWORK(N+1), 1 ) @@ -1213,14 +1227,14 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, CALL ZLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL ZAXPY( M, -DCONJG(AAPQ), + CALL ZAXPY( M, -CONJG(AAPQ), $ CWORK(N+1), 1, A( 1, p ), 1 ) CALL ZLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*DSQRT( DMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -1237,7 +1251,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAQQ = ONE CALL ZLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) - SVA( q ) = T*DSQRT( AAQQ ) + SVA( q ) = T*SQRT( AAQQ ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN @@ -1249,7 +1263,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, T, $ AAPP ) - AAPP = T*DSQRT( AAPP ) + AAPP = T*SQRT( AAPP ) END IF SVA( p ) = AAPP END IF @@ -1288,7 +1302,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -1299,7 +1313,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -1314,7 +1328,7 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, T = ZERO AAPP = ONE CALL ZLASSQ( M, A( 1, N ), 1, T, AAPP ) - SVA( N ) = T*DSQRT( AAPP ) + SVA( N ) = T*SQRT( AAPP ) END IF * * Additional steering devices @@ -1322,8 +1336,8 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DFLOAT( N ) )* - $ TOL ) .AND. ( DFLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( DBLE( N ) )* + $ TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * @@ -1371,8 +1385,9 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * Normalize the left singular vectors. * IF( LSVEC .OR. UCTOL ) THEN - DO 1998 p = 1, N2 - CALL ZDSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) + DO 1998 p = 1, N4 +* CALL ZDSCAL( M, ONE / SVA( p ), A( 1, p ), 1 ) + CALL ZLASCL( 'G',0,0, SVA(p), ONE, M, 1, A(1,p), M, IERR ) 1998 CONTINUE END IF * @@ -1386,11 +1401,11 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, END IF * * Undo scaling, if necessary (and possible). - IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) + IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL ) ) ) $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. $ ( SFMIN / SKL ) ) ) ) THEN DO 2400 p = 1, N - SVA( P ) = SKL*SVA( P ) + SVA( p ) = SKL*SVA( p ) 2400 CONTINUE SKL = ONE END IF @@ -1400,15 +1415,15 @@ SUBROUTINE ZGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * then some of the singular values may overflow or underflow and * the spectrum is given in this factored representation. * - RWORK( 2 ) = DFLOAT( N4 ) + RWORK( 2 ) = DBLE( N4 ) * N4 is the number of computed nonzero singular values of A. * - RWORK( 3 ) = DFLOAT( N2 ) + RWORK( 3 ) = DBLE( N2 ) * N2 is the number of singular values of A greater than SFMIN. * If N2 \htmlonly -*> Download ZGESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, * EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -336,10 +336,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -350,7 +350,7 @@ SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zgesvxx.f b/lapack-netlib/SRC/zgesvxx.f index 3ac901f609..c3727b70e3 100644 --- a/lapack-netlib/SRC/zgesvxx.f +++ b/lapack-netlib/SRC/zgesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * BERR, N_ERR_BNDS, ERR_BNDS_NORM, * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -38,7 +38,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -524,10 +524,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -540,7 +540,7 @@ SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zgetc2.f b/lapack-netlib/SRC/zgetc2.f index bf59415b5a..40e4d9150e 100644 --- a/lapack-netlib/SRC/zgetc2.f +++ b/lapack-netlib/SRC/zgetc2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGETC2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGETC2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complex16GEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/zgetf2.f b/lapack-netlib/SRC/zgetf2.f index 7013ffb17d..a98e36e2ec 100644 --- a/lapack-netlib/SRC/zgetf2.f +++ b/lapack-netlib/SRC/zgetf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -167,7 +167,7 @@ SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * * Compute machine safe minimum * - SFMIN = DLAMCH('S') + SFMIN = DLAMCH('S') * DO 10 J = 1, MIN( M, N ) * diff --git a/lapack-netlib/SRC/zgetrf.f b/lapack-netlib/SRC/zgetrf.f index fcf31e34f5..c7b07b6589 100644 --- a/lapack-netlib/SRC/zgetrf.f +++ b/lapack-netlib/SRC/zgetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff --git a/lapack-netlib/SRC/zgetrf2.f b/lapack-netlib/SRC/zgetrf2.f index 7d28b58129..44e2731efe 100644 --- a/lapack-netlib/SRC/zgetrf2.f +++ b/lapack-netlib/SRC/zgetrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -35,11 +35,11 @@ *> *> This is the recursive version of the algorithm. It divides *> the matrix into four submatrices: -*> +*> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = min(m,n) +*> A = [ -----|----- ] with n1 = min(m,n)/2 *> [ A21 | A22 ] n2 = n-n1 -*> +*> *> [ A11 ] *> The subroutine calls itself to factor [ --- ], *> [ A12 ] @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -241,12 +241,12 @@ RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) * * Solve A12 * - CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, $ A( 1, N1+1 ), LDA ) * * Update A22 * - CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) * * Factor A22 diff --git a/lapack-netlib/SRC/zgetri.f b/lapack-netlib/SRC/zgetri.f index c7ac26ef74..deff71ff5f 100644 --- a/lapack-netlib/SRC/zgetri.f +++ b/lapack-netlib/SRC/zgetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/zgetrs.f b/lapack-netlib/SRC/zgetrs.f index 6400055b40..5c0bd35f64 100644 --- a/lapack-netlib/SRC/zgetrs.f +++ b/lapack-netlib/SRC/zgetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgetsls.f b/lapack-netlib/SRC/zgetsls.f new file mode 100644 index 0000000000..40ad10e86e --- /dev/null +++ b/lapack-netlib/SRC/zgetsls.f @@ -0,0 +1,497 @@ +* Definition: +* =========== +* +* SUBROUTINE ZGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETSLS solves overdetermined or underdetermined complex linear systems +*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ +*> factorization of A. It is assumed that A has full rank. +*> +*> +*> +*> The following options are provided: +*> +*> 1. If TRANS = 'N' and m >= n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A*X ||. +*> +*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of +*> an underdetermined system A * X = B. +*> +*> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of +*> an undetermined system A**T * X = B. +*> +*> 4. If TRANS = 'C' and m < n: find the least squares solution of +*> an overdetermined system, i.e., solve the least squares problem +*> minimize || B - A**T * X ||. +*> +*> Several right hand side vectors b and solution vectors x can be +*> handled in a single call; they are stored as the columns of the +*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution +*> matrix X. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': the linear system involves A; +*> = 'C': the linear system involves A**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrices B and X. NRHS >=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, +*> A is overwritten by details of its QR or LQ +*> factorization as returned by ZGEQR or ZGELQ. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the matrix B of right hand side vectors, stored +*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS +*> if TRANS = 'C'. +*> On exit, if INFO = 0, B is overwritten by the solution +*> vectors, stored columnwise: +*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least +*> squares solution vectors. +*> if TRANS = 'N' and m < n, rows 1 to N of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'C' and m >= n, rows 1 to M of B contain the +*> minimum norm solution vectors; +*> if TRANS = 'C' and m < n, rows 1 to M of B contain the +*> least squares solution vectors. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= MAX(1,M,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) contains optimal (or either minimal +*> or optimal, if query was assumed) LWORK. +*> See LWORK for details. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If LWORK = -1 or -2, then a workspace query is assumed. +*> If LWORK = -1, the routine calculates optimal size of WORK for the +*> optimal performance and returns this value in WORK(1). +*> If LWORK = -2, the routine calculates minimal size of WORK and +*> returns this value in WORK(1). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of A is zero, so that A does not have +*> full rank; the least squares solution could not be +*> computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16GEsolve +* +* ===================================================================== + SUBROUTINE ZGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, TRAN + INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW, + $ SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2, + $ WSIZEO, WSIZEM, INFO2 + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM + COMPLEX*16 TQ( 5 ), WORKQ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, ZLANGE +* .. +* .. External Subroutines .. + EXTERNAL ZGEQR, ZGEMQR, ZLASCL, ZLASET, + $ ZTRTRS, XERBLA, ZGELQ, ZGEMLQ +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, INT +* .. +* .. Executable Statements .. +* +* Test the input arguments. +* + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNK = MAX( MINMN, NRHS ) + TRAN = LSAME( TRANS, 'C' ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 ) + IF( .NOT.( LSAME( TRANS, 'N' ) .OR. + $ LSAME( TRANS, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size and minimum LWORK +* + IF( M.GE.N ) THEN + CALL ZGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL ZGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL ZGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL ZGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ, + $ TSZM, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + ELSE + CALL ZGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 ) + TSZO = INT( TQ( 1 ) ) + LWO = INT( WORKQ ) + CALL ZGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWO = MAX( LWO, INT( WORKQ ) ) + CALL ZGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 ) + TSZM = INT( TQ( 1 ) ) + LWM = INT( WORKQ ) + CALL ZGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ, + $ TSZO, B, LDB, WORKQ, -1, INFO2 ) + LWM = MAX( LWM, INT( WORKQ ) ) + WSIZEO = TSZO + LWO + WSIZEM = TSZM + LWM + END IF +* + IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN + INFO = -10 + END IF +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETSLS', -INFO ) + WORK( 1 ) = DBLE( WSIZEO ) + RETURN + END IF + IF( LQUERY ) THEN + IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO ) + IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM ) + RETURN + END IF + IF( LWORK.LT.WSIZEO ) THEN + LW1 = TSZM + LW2 = LWM + ELSE + LW1 = TSZO + LW2 = LWO + END IF +* +* Quick return if possible +* + IF( MIN( M, N, NRHS ).EQ.0 ) THEN + CALL ZLASET( 'FULL', MAX( M, N ), NRHS, CZERO, CZERO, + $ B, LDB ) + RETURN + END IF +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* +* Scale A, B if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +* +* Matrix all zero. Return zero solution. +* + CALL ZLASET( 'F', MAXMN, NRHS, CZERO, CZERO, B, LDB ) + GO TO 50 + END IF +* + BROW = M + IF ( TRAN ) THEN + BROW = N + END IF + BNRM = ZLANGE( 'M', BROW, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +* +* Scale matrix norm up to SMLNUM +* + CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +* +* Scale matrix norm down to BIGNUM +* + CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +* + IF ( M.GE.N ) THEN +* +* compute QR factorization of A +* + CALL ZGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) + IF ( .NOT.TRAN ) THEN +* +* Least-Squares Problem min || A * X - B || +* +* B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) +* + CALL ZGEMQR( 'L' , 'C', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) +* + CALL ZTRTRS( 'U', 'N', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) + IF( INFO.GT.0 ) THEN + RETURN + END IF + SCLLEN = N + ELSE +* +* Overdetermined system of equations A**T * X = B +* +* B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) +* + CALL ZTRTRS( 'U', 'C', 'N', N, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(N+1:M,1:NRHS) = CZERO +* + DO 20 J = 1, NRHS + DO 10 I = N + 1, M + B( I, J ) = CZERO + 10 CONTINUE + 20 CONTINUE +* +* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) +* + CALL ZGEMQR( 'L', 'N', M, NRHS, N, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* + SCLLEN = M +* + END IF +* + ELSE +* +* Compute LQ factorization of A +* + CALL ZGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1, + $ WORK( 1 ), LW2, INFO ) +* +* workspace at least M, optimally M*NB. +* + IF( .NOT.TRAN ) THEN +* +* underdetermined system of equations A * X = B +* +* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) +* + CALL ZTRTRS( 'L', 'N', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* +* B(M+1:N,1:NRHS) = 0 +* + DO 40 J = 1, NRHS + DO 30 I = M + 1, N + B( I, J ) = CZERO + 30 CONTINUE + 40 CONTINUE +* +* B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS) +* + CALL ZGEMLQ( 'L', 'C', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* + SCLLEN = N +* + ELSE +* +* overdetermined system min || A**T * X - B || +* +* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) +* + CALL ZGEMLQ( 'L', 'N', N, NRHS, M, A, LDA, + $ WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2, + $ INFO ) +* +* workspace at least NRHS, optimally NRHS*NB +* +* B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS) +* + CALL ZTRTRS( 'L', 'C', 'N', M, NRHS, + $ A, LDA, B, LDB, INFO ) +* + IF( INFO.GT.0 ) THEN + RETURN + END IF +* + SCLLEN = M +* + END IF +* + END IF +* +* Undo scaling +* + IF( IASCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, + $ INFO ) + END IF +* + 50 CONTINUE + WORK( 1 ) = DBLE( TSZO + LWO ) + RETURN +* +* End of ZGETSLS +* + END diff --git a/lapack-netlib/SRC/zggbak.f b/lapack-netlib/SRC/zggbak.f index 1d8d73c787..cb10b4f8ca 100644 --- a/lapack-netlib/SRC/zggbak.f +++ b/lapack-netlib/SRC/zggbak.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGBAK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, * LDV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION LSCALE( * ), RSCALE( * ) * COMPLEX*16 V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -148,10 +148,10 @@ SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff --git a/lapack-netlib/SRC/zggbal.f b/lapack-netlib/SRC/zggbal.f index 7298da3976..beca512614 100644 --- a/lapack-netlib/SRC/zggbal.f +++ b/lapack-netlib/SRC/zggbal.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGBAL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, * RSCALE, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, LDB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,7 +140,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (lwork) +*> WORK is DOUBLE PRECISION array, dimension (lwork) *> lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and *> at least 1 when JOB = 'N' or 'P'. *> \endverbatim @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16GBcomputational * @@ -177,10 +177,10 @@ SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/SRC/zgges.f b/lapack-netlib/SRC/zgges.f index 6432a71dd6..555abcd86e 100644 --- a/lapack-netlib/SRC/zgges.f +++ b/lapack-netlib/SRC/zgges.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGES + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGES + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, * SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM @@ -37,7 +37,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -256,12 +256,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16GEeigen * @@ -270,10 +270,10 @@ SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT diff --git a/lapack-netlib/SRC/zgges3.f b/lapack-netlib/SRC/zgges3.f index 1a7dbccc7b..08557b134d 100644 --- a/lapack-netlib/SRC/zgges3.f +++ b/lapack-netlib/SRC/zgges3.f @@ -269,7 +269,7 @@ SUBROUTINE ZGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -392,8 +392,8 @@ SUBROUTINE ZGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, - $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, - $ -1, RWORK, IERR ) + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, -1, + $ RWORK, IERR ) LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) IF( WANTST ) THEN CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, diff --git a/lapack-netlib/SRC/zggesx.f b/lapack-netlib/SRC/zggesx.f index bc709ffd74..ac91384513 100644 --- a/lapack-netlib/SRC/zggesx.f +++ b/lapack-netlib/SRC/zggesx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGESX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGESX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, * LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, * IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SENSE, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, @@ -40,7 +40,7 @@ * LOGICAL SELCTG * EXTERNAL SELCTG * .. -* +* * *> \par Purpose: * ============= @@ -315,12 +315,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEeigen * @@ -330,10 +330,10 @@ SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, $ LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT diff --git a/lapack-netlib/SRC/zggev.f b/lapack-netlib/SRC/zggev.f index 6ad934d3d5..946de6c2ca 100644 --- a/lapack-netlib/SRC/zggev.f +++ b/lapack-netlib/SRC/zggev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, * VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -31,7 +31,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -204,10 +204,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -217,7 +217,7 @@ SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zggev3.f b/lapack-netlib/SRC/zggev3.f index 78337fd073..2e88adedc3 100644 --- a/lapack-netlib/SRC/zggev3.f +++ b/lapack-netlib/SRC/zggev3.f @@ -216,7 +216,7 @@ SUBROUTINE ZGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 diff --git a/lapack-netlib/SRC/zggevx.f b/lapack-netlib/SRC/zggevx.f index 922a717b32..5549feb139 100644 --- a/lapack-netlib/SRC/zggevx.f +++ b/lapack-netlib/SRC/zggevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, * LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, * WORK, LWORK, RWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N @@ -37,7 +37,7 @@ * $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -330,10 +330,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -374,7 +374,7 @@ SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, $ WORK, LWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -522,7 +522,7 @@ SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, IF( ILVL ) THEN MAXWRK = MAX( MAXWRK, N + $ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, 0 ) ) - END IF + END IF END IF WORK( 1 ) = MAXWRK * diff --git a/lapack-netlib/SRC/zggglm.f b/lapack-netlib/SRC/zggglm.f index 47f56c4a2c..d6a30cee71 100644 --- a/lapack-netlib/SRC/zggglm.f +++ b/lapack-netlib/SRC/zggglm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGGLM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGGLM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), * $ X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -185,10 +185,10 @@ SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P @@ -216,7 +216,7 @@ SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * .. * .. External Functions .. INTEGER ILAENV - EXTERNAL ILAENV + EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN diff --git a/lapack-netlib/SRC/zgghd3.f b/lapack-netlib/SRC/zgghd3.f index 9d6e36285c..94ae93b98b 100644 --- a/lapack-netlib/SRC/zgghd3.f +++ b/lapack-netlib/SRC/zgghd3.f @@ -227,7 +227,7 @@ SUBROUTINE ZGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 @@ -277,7 +277,7 @@ SUBROUTINE ZGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * INFO = 0 NB = ILAENV( 1, 'ZGGHD3', ' ', N, ILO, IHI, -1 ) - LWKOPT = 6*N*NB + LWKOPT = MAX( 6*N*NB, 1 ) WORK( 1 ) = DCMPLX( LWKOPT ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) diff --git a/lapack-netlib/SRC/zgghrd.f b/lapack-netlib/SRC/zgghrd.f index 58ac1918e1..e9e870320d 100644 --- a/lapack-netlib/SRC/zgghrd.f +++ b/lapack-netlib/SRC/zgghrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGHRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ * INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -181,12 +181,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -204,10 +204,10 @@ SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ diff --git a/lapack-netlib/SRC/zgglse.f b/lapack-netlib/SRC/zgglse.f index 084654620b..1b5f468bce 100644 --- a/lapack-netlib/SRC/zgglse.f +++ b/lapack-netlib/SRC/zgglse.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGLSE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGLSE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( * ), D( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsolve * @@ -180,10 +180,10 @@ SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/zggqrf.f b/lapack-netlib/SRC/zggqrf.f index 3685570410..ba04d07603 100644 --- a/lapack-netlib/SRC/zggqrf.f +++ b/lapack-netlib/SRC/zggqrf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGQRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -215,10 +215,10 @@ SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/zggrqf.f b/lapack-netlib/SRC/zggrqf.f index 8bb41e9deb..27970e8336 100644 --- a/lapack-netlib/SRC/zggrqf.f +++ b/lapack-netlib/SRC/zggrqf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGRQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGRQF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -214,10 +214,10 @@ SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/SRC/zggsvd3.f b/lapack-netlib/SRC/zggsvd3.f index d478d2922e..fd22d4f197 100644 --- a/lapack-netlib/SRC/zggsvd3.f +++ b/lapack-netlib/SRC/zggsvd3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGSVD3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGSVD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * LWORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -327,14 +327,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * -*> \ingroup complex16OTHERsing +*> \ingroup complex16GEsing * *> \par Contributors: * ================== @@ -353,7 +353,7 @@ SUBROUTINE ZGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * August 2015 @@ -383,7 +383,7 @@ SUBROUTINE ZGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, EXTERNAL LSAME, DLAMCH, ZLANGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, XERBLA, ZGGSVP, ZTGSJA + EXTERNAL DCOPY, XERBLA, ZGGSVP3, ZTGSJA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN diff --git a/lapack-netlib/SRC/zggsvp3.f b/lapack-netlib/SRC/zggsvp3.f index b397651ccc..986bc47bbe 100644 --- a/lapack-netlib/SRC/zggsvp3.f +++ b/lapack-netlib/SRC/zggsvp3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGGSVP3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGGSVP3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, * IWORK, RWORK, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular *> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, *> otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective -*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. +*> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine @@ -251,10 +251,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -278,7 +278,7 @@ SUBROUTINE ZGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * August 2015 @@ -308,7 +308,6 @@ SUBROUTINE ZGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, * .. Local Scalars .. LOGICAL FORWRD, WANTQ, WANTU, WANTV, LQUERY INTEGER I, J, LWKOPT - COMPLEX*16 T * .. * .. External Functions .. LOGICAL LSAME diff --git a/lapack-netlib/SRC/zgsvj0.f b/lapack-netlib/SRC/zgsvj0.f index a9e663d4bf..ea2b542229 100644 --- a/lapack-netlib/SRC/zgsvj0.f +++ b/lapack-netlib/SRC/zgsvj0.f @@ -1,26 +1,26 @@ -*> \brief \b ZGSVJ0 pre-processor for the routine dgesvj. +*> \brief ZGSVJ0 pre-processor for the routine zgesvj. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGSVJ0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP * DOUBLE PRECISION EPS, SFMIN, TOL @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) * DOUBLE PRECISION SVA( N ) * .. -* +* * *> \par Purpose: * ============= @@ -112,6 +112,7 @@ *> the matrix A*diag(D). *> On exit, SVA contains the Euclidean norms of the columns of *> the matrix A_onexit*diag(D_onexit). +*> \endverbatim *> *> \param[in] MV *> \verbatim @@ -187,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational *> @@ -202,12 +203,12 @@ *> ZGSVJ0 is used just to enable ZGESVJ to call a simplified version of *> itself to work on a submatrix of the original matrix. *> -*> Contributors: +*> Contributor: * ============= *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> Zlatko Drmac (Zagreb, Croatia) *> -*> Bugs, Examples and Comments: +*> \par Bugs, Examples and Comments: * ============================ *> *> Please report all bugs and send interesting test examples and comments to @@ -217,10 +218,10 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * IMPLICIT NONE * .. Scalar Arguments .. @@ -230,7 +231,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) - DOUBLE PRECISION SVA( N ) + DOUBLE PRECISION SVA( N ) * .. * * ===================================================================== @@ -254,7 +255,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DMAX1, DCONJG, DFLOAT, MIN0, DSIGN, DSQRT + INTRINSIC ABS, MAX, CONJG, DBLE, MIN, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 @@ -287,7 +288,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, INFO = -5 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN @@ -313,13 +314,13 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, END IF RSVEC = RSVEC .OR. APPLV - ROOTEPS = DSQRT( EPS ) - ROOTSFMIN = DSQRT( SFMIN ) + ROOTEPS = SQRT( EPS ) + ROOTSFMIN = SQRT( SFMIN ) SMALL = SFMIN / EPS BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN BIGTHETA = ONE / ROOTEPS - ROOTTOL = DSQRT( TOL ) + ROOTTOL = SQRT( TOL ) * * .. Row-cyclic Jacobi SVD algorithm with column pivoting .. * @@ -337,7 +338,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * The boundaries are determined dynamically, based on the number of * pivots above a threshold. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the @@ -349,7 +350,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, BLSKIP = KBL**2 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. * - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. * LKAHEAD = 1 @@ -383,18 +384,18 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * igl = ( ibr-1 )*KBL + 1 * - DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr ) + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * - DO 2001 p = igl, MIN0( igl+KBL-1, N-1 ) + DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * * .. de Rijk's pivoting * q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL ZSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) - IF( RSVEC )CALL ZSWAP( MVL, V( 1, p ), 1, + IF( RSVEC )CALL ZSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) @@ -418,14 +419,14 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * If properly implemented DZNRM2 is available, the IF-THEN-ELSE-END IF * below should be replaced with "AAPP = DZNRM2( M, A(1,p), 1 )". * - IF( ( SVA( p ).LT.ROOTBIG ) .AND. + IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = DZNRM2( M, A( 1, p ), 1 ) ELSE TEMP1 = ZERO AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) - SVA( p ) = TEMP1*DSQRT( AAPP ) + SVA( p ) = TEMP1*SQRT( AAPP ) END IF AAPP = SVA( p ) ELSE @@ -436,7 +437,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * PSKIPPED = 0 * - DO 2002 q = p + 1, MIN0( igl+KBL-1, N ) + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) * @@ -446,12 +447,12 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, + AAPQ = ( ZDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE - CALL ZCOPY( M, A( 1, p ), 1, + CALL ZCOPY( M, A( 1, p ), 1, $ WORK, 1 ) - CALL ZLASCL( 'G', 0, 0, AAPP, ONE, + CALL ZLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, WORK, LDA, IERR ) AAPQ = ZDOTC( M, WORK, 1, $ A( 1, q ), 1 ) / AAQQ @@ -459,27 +460,27 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( ZDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / AAPP ) / AAQQ ELSE - CALL ZCOPY( M, A( 1, q ), 1, + CALL ZCOPY( M, A( 1, q ), 1, $ WORK, 1 ) CALL ZLASCL( 'G', 0, 0, AAQQ, $ ONE, M, 1, $ WORK, LDA, IERR ) - AAPQ = ZDOTC( M, A( 1, p ), 1, + AAPQ = ZDOTC( M, A( 1, p ), 1, $ WORK, 1 ) / AAPP END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * DCONJG( CWORK(p) ) * CWORK(q) - AAPQ1 = -ABS(AAPQ) - MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 ) +* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q) + AAPQ1 = -ABS(AAPQ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) * * .. rotate *[RTD] ROTATED = ROTATED + ONE @@ -497,47 +498,47 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, THETA = -HALF*ABS( AQOAP-APOAQ )/AAPQ1 * IF( ABS( THETA ).GT.BIGTHETA ) THEN -* +* T = HALF / THETA CS = ONE CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*T ) + $ CS, CONJG(OMPQ)*T ) IF ( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*T ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * - THSIGN = -DSIGN( ONE, AAPQ1 ) - T = ONE / ( THETA+THSIGN* - $ DSQRT( ONE+THETA*THETA ) ) - CS = DSQRT( ONE / ( ONE+T*T ) ) + THSIGN = -SIGN( ONE, AAPQ1 ) + T = ONE / ( THETA+THSIGN* + $ SQRT( ONE+THETA*THETA ) ) + CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS * - MXSINJ = DMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF ( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*SN ) - END IF - END IF - D(p) = -D(q) * OMPQ + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) + END IF + END IF + D(p) = -D(q) * OMPQ * ELSE * .. have to use modified Gram-Schmidt like transformation @@ -552,9 +553,9 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ A( 1, q ), 1 ) CALL ZLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * @@ -571,7 +572,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, AAQQ = ONE CALL ZLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) - SVA( q ) = T*DSQRT( AAQQ ) + SVA( q ) = T*SQRT( AAQQ ) END IF END IF IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN @@ -583,7 +584,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, T, $ AAPP ) - AAPP = T*DSQRT( AAPP ) + AAPP = T*SQRT( AAPP ) END IF SVA( p ) = AAPP END IF @@ -618,7 +619,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) - $ NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE @@ -638,14 +639,14 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N ) + DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -662,7 +663,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, + AAPQ = ( ZDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL ZCOPY( M, A( 1, p ), 1, @@ -680,8 +681,9 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( ZDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -693,14 +695,14 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * DCONJG(CWORK(p))*CWORK(q) +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -715,39 +717,39 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*T ) + $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*T ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * - THSIGN = -DSIGN( ONE, AAPQ1 ) + THSIGN = -SIGN( ONE, AAPQ1 ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* - $ DSQRT( ONE+THETA*THETA ) ) - CS = DSQRT( ONE / ( ONE+T*T ) ) + $ SQRT( ONE+THETA*THETA ) ) + CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = DMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*SN ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF D(p) = -D(q) * OMPQ @@ -768,9 +770,9 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, CALL ZLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -780,14 +782,14 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, CALL ZLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL ZAXPY( M, -DCONJG(AAPQ), + CALL ZAXPY( M, -CONJG(AAPQ), $ WORK, 1, A( 1, p ), 1 ) CALL ZLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*DSQRT( DMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -804,7 +806,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, AAQQ = ONE CALL ZLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) - SVA( q ) = T*DSQRT( AAQQ ) + SVA( q ) = T*SQRT( AAQQ ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN @@ -816,7 +818,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, T, $ AAPP ) - AAPP = T*DSQRT( AAPP ) + AAPP = T*SQRT( AAPP ) END IF SVA( p ) = AAPP END IF @@ -855,7 +857,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -866,7 +868,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -881,7 +883,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, T = ZERO AAPP = ONE CALL ZLASSQ( M, A( 1, N ), 1, T, AAPP ) - SVA( N ) = T*DSQRT( AAPP ) + SVA( N ) = T*SQRT( AAPP ) END IF * * Additional steering devices @@ -889,8 +891,8 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DFLOAT( N ) )* - $ TOL ) .AND. ( DFLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( DBLE( N ) )* + $ TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * @@ -909,7 +911,7 @@ SUBROUTINE ZGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * INFO = 0 * #:) INFO = 0 confirms successful iterations. - 1995 CONTINUE + 1995 CONTINUE * * Sort the vector SVA() of column norms. DO 5991 p = 1, N - 1 diff --git a/lapack-netlib/SRC/zgsvj1.f b/lapack-netlib/SRC/zgsvj1.f index 54410cc0fa..aba6ea2376 100644 --- a/lapack-netlib/SRC/zgsvj1.f +++ b/lapack-netlib/SRC/zgsvj1.f @@ -1,36 +1,36 @@ -*> \brief \b ZGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivots. +*> \brief \b ZGSVJ1 pre-processor for the routine zgesvj, applies Jacobi rotations targeting only particular pivots. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGSVJ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGSVJ1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION EPS, SFMIN, TOL * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP * CHARACTER*1 JOBV * .. * .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) -* DOUBLE PRECISION SVA( N ) +* COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) +* DOUBLE PRECISION SVA( N ) * .. -* +* * *> \par Purpose: * ============= @@ -105,7 +105,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, M-by-N matrix A, such that A*diag(D) represents *> the input matrix. *> On exit, @@ -124,7 +124,7 @@ *> *> \param[in,out] D *> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) +*> D is COMPLEX*16 array, dimension (N) *> The array D accumulates the scaling factors from the fast scaled *> Jacobi rotations. *> On entry, A*diag(D) represents the input matrix. @@ -154,7 +154,7 @@ *> *> \param[in,out] V *> \verbatim -*> V is DOUBLE PRECISION array, dimension (LDV,N) +*> V is COMPLEX*16 array, dimension (LDV,N) *> If JOBV .EQ. 'V' then N rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a @@ -199,7 +199,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> WORK is COMPLEX*16 array, dimension (LWORK) *> \endverbatim *> *> \param[in] LWORK @@ -218,30 +218,30 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * -*> \par Contributors: +*> \par Contributor: * ================== *> -*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> Zlatko Drmac (Zagreb, Croatia) * * ===================================================================== SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * - IMPLICIT NONE + IMPLICIT NONE * .. Scalar Arguments .. DOUBLE PRECISION EPS, SFMIN, TOL INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP @@ -249,7 +249,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK ) - DOUBLE PRECISION SVA( N ) + DOUBLE PRECISION SVA( N ) * .. * * ===================================================================== @@ -261,7 +261,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. Local Scalars .. COMPLEX*16 AAPQ, OMPQ DOUBLE PRECISION AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG, - $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, + $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T, $ TEMP1, THETA, THSIGN INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, @@ -271,7 +271,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * .. * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, DMAX1, DFLOAT, MIN0, DSIGN, DSQRT + INTRINSIC ABS, CONJG, MAX, DBLE, MIN, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DZNRM2 @@ -281,7 +281,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EXTERNAL IDAMAX, LSAME, ZDOTC, DZNRM2 * .. * .. External Subroutines .. -* .. from BLAS +* .. from BLAS EXTERNAL ZCOPY, ZROT, ZSWAP * .. from LAPACK EXTERNAL ZLASCL, ZLASSQ, XERBLA @@ -304,7 +304,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, INFO = -6 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -9 - ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( TOL.LE.EPS ) THEN @@ -330,14 +330,14 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, END IF RSVEC = RSVEC .OR. APPLV - ROOTEPS = DSQRT( EPS ) - ROOTSFMIN = DSQRT( SFMIN ) + ROOTEPS = SQRT( EPS ) + ROOTSFMIN = SQRT( SFMIN ) SMALL = SFMIN / EPS BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN - LARGE = BIG / DSQRT( DFLOAT( M*N ) ) +* LARGE = BIG / SQRT( DBLE( M*N ) ) BIGTHETA = ONE / ROOTEPS - ROOTTOL = DSQRT( TOL ) + ROOTTOL = SQRT( TOL ) * * .. Initialize the right singular vector matrix .. * @@ -348,7 +348,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * * .. Row-cyclic pivot strategy with de Rijk's pivoting .. * - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) NBLR = N1 / KBL IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1 @@ -359,7 +359,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, BLSKIP = ( KBL**2 ) + 1 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. SWBAND = 0 *[TP] SWBAND is a tuning parameter. It is meaningful and effective @@ -402,21 +402,21 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, igl = ( ibr-1 )*KBL + 1 * * DO 2010 jbc = ibr + 1, NBL - DO 2010 jbc = 1, NBLC + DO 2010 jbc = 1, NBLC * jgl = ( jbc-1 )*KBL + N1 + 1 * * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N1 ) + DO 2100 p = igl, MIN( igl+KBL-1, N1 ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN @@ -433,7 +433,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, + AAPQ = ( ZDOTC( M, A( 1, p ), 1, $ A( 1, q ), 1 ) / AAQQ ) / AAPP ELSE CALL ZCOPY( M, A( 1, p ), 1, @@ -451,8 +451,9 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN - AAPQ = ( ZDOTC( M, A( 1, p ), 1, - $ A( 1, q ), 1 ) / AAQQ ) / AAPP + AAPQ = ( ZDOTC( M, A( 1, p ), 1, + $ A( 1, q ), 1 ) / MAX(AAQQ,AAPP) ) + $ / MIN(AAQQ,AAPP) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -464,14 +465,14 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, END IF END IF * - OMPQ = AAPQ / ABS(AAPQ) -* AAPQ = AAPQ * DCONJG(CWORK(p))*CWORK(q) +* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q) AAPQ1 = -ABS(AAPQ) - MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 ) + MXAAPQ = MAX( MXAAPQ, -AAPQ1 ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( ABS( AAPQ1 ).GT.TOL ) THEN + OMPQ = AAPQ / ABS(AAPQ) NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 @@ -486,39 +487,39 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * IF( ABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA - CS = ONE + CS = ONE CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*T ) + $ CS, CONJG(OMPQ)*T ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*T ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*T ) END IF - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, ABS( T ) ) + MXSINJ = MAX( MXSINJ, ABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * - THSIGN = -DSIGN( ONE, AAPQ1 ) + THSIGN = -SIGN( ONE, AAPQ1 ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* - $ DSQRT( ONE+THETA*THETA ) ) - CS = DSQRT( ONE / ( ONE+T*T ) ) + $ SQRT( ONE+THETA*THETA ) ) + CS = SQRT( ONE / ( ONE+T*T ) ) SN = T*CS - MXSINJ = DMAX1( MXSINJ, ABS( SN ) ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + MXSINJ = MAX( MXSINJ, ABS( SN ) ) + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ1 ) ) - AAPP = AAPP*DSQRT( DMAX1( ZERO, + AAPP = AAPP*SQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ1 ) ) * CALL ZROT( M, A(1,p), 1, A(1,q), 1, - $ CS, DCONJG(OMPQ)*SN ) + $ CS, CONJG(OMPQ)*SN ) IF( RSVEC ) THEN - CALL ZROT( MVL, V(1,p), 1, - $ V(1,q), 1, CS, DCONJG(OMPQ)*SN ) + CALL ZROT( MVL, V(1,p), 1, + $ V(1,q), 1, CS, CONJG(OMPQ)*SN ) END IF END IF D(p) = -D(q) * OMPQ @@ -539,9 +540,9 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, CALL ZLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) - SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO, + SVA( q ) = AAQQ*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL ZCOPY( M, A( 1, q ), 1, $ WORK, 1 ) @@ -551,14 +552,14 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, CALL ZLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) - CALL ZAXPY( M, -DCONJG(AAPQ), + CALL ZAXPY( M, -CONJG(AAPQ), $ WORK, 1, A( 1, p ), 1 ) CALL ZLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) - SVA( p ) = AAPP*DSQRT( DMAX1( ZERO, + SVA( p ) = AAPP*SQRT( MAX( ZERO, $ ONE-AAPQ1*AAPQ1 ) ) - MXSINJ = DMAX1( MXSINJ, SFMIN ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -575,7 +576,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, AAQQ = ONE CALL ZLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) - SVA( q ) = T*DSQRT( AAQQ ) + SVA( q ) = T*SQRT( AAQQ ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN @@ -587,7 +588,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, AAPP = ONE CALL ZLASSQ( M, A( 1, p ), 1, T, $ AAPP ) - AAPP = T*DSQRT( AAPP ) + AAPP = T*SQRT( AAPP ) END IF SVA( p ) = AAPP END IF @@ -626,7 +627,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - $ MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF @@ -637,7 +638,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = ABS( SVA( p ) ) 2012 CONTINUE *** @@ -652,7 +653,7 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, T = ZERO AAPP = ONE CALL ZLASSQ( M, A( 1, N ), 1, T, AAPP ) - SVA( N ) = T*DSQRT( AAPP ) + SVA( N ) = T*SQRT( AAPP ) END IF * * Additional steering devices @@ -660,8 +661,8 @@ SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * - IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DFLOAT( N ) )* - $ TOL ) .AND. ( DFLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( DBLE( N ) )* + $ TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * diff --git a/lapack-netlib/SRC/zgtcon.f b/lapack-netlib/SRC/zgtcon.f index b8cac22adf..efa6a2c8d7 100644 --- a/lapack-netlib/SRC/zgtcon.f +++ b/lapack-netlib/SRC/zgtcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTcomputational * @@ -141,10 +141,10 @@ SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zgtrfs.f b/lapack-netlib/SRC/zgtrfs.f index f0a0359c81..fedaaee540 100644 --- a/lapack-netlib/SRC/zgtrfs.f +++ b/lapack-netlib/SRC/zgtrfs.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -33,7 +33,7 @@ * $ DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTcomputational * @@ -210,10 +210,10 @@ SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgtsv.f b/lapack-netlib/SRC/zgtsv.f index 8611ce6cba..96ef9db771 100644 --- a/lapack-netlib/SRC/zgtsv.f +++ b/lapack-netlib/SRC/zgtsv.f @@ -1,32 +1,32 @@ -*> \brief ZGTSV computes the solution to system of linear equations A * X = B for GT matrices +*> \brief ZGTSV computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTsolve * * ===================================================================== SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zgtsvx.f b/lapack-netlib/SRC/zgtsvx.f index 59b25e4cd3..0b245520ff 100644 --- a/lapack-netlib/SRC/zgtsvx.f +++ b/lapack-netlib/SRC/zgtsvx.f @@ -1,19 +1,19 @@ -*> \brief ZGTSVX computes the solution to system of linear equations A * X = B for GT matrices +*> \brief ZGTSVX computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, * DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, TRANS * INTEGER INFO, LDB, LDX, N, NRHS @@ -34,7 +34,7 @@ * $ DLF( * ), DU( * ), DU2( * ), DUF( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -280,12 +280,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTsolve * @@ -294,10 +294,10 @@ SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT, TRANS diff --git a/lapack-netlib/SRC/zgttrf.f b/lapack-netlib/SRC/zgttrf.f index 8ccc654ead..0d4c48dd7f 100644 --- a/lapack-netlib/SRC/zgttrf.f +++ b/lapack-netlib/SRC/zgttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTcomputational * * ===================================================================== SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/zgttrs.f b/lapack-netlib/SRC/zgttrs.f index 421efca357..f37c35a679 100644 --- a/lapack-netlib/SRC/zgttrs.f +++ b/lapack-netlib/SRC/zgttrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTcomputational * @@ -138,10 +138,10 @@ SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zgtts2.f b/lapack-netlib/SRC/zgtts2.f index 5f9eb4aad9..c8c1797c12 100644 --- a/lapack-netlib/SRC/zgtts2.f +++ b/lapack-netlib/SRC/zgtts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZGTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZGTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER ITRANS, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GTcomputational * * ===================================================================== SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ITRANS, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zhb2st_kernels.f b/lapack-netlib/SRC/zhb2st_kernels.f new file mode 100644 index 0000000000..e4114b5f4d --- /dev/null +++ b/lapack-netlib/SRC/zhb2st_kernels.f @@ -0,0 +1,335 @@ +*> \brief \b ZHB2ST_KERNELS +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHB2ST_KERNELS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHB2ST_KERNELS( UPLO, WANTZ, TTYPE, +* ST, ED, SWEEP, N, NB, IB, +* A, LDA, V, TAU, LDVT, WORK) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* LOGICAL WANTZ +* INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), V( * ), +* TAU( * ), WORK( * ) +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHB2ST_KERNELS is an internal routine used by the ZHETRD_HB2ST +*> subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> @param[in] n +*> The order of the matrix A. +*> +*> @param[in] nb +*> The size of the band. +*> +*> @param[in, out] A +*> A pointer to the matrix A. +*> +*> @param[in] lda +*> The leading dimension of the matrix A. +*> +*> @param[out] V +*> COMPLEX*16 array, dimension 2*n if eigenvalues only are +*> requested or to be queried for vectors. +*> +*> @param[out] TAU +*> COMPLEX*16 array, dimension (2*n). +*> The scalar factors of the Householder reflectors are stored +*> in this array. +*> +*> @param[in] st +*> internal parameter for indices. +*> +*> @param[in] ed +*> internal parameter for indices. +*> +*> @param[in] sweep +*> internal parameter for indices. +*> +*> @param[in] Vblksiz +*> internal parameter for indices. +*> +*> @param[in] wantz +*> logical which indicate if Eigenvalue are requested or both +*> Eigenvalue/Eigenvectors. +*> +*> @param[in] work +*> Workspace of size nb. +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHB2ST_KERNELS( UPLO, WANTZ, TTYPE, + $ ST, ED, SWEEP, N, NB, IB, + $ A, LDA, V, TAU, LDVT, WORK) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + LOGICAL WANTZ + INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), V( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, + $ DPOS, OFDPOS, AJETER + COMPLEX*16 CTMP +* .. +* .. External Subroutines .. + EXTERNAL ZLARFG, ZLARFX, ZLARFY +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MOD +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. +* .. Executable Statements .. +* + AJETER = IB + LDVT + UPPER = LSAME( UPLO, 'U' ) + + IF( UPPER ) THEN + DPOS = 2 * NB + 1 + OFDPOS = 2 * NB + ELSE + DPOS = 1 + OFDPOS = 2 + ENDIF + +* +* Upper case +* + IF( UPPER ) THEN +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 10 I = 1, LM-1 + V( VPOS+I ) = DCONJG( A( OFDPOS-I, ST+I ) ) + A( OFDPOS-I, ST+I ) = ZERO + 10 CONTINUE + CTMP = DCONJG( A( OFDPOS, ST ) ) + CALL ZLARFG( LM, CTMP, V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) + A( OFDPOS, ST ) = CTMP +* + LM = ED - ST + 1 + CALL ZLARFY( UPLO, LM, V( VPOS ), 1, + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.3 ) THEN +* + LM = ED - ST + 1 + CALL ZLARFY( UPLO, LM, V( VPOS ), 1, + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 + IF( LM.GT.0) THEN + CALL ZLARFX( 'Left', LN, LM, V( VPOS ), + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS-NB, J1 ), LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 30 I = 1, LM-1 + V( VPOS+I ) = + $ DCONJG( A( DPOS-NB-I, J1+I ) ) + A( DPOS-NB-I, J1+I ) = ZERO + 30 CONTINUE + CTMP = DCONJG( A( DPOS-NB, J1 ) ) + CALL ZLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) + A( DPOS-NB, J1 ) = CTMP +* + CALL ZLARFX( 'Right', LN-1, LM, V( VPOS ), + $ TAU( TAUPOS ), + $ A( DPOS-NB+1, J1 ), LDA-1, WORK) + ENDIF + ENDIF +* +* Lower case +* + ELSE +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + ST + TAUPOS = MOD( SWEEP-1, 2 ) * N + ST + ENDIF +* + IF( TTYPE.EQ.1 ) THEN + LM = ED - ST + 1 +* + V( VPOS ) = ONE + DO 20 I = 1, LM-1 + V( VPOS+I ) = A( OFDPOS+I, ST-1 ) + A( OFDPOS+I, ST-1 ) = ZERO + 20 CONTINUE + CALL ZLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + LM = ED - ST + 1 +* + CALL ZLARFY( UPLO, LM, V( VPOS ), 1, + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.3 ) THEN + LM = ED - ST + 1 +* + CALL ZLARFY( UPLO, LM, V( VPOS ), 1, + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS, ST ), LDA-1, WORK) + + ENDIF +* + IF( TTYPE.EQ.2 ) THEN + J1 = ED+1 + J2 = MIN( ED+NB, N ) + LN = ED-ST+1 + LM = J2-J1+1 +* + IF( LM.GT.0) THEN + CALL ZLARFX( 'Right', LM, LN, V( VPOS ), + $ TAU( TAUPOS ), A( DPOS+NB, ST ), + $ LDA-1, WORK) +* + IF( WANTZ ) THEN + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ELSE + VPOS = MOD( SWEEP-1, 2 ) * N + J1 + TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 + ENDIF +* + V( VPOS ) = ONE + DO 40 I = 1, LM-1 + V( VPOS+I ) = A( DPOS+NB+I, ST ) + A( DPOS+NB+I, ST ) = ZERO + 40 CONTINUE + CALL ZLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, + $ TAU( TAUPOS ) ) +* + CALL ZLARFX( 'Left', LM, LN-1, V( VPOS ), + $ DCONJG( TAU( TAUPOS ) ), + $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) + + ENDIF + ENDIF + ENDIF +* + RETURN +* +* END OF ZHB2ST_KERNELS +* + END diff --git a/lapack-netlib/SRC/zhbev.f b/lapack-netlib/SRC/zhbev.f index 62e75c97aa..964e684c85 100644 --- a/lapack-netlib/SRC/zhbev.f +++ b/lapack-netlib/SRC/zhbev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -152,10 +152,10 @@ SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhbev_2stage.f b/lapack-netlib/SRC/zhbev_2stage.f new file mode 100644 index 0000000000..bb0faefd2f --- /dev/null +++ b/lapack-netlib/SRC/zhbev_2stage.f @@ -0,0 +1,386 @@ +*> \brief ZHBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHBEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHBEV_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX*16 array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(1,3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHBEV_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, N, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, WANTZ, LQUERY + INTEGER IINFO, IMAX, INDE, INDWRK, INDRWK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHB + EXTERNAL LSAME, DLAMCH, ZLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTERF, XERBLA, ZLASCL, ZSTEQR, + $ ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'ZHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -11 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHBEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( LOWER ) THEN + W( 1 ) = DBLE( AB( 1, 1 ) ) + ELSE + W( 1 ) = DBLE( AB( KD+1, 1 ) ) + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call ZHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDE = 1 + INDHOUS = 1 + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL ZHETRD_HB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ RWORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + INDRWK = INDE + N + CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZHBEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhbevd.f b/lapack-netlib/SRC/zhbevd.f index fded2d1d9a..70378b140e 100644 --- a/lapack-netlib/SRC/zhbevd.f +++ b/lapack-netlib/SRC/zhbevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -202,12 +202,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -215,10 +215,10 @@ SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhbevd_2stage.f b/lapack-netlib/SRC/zhbevd_2stage.f new file mode 100644 index 0000000000..94863c708e --- /dev/null +++ b/lapack-netlib/SRC/zhbevd_2stage.f @@ -0,0 +1,458 @@ +*> \brief ZHBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHBEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, +* WORK, LWORK, RWORK, LRWORK, IWORK, +* LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHBEVD_2STAGE computes all the eigenvalues and, optionally, eigenvectors of +*> a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it +*> uses a divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX*16 array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. If UPLO = 'U', the first +*> superdiagonal and the diagonal of the tridiagonal matrix T +*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', +*> the diagonal and first subdiagonal of T are returned in the +*> first two rows of AB. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal +*> eigenvectors of the matrix A, with the i-th column of Z +*> holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, +*> dimension (LRWORK) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of array RWORK. +*> If N <= 1, LRWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. +*> If JOBZ = 'V' and N > 1, LRWORK must be at least +*> 1 + 5*N + 2*N**2. +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of array IWORK. +*> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHBEVD_2STAGE( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, + $ WORK, LWORK, RWORK, LRWORK, IWORK, + $ LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDWK2, INDRWK, ISCALE, + $ LLWORK, INDWK, LHTRD, LWTRD, IB, INDHOUS, + $ LIWMIN, LLRWK, LLWK2, LRWMIN, LWMIN + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHB + EXTERNAL LSAME, DLAMCH, ZLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTERF, XERBLA, ZGEMM, ZLACPY, + $ ZLASCL, ZSTEDC, ZHETRD_HB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) +* + INFO = 0 + IF( N.LE.1 ) THEN + LWMIN = 1 + LRWMIN = 1 + LIWMIN = 1 + ELSE + IB = ILAENV( 18, 'ZHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LWMIN = 2*N**2 + LRWMIN = 1 + 5*N + 2*N**2 + LIWMIN = 3 + 5*N + ELSE + LWMIN = MAX( N, LHTRD + LWTRD ) + LRWMIN = N + LIWMIN = 1 + END IF + END IF + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KD.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -6 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHBEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = DBLE( AB( 1, 1 ) ) + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + END IF +* +* Call ZHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDE = 1 + INDRWK = INDE + N + LLRWK = LRWORK - INDRWK + 1 + INDHOUS = 1 + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + INDWK2 = INDWK + N*N + LLWK2 = LWORK - INDWK2 + 1 +* + CALL ZHETRD_HB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, W, + $ RWORK( INDE ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEDC. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ), + $ LLWK2, RWORK( INDRWK ), LLRWK, IWORK, LIWORK, + $ INFO ) + CALL ZGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO, + $ WORK( INDWK2 ), N ) + CALL ZLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of ZHBEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhbevx.f b/lapack-netlib/SRC/zhbevx.f index f060029ece..3966cfa59e 100644 --- a/lapack-netlib/SRC/zhbevx.f +++ b/lapack-netlib/SRC/zhbevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N @@ -33,7 +33,7 @@ * COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -136,13 +139,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -246,12 +253,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHEReigen * @@ -260,10 +267,10 @@ SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/zhbevx_2stage.f b/lapack-netlib/SRC/zhbevx_2stage.f new file mode 100644 index 0000000000..8473c4a402 --- /dev/null +++ b/lapack-netlib/SRC/zhbevx_2stage.f @@ -0,0 +1,646 @@ +*> \brief ZHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHBEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, +* Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, +* Z, LDZ, WORK, LWORK, RWORK, IWORK, +* IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian band matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors +*> can be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found; +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found; +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX*16 array, dimension (LDAB, N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> +*> On exit, AB is overwritten by values generated during the +*> reduction to tridiagonal form. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD + 1. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension (LDQ, N) +*> If JOBZ = 'V', the N-by-N unitary matrix used in the +*> reduction to tridiagonal form. +*> If JOBZ = 'N', the array Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. If JOBZ = 'V', then +*> LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing AB to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the size of the band. +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16OTHEReigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, + $ Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, + $ Z, LDZ, WORK, LWORK, RWORK, IWORK, + $ IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, + $ LQUERY + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, + $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, + $ J, JJ, NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU + COMPLEX*16 CTMP1 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHB + EXTERNAL LSAME, DLAMCH, ZLANHB, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZCOPY, + $ ZGEMV, ZLACPY, ZLASCL, ZSTEIN, ZSTEQR, + $ ZSWAP, ZHETRD_HB2ST +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KD+1 ) THEN + INFO = -7 + ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -11 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -13 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) + $ INFO = -18 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + IB = ILAENV( 18, 'ZHETRD_HB2ST', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_HB2ST', JOBZ, N, KD, IB, -1 ) + LWMIN = LHTRD + LWTRD + WORK( 1 ) = LWMIN + ENDIF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -20 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHBEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + M = 1 + IF( LOWER ) THEN + CTMP1 = AB( 1, 1 ) + ELSE + CTMP1 = AB( KD+1, 1 ) + END IF + TMP1 = DBLE( CTMP1 ) + IF( VALEIG ) THEN + IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) + $ M = 0 + END IF + IF( M.EQ.1 ) THEN + W( 1 ) = DBLE( CTMP1 ) + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + ELSE + VLL = ZERO + VUU = ZERO + END IF + ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + ELSE + CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call ZHBTRD_HB2ST to reduce Hermitian band matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDRWK = INDE + N +* + INDHOUS = 1 + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL ZHETRD_HB2ST( 'N', JOBZ, UPLO, N, KD, AB, LDAB, + $ RWORK( INDD ), RWORK( INDE ), WORK( INDHOUS ), + $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal +* to zero, then call DSTERF or ZSTEQR. If this fails for some +* eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF (INDEIG) THEN + IF (IL.EQ.1 .AND. IU.EQ.N) THEN + TEST = .TRUE. + END IF + END IF + IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN + CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) + INDEE = INDRWK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL DSTERF( N, W, RWORK( INDEE ), INFO ) + ELSE + CALL ZLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWK = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWK ), INFO ) +* + IF( WANTZ ) THEN + CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by ZSTEIN. +* + DO 20 J = 1, M + CALL ZCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL ZGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO, + $ Z( 1, J ), 1 ) + 20 CONTINUE + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZHBEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhbgst.f b/lapack-netlib/SRC/zhbgst.f index efc48d0fa3..cb1c43bf32 100644 --- a/lapack-netlib/SRC/zhbgst.f +++ b/lapack-netlib/SRC/zhbgst.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, * LDX, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N @@ -30,7 +30,7 @@ * COMPLEX*16 AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -165,10 +165,10 @@ SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/zhbgv.f b/lapack-netlib/SRC/zhbgv.f index 81ed1b59f6..d7e89789e3 100644 --- a/lapack-netlib/SRC/zhbgv.f +++ b/lapack-netlib/SRC/zhbgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, * LDZ, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N @@ -30,7 +30,7 @@ * COMPLEX*16 AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -183,10 +183,10 @@ SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhbgvd.f b/lapack-netlib/SRC/zhbgvd.f index f60d6b017a..b2f792182f 100644 --- a/lapack-netlib/SRC/zhbgvd.f +++ b/lapack-netlib/SRC/zhbgvd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, * Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LRWORK, @@ -33,7 +33,7 @@ * COMPLEX*16 AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -233,12 +233,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHEReigen * @@ -252,10 +252,10 @@ SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -372,7 +372,7 @@ SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, LLWK2 = LWORK - INDWK2 + 2 LLRWK = LRWORK - INDWRK + 2 CALL ZHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, - $ WORK, RWORK( INDWRK ), IINFO ) + $ WORK, RWORK, IINFO ) * * Reduce Hermitian band matrix to tridiagonal form. * diff --git a/lapack-netlib/SRC/zhbgvx.f b/lapack-netlib/SRC/zhbgvx.f index e8596e4516..07526a56c0 100644 --- a/lapack-netlib/SRC/zhbgvx.f +++ b/lapack-netlib/SRC/zhbgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, * LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, * LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, @@ -34,7 +34,7 @@ * COMPLEX*16 AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,13 +153,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -167,14 +171,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -272,12 +281,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHEReigen * @@ -291,10 +300,10 @@ SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/zhbtrd.f b/lapack-netlib/SRC/zhbtrd.f index 0ea08bd2b6..7f5af1b59f 100644 --- a/lapack-netlib/SRC/zhbtrd.f +++ b/lapack-netlib/SRC/zhbtrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHBTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHBTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KD, LDAB, LDQ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -163,10 +163,10 @@ SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT diff --git a/lapack-netlib/SRC/zhecon.f b/lapack-netlib/SRC/zhecon.f index f87b4bfda8..bb8ee6d3fe 100644 --- a/lapack-netlib/SRC/zhecon.f +++ b/lapack-netlib/SRC/zhecon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHECON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -125,10 +125,10 @@ SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhecon_3.f b/lapack-netlib/SRC/zhecon_3.f new file mode 100644 index 0000000000..db93f6d935 --- /dev/null +++ b/lapack-netlib/SRC/zhecon_3.f @@ -0,0 +1,285 @@ +*> \brief \b ZHECON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHECON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHECON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex Hermitian matrix A using the factorization +*> computed by ZHETRF_RK or ZHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver ZHETRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_RK or ZHETRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZHETRS_3, ZLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHECON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**H) or inv(U*D*U**H). +* + CALL ZHETRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of ZHECON_3 +* + END diff --git a/lapack-netlib/SRC/zhecon_rook.f b/lapack-netlib/SRC/zhecon_rook.f index 9ae4336500..3daf53523c 100644 --- a/lapack-netlib/SRC/zhecon_rook.f +++ b/lapack-netlib/SRC/zhecon_rook.f @@ -1,4 +1,4 @@ -*> \brief \b ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +*> \brief ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) * * =========== DOCUMENTATION =========== * @@ -117,7 +117,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -125,7 +125,7 @@ * ================== *> \verbatim *> -*> November 2013, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -139,10 +139,10 @@ SUBROUTINE ZHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zheequb.f b/lapack-netlib/SRC/zheequb.f index 12bead6c9f..ec6d095adf 100644 --- a/lapack-netlib/SRC/zheequb.f +++ b/lapack-netlib/SRC/zheequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), WORK( * ) * DOUBLE PRECISION S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -37,12 +37,11 @@ *> \verbatim *> *> ZHEEQUB computes row and column scalings intended to equilibrate a -*> Hermitian matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> Hermitian matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -52,28 +51,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) -*> The N-by-N Hermitian matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N Hermitian matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -86,21 +84,21 @@ *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension (3*N) +*> WORK is COMPLEX*16 array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -114,19 +112,27 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * *> \ingroup complex16HEcomputational * +*> \par References: +* ================ +*> +*> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n +*> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n +*> DOI 10.1023/B:NUMA.0000016606.32820.69 \n +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 +*> * ===================================================================== SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -145,14 +151,14 @@ SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * .. Parameters .. DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) INTEGER MAX_ITER PARAMETER ( MAX_ITER = 100 ) * .. * .. Local Scalars .. INTEGER I, J, ITER - DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, - $ BASE, SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ LOGICAL UP COMPLEX*16 ZDUM * .. @@ -172,20 +178,22 @@ SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. * .. Statement Function Definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. * -* Test input parameters. +* Test the input parameters. * INFO = 0 - IF (.NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'ZHEEQUB', -INFO ) - RETURN + CALL XERBLA( 'ZHEEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -194,12 +202,12 @@ SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -220,102 +228,100 @@ SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) DO I = J+1, N S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) - AMAX = MAX( AMAX, CABS1( A(I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO END DO END IF DO J = 1, N - S( J ) = 1.0D+0 / S( J ) + S( J ) = 1.0D0 / S( J ) END DO TOL = ONE / SQRT( 2.0D0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0D+0 - SUMSQ = 0.0D+0 -* beta = |A|s - DO I = 1, N - WORK( I ) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - DO I = J+1, N - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - END DO - END IF + SCALE = 0.0D0 + SUMSQ = 0.0D0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF -* avg = s^T beta / n - AVG = 0.0D+0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N +* avg = s^T beta / n + AVG = 0.0D0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - STD = 0.0D+0 - DO I = 2*N+1, 3*N - WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG - END DO - CALL ZLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + STD = 0.0D0 + DO I = N+1, N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL ZLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( STD .LT. TOL * AVG ) GOTO 999 + IF ( STD .LT. TOL * AVG ) GOTO 999 - DO I = 1, N - T = CABS1( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - D = C1*C1 - 4*C0*C2 - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - D = SI - S(I) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -328,10 +334,10 @@ SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BASE = DLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) - +* END diff --git a/lapack-netlib/SRC/zheev.f b/lapack-netlib/SRC/zheev.f index adba990f0a..3e87778740 100644 --- a/lapack-netlib/SRC/zheev.f +++ b/lapack-netlib/SRC/zheev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEeigen * @@ -140,10 +140,10 @@ SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zheev_2stage.f b/lapack-netlib/SRC/zheev_2stage.f new file mode 100644 index 0000000000..0cf57e9047 --- /dev/null +++ b/lapack-netlib/SRC/zheev_2stage.f @@ -0,0 +1,355 @@ +*> \brief ZHEEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHEEV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTERF, XERBLA, ZLASCL, ZSTEQR, + $ ZUNGTR, ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEEV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = DBLE( A( 1, 1 ) ) + WORK( 1 ) = 1 + IF( WANTZ ) + $ A( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call ZHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDE = 1 + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* ZUNGTR to generate the unitary matrix, then call ZSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + INDWRK = INDE + N + CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, + $ RWORK( INDWRK ), INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal complex workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZHEEV_2STAGE +* + END diff --git a/lapack-netlib/SRC/zheevd.f b/lapack-netlib/SRC/zheevd.f index 74b21b0d4f..cbe9a39a19 100644 --- a/lapack-netlib/SRC/zheevd.f +++ b/lapack-netlib/SRC/zheevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, * LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -181,12 +181,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEeigen * @@ -205,10 +205,10 @@ SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zheevd_2stage.f b/lapack-netlib/SRC/zheevd_2stage.f new file mode 100644 index 0000000000..7a8c1593f2 --- /dev/null +++ b/lapack-netlib/SRC/zheevd_2stage.f @@ -0,0 +1,451 @@ +*> \brief ZHEEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHEEVD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHEEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, +* RWORK, LRWORK, IWORK, LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a +*> complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. If eigenvectors are desired, it uses a +*> divide and conquer algorithm. +*> +*> The divide and conquer algorithm makes very mild assumptions about +*> floating point arithmetic. It will work on machines with a guard +*> digit in add/subtract, or on those binary machines without guard +*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or +*> Cray-2. It could conceivably fail on hexadecimal or decimal machines +*> without guard digits, but we know of none. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> orthonormal eigenvectors of the matrix A. +*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +*> or the upper triangle (if UPLO='U') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= 1, LWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N+1 +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N+1 +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, +*> dimension (LRWORK) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> If N <= 1, LRWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. +*> If JOBZ = 'V' and N > 1, LRWORK must be at least +*> 1 + 5*N + 2*N**2. +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= 1, LIWORK must be at least 1. +*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. +*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed +*> to converge; i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> if INFO = i and JOBZ = 'V', then the algorithm failed +*> to compute an eigenvalue while working on the submatrix +*> lying in rows and columns INFO/(N+1) through +*> mod(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEeigen +* +*> \par Further Details: +* ===================== +*> +*> Modified description of INFO. Sven, 16 Feb 05. +* +*> \par Contributors: +* ================== +*> +*> Jeff Rutter, Computer Science Division, University of California +*> at Berkeley, USA +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHEEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, + $ RWORK, LRWORK, IWORK, LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, + $ INDWRK, ISCALE, LIWMIN, LLRWK, LLWORK, + $ LLWRK2, LRWMIN, LWMIN, + $ LHTRD, LWTRD, KD, IB, INDHOUS + + + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSTERF, XERBLA, ZLACPY, ZLASCL, + $ ZSTEDC, ZUNMTR, ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + LRWMIN = 1 + LIWMIN = 1 + ELSE + KD = ILAENV( 17, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + IF( WANTZ ) THEN + LWMIN = 2*N + N*N + LRWMIN = 1 + 5*N + 2*N**2 + LIWMIN = 3 + 5*N + ELSE + LWMIN = N + 1 + LHTRD + LWTRD + LRWMIN = N + LIWMIN = 1 + END IF + END IF + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -8 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEEVD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + W( 1 ) = DBLE( A( 1, 1 ) ) + IF( WANTZ ) + $ A( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call ZHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDE = 1 + INDRWK = INDE + N + LLRWK = LRWORK - INDRWK + 1 + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 + INDWK2 = INDWRK + N*N + LLWRK2 = LWORK - INDWK2 + 1 +* + CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), + $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the +* tridiagonal matrix, then call ZUNMTR to multiply it to the +* Householder transformations represented as Householder vectors in +* A. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, RWORK( INDE ), INFO ) + ELSE + CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, + $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, + $ IWORK, LIWORK, INFO ) + CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), + $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) + CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of ZHEEVD_2STAGE +* + END diff --git a/lapack-netlib/SRC/zheevr.f b/lapack-netlib/SRC/zheevr.f index 86e05b0657..810373c839 100644 --- a/lapack-netlib/SRC/zheevr.f +++ b/lapack-netlib/SRC/zheevr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEVR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEVR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, * RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, @@ -33,7 +33,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -168,13 +171,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -250,7 +257,9 @@ *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through -*> ISUPPZ( 2*i ). +*> ISUPPZ( 2*i ). This is an output of ZSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the unitary transformations applied by ZUNMTR. *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> @@ -324,12 +333,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16HEeigen * @@ -348,10 +357,10 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -617,7 +626,7 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ IWORK, LIWORK, INFO ) * * Apply unitary matrix used in reduction to tridiagonal -* form to eigenvectors returned by ZSTEIN. +* form to eigenvectors returned by ZSTEMR. * IF( WANTZ .AND. INFO.EQ.0 ) THEN INDWKN = INDWK diff --git a/lapack-netlib/SRC/zheevr_2stage.f b/lapack-netlib/SRC/zheevr_2stage.f new file mode 100644 index 0000000000..5457853617 --- /dev/null +++ b/lapack-netlib/SRC/zheevr_2stage.f @@ -0,0 +1,779 @@ +*> \brief ZHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHEEVR_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, +* WORK, LWORK, RWORK, LRWORK, IWORK, +* LIWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, +* $ M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER ISUPPZ( * ), IWORK( * ) +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> +*> ZHEEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call +*> to ZHETRD. Then, whenever possible, ZHEEVR_2STAGE calls ZSTEMR to compute +*> eigenspectrum using Relatively Robust Representations. ZSTEMR +*> computes eigenvalues by the dqds algorithm, while orthogonal +*> eigenvectors are computed from various "good" L D L^T representations +*> (also known as Relatively Robust Representations). Gram-Schmidt +*> orthogonalization is avoided as far as possible. More specifically, +*> the various steps of the algorithm are as follows. +*> +*> For each unreduced block (submatrix) of T, +*> (a) Compute T - sigma I = L D L^T, so that L and D +*> define all the wanted eigenvalues to high relative accuracy. +*> This means that small relative changes in the entries of D and L +*> cause only small relative changes in the eigenvalues and +*> eigenvectors. The standard (unfactored) representation of the +*> tridiagonal matrix T does not have this property in general. +*> (b) Compute the eigenvalues to suitable accuracy. +*> If the eigenvectors are desired, the algorithm attains full +*> accuracy of the computed eigenvalues only right before +*> the corresponding vectors have to be computed, see steps c) and d). +*> (c) For each cluster of close eigenvalues, select a new +*> shift close to the cluster, find a new factorization, and refine +*> the shifted eigenvalues to suitable accuracy. +*> (d) For each eigenvalue with a large enough relative separation compute +*> the corresponding eigenvector by forming a rank revealing twisted +*> factorization. Go back to (c) for any clusters that remain. +*> +*> The desired accuracy of the output can be specified by the input +*> parameter ABSTOL. +*> +*> For more details, see DSTEMR's documentation and: +*> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations +*> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," +*> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. +*> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and +*> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, +*> 2004. Also LAPACK Working Note 154. +*> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric +*> tridiagonal eigenvalue/eigenvector problem", +*> Computer Science Division Technical Report No. UCB/CSD-97-971, +*> UC Berkeley, May 1997. +*> +*> +*> Note 1 : ZHEEVR_2STAGE calls ZSTEMR when the full spectrum is requested +*> on machines which conform to the ieee-754 floating point standard. +*> ZHEEVR_2STAGE calls DSTEBZ and ZSTEIN on non-ieee machines and +*> when partial spectrum requests are made. +*> +*> Normal execution of ZSTEMR may create NaNs and infinities and +*> hence may abort due to a floating point exception in environments +*> which do not handle NaNs and infinities in the ieee standard default +*> manner. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and +*> ZSTEIN are called +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> +*> If high relative accuracy is important, set ABSTOL to +*> DLAMCH( 'Safe minimum' ). Doing so will guarantee that +*> eigenvalues are computed to high relative accuracy when +*> possible in future releases. The current code does not +*> make any guarantees about high relative accuracy, but +*> furutre releases will. See J. Barlow and J. Demmel, +*> "Computing Accurate Eigensystems of Scaled Diagonally +*> Dominant Matrices", LAPACK Working Note #7, for a discussion +*> of which matrices define their eigenvalues to high relative +*> accuracy. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> The first M elements contain the selected eigenvalues in +*> ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] ISUPPZ +*> \verbatim +*> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) +*> The support of the eigenvectors in Z, i.e., the indices +*> indicating the nonzero elements in Z. The i-th eigenvector +*> is nonzero only in elements ISUPPZ( 2*i-1 ) through +*> ISUPPZ( 2*i ). This is an output of ZSTEMR (tridiagonal +*> matrix). The support of the eigenvectors of A is typically +*> 1:N because of the unitary transformations applied by ZUNMTR. +*> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 26*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal sizes of the WORK, RWORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal +*> (and minimal) LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The length of the array RWORK. LRWORK >= max(1,24*N). +*> +*> If LRWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal +*> (and minimal) LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. LIWORK >= max(1,10*N). +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK, RWORK +*> and IWORK arrays, returns these values as the first entries +*> of the WORK, RWORK and IWORK arrays, and no error message +*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: Internal error +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16HEeigen +* +*> \par Contributors: +* ================== +*> +*> Inderjit Dhillon, IBM Almaden, USA \n +*> Osni Marques, LBNL/NERSC, USA \n +*> Ken Stanley, Computer Science Division, University of +*> California at Berkeley, USA \n +*> Jason Riedy, Computer Science Division, University of +*> California at Berkeley, USA \n +*> +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, + $ WORK, LWORK, RWORK, LRWORK, IWORK, + $ LIWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, + $ M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER ISUPPZ( * ), IWORK( * ) + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ, TRYRAC + CHARACTER ORDER + INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, + $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, + $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, + $ LWMIN, NSPLIT, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, + $ ZHETRD_2STAGE, ZSTEMR, ZSTEIN, ZSWAP, ZUNMTR +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IEEEOK = ILAENV( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 ) +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR. + $ ( LIWORK.EQ.-1 ) ) +* + KD = ILAENV( 17, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + LRWMIN = MAX( 1, 24*N ) + LIWMIN = MAX( 1, 10*N ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -18 + ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN + INFO = -20 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -22 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEEVR_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 2 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = DBLE( A( 1, 1 ) ) + ELSE + IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) + $ THEN + M = 1 + W( 1 ) = DBLE( A( 1, 1 ) ) + END IF + END IF + IF( WANTZ ) THEN + Z( 1, 1 ) = ONE + ISUPPZ( 1 ) = 1 + ISUPPZ( 2 ) = 1 + END IF + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + END IF + ANRM = ZLANSY( 'M', UPLO, N, A, LDA, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF + +* Initialize indices into workspaces. Note: The IWORK indices are +* used only if DSTERF or ZSTEMR fail. + +* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the +* elementary reflectors used in ZHETRD. + INDTAU = 1 +* INDWK is the starting offset of the remaining complex workspace, +* and LLWORK is the remaining complex workspace size. + INDHOUS = INDTAU + N + INDWK = INDHOUS + LHTRD + LLWORK = LWORK - INDWK + 1 + +* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal +* entries. + INDRD = 1 +* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the +* tridiagonal matrix from ZHETRD. + INDRE = INDRD + N +* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over +* -written by ZSTEMR (the DSTERF path copies the diagonal to W). + INDRDD = INDRE + N +* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over +* -written while computing the eigenvalues in DSTERF and ZSTEMR. + INDREE = INDRDD + N +* INDRWK is the starting offset of the left-over real workspace, and +* LLRWORK is the remaining workspace size. + INDRWK = INDREE + N + LLRWORK = LRWORK - INDRWK + 1 + +* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and +* stores the block indices of each of the M<=N eigenvalues. + INDIBL = 1 +* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and +* stores the starting and finishing indices of each block. + INDISP = INDIBL + N +* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors +* that corresponding to eigenvectors that fail to converge in +* ZSTEIN. This information is discarded; if any fail, the driver +* returns INFO > 0. + INDIFL = INDISP + N +* INDIWO is the offset of the remaining integer workspace. + INDIWO = INDIFL + N + +* +* Call ZHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDRD ), + $ RWORK( INDRE ), WORK( INDTAU ), + $ WORK( INDHOUS ), LHTRD, + $ WORK( INDWK ), LLWORK, IINFO ) +* +* If all eigenvalues are desired +* then call DSTERF or ZSTEMR and ZUNMTR. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) + CALL DSTERF( N, W, RWORK( INDREE ), INFO ) + ELSE + CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) + CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) +* + IF (ABSTOL .LE. TWO*N*EPS) THEN + TRYRAC = .TRUE. + ELSE + TRYRAC = .FALSE. + END IF + CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + $ RWORK( INDREE ), VL, VU, IL, IU, M, W, + $ Z, LDZ, N, ISUPPZ, TRYRAC, + $ RWORK( INDRWK ), LLRWORK, + $ IWORK, LIWORK, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by ZSTEMR. +* + IF( WANTZ .AND. INFO.EQ.0 ) THEN + INDWKN = INDWK + LLWRKN = LWORK - INDWKN + 1 + CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, + $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), + $ LLWRKN, IINFO ) + END IF + END IF +* +* + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. +* Also call DSTEBZ and ZSTEIN if ZSTEMR fails. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL ZSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ), + $ INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by ZSTEIN. +* + INDWKN = INDWK + LLWRKN = LWORK - INDWKN + 1 + CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 30 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 50 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + END IF + 50 CONTINUE + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWMIN + RWORK( 1 ) = LRWMIN + IWORK( 1 ) = LIWMIN +* + RETURN +* +* End of ZHEEVR_2STAGE +* + END diff --git a/lapack-netlib/SRC/zheevx.f b/lapack-netlib/SRC/zheevx.f index 376d4c1b9b..3e11875db6 100644 --- a/lapack-netlib/SRC/zheevx.f +++ b/lapack-netlib/SRC/zheevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,12 +99,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -112,13 +115,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -238,12 +245,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16HEeigen * @@ -252,10 +259,10 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/zheevx_2stage.f b/lapack-netlib/SRC/zheevx_2stage.f new file mode 100644 index 0000000000..9def33c6de --- /dev/null +++ b/lapack-netlib/SRC/zheevx_2stage.f @@ -0,0 +1,618 @@ +*> \brief ZHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHEEVX_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, +* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, +* LWORK, RWORK, IWORK, IFAIL, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, RANGE, UPLO +* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N +* DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. +* INTEGER IFAIL( * ), IWORK( * ) +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors +*> of a complex Hermitian matrix A using the 2stage technique for +*> the reduction to tridiagonal. Eigenvalues and eigenvectors can +*> be selected by specifying either a range of values or a range of +*> indices for the desired eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] RANGE +*> \verbatim +*> RANGE is CHARACTER*1 +*> = 'A': all eigenvalues will be found. +*> = 'V': all eigenvalues in the half-open interval (VL,VU] +*> will be found. +*> = 'I': the IL-th through IU-th eigenvalues will be found. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, the lower triangle (if UPLO='L') or the upper +*> triangle (if UPLO='U') of A, including the diagonal, is +*> destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] VL +*> \verbatim +*> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] VU +*> \verbatim +*> VU is DOUBLE PRECISION +*> If RANGE='V', the upper bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. +*> \endverbatim +*> +*> \param[in] IL +*> \verbatim +*> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] IU +*> \verbatim +*> IU is INTEGER +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> The absolute error tolerance for the eigenvalues. +*> An approximate eigenvalue is accepted as converged +*> when it is determined to lie in an interval [a,b] +*> of width less than or equal to +*> +*> ABSTOL + EPS * max( |a|,|b| ) , +*> +*> where EPS is the machine precision. If ABSTOL is less than +*> or equal to zero, then EPS*|T| will be used in its place, +*> where |T| is the 1-norm of the tridiagonal matrix obtained +*> by reducing A to tridiagonal form. +*> +*> Eigenvalues will be computed most accurately when ABSTOL is +*> set to twice the underflow threshold 2*DLAMCH('S'), not zero. +*> If this routine returns with INFO>0, indicating that some +*> eigenvectors did not converge, try setting ABSTOL to +*> 2*DLAMCH('S'). +*> +*> See "Computing Small Singular Values of Bidiagonal Matrices +*> with Guaranteed High Relative Accuracy," by Demmel and +*> Kahan, LAPACK Working Note #3. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The total number of eigenvalues found. 0 <= M <= N. +*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> On normal exit, the first M elements contain the selected +*> eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M)) +*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z +*> contain the orthonormal eigenvectors of the matrix A +*> corresponding to the selected eigenvalues, with the i-th +*> column of Z holding the eigenvector associated with W(i). +*> If an eigenvector fails to converge, then that column of Z +*> contains the latest approximation to the eigenvector, and the +*> index of the eigenvector is returned in IFAIL. +*> If JOBZ = 'N', then Z is not referenced. +*> Note: the user must ensure that at least max(1,M) columns are +*> supplied in the array Z; if RANGE = 'V', the exact value of M +*> is not known in advance and an upper bound must be used. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, 8*N, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (7*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (5*N) +*> \endverbatim +*> +*> \param[out] IFAIL +*> \verbatim +*> IFAIL is INTEGER array, dimension (N) +*> If JOBZ = 'V', then if INFO = 0, the first M elements of +*> IFAIL are zero. If INFO > 0, then IFAIL contains the +*> indices of the eigenvectors that failed to converge. +*> If JOBZ = 'N', then IFAIL is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, then i eigenvectors failed to converge. +*> Their indices are stored in array IFAIL. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16HEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, + $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, + $ LWORK, RWORK, IWORK, IFAIL, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, + $ WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, + $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, + $ ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, ZUNMTR, + $ ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + IF( VALEIG ) THEN + IF( N.GT.0 .AND. VU.LE.VL ) + $ INFO = -8 + ELSE IF( INDEIG ) THEN + IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN + INFO = -10 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.LE.1 ) THEN + LWMIN = 1 + WORK( 1 ) = LWMIN + ELSE + KD = ILAENV( 17, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) + $ INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEEVX_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + M = 0 + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = DBLE( A( 1, 1 ) ) + ELSE IF( VALEIG ) THEN + IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) + $ THEN + M = 1 + W( 1 ) = DBLE( A( 1, 1 ) ) + END IF + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = CONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* Call ZHETRD_2STAGE to reduce Hermitian matrix to tridiagonal form. +* + INDD = 1 + INDE = INDD + N + INDRWK = INDE + N + INDTAU = 1 + INDHOUS = INDTAU + N + INDWRK = INDHOUS + LHTRD + LLWORK = LWORK - INDWRK + 1 +* + CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDD ), + $ RWORK( INDE ), WORK( INDTAU ), + $ WORK( INDHOUS ), LHTRD, WORK( INDWRK ), + $ LLWORK, IINFO ) +* +* If all eigenvalues are desired and ABSTOL is less than or equal to +* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for +* some eigenvalue, then try DSTEBZ. +* + TEST = .FALSE. + IF( INDEIG ) THEN + IF( IL.EQ.1 .AND. IU.EQ.N ) THEN + TEST = .TRUE. + END IF + END IF + IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) + INDEE = INDRWK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL DSTERF( N, W, RWORK( INDEE ), INFO ) + ELSE + CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) + CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, + $ RWORK( INDRWK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWK = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), + $ IWORK( INDIWK ), INFO ) +* + IF( WANTZ ) THEN + CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) +* +* Apply unitary matrix used in reduction to tridiagonal +* form to eigenvectors returned by ZSTEIN. +* + CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* If eigenvalues are not in order, then sort them, along with +* eigenvectors. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* Set WORK(1) to optimal complex workspace size. +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZHEEVX_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhegs2.f b/lapack-netlib/SRC/zhegs2.f index 80c4b21381..0bdc653b93 100644 --- a/lapack-netlib/SRC/zhegs2.f +++ b/lapack-netlib/SRC/zhegs2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhegst.f b/lapack-netlib/SRC/zhegst.f index cf804bf2e8..d0c08a8f67 100644 --- a/lapack-netlib/SRC/zhegst.f +++ b/lapack-netlib/SRC/zhegst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhegv.f b/lapack-netlib/SRC/zhegv.f index 912c4bcced..761b5d0f24 100644 --- a/lapack-netlib/SRC/zhegv.f +++ b/lapack-netlib/SRC/zhegv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16HEeigen * @@ -181,10 +181,10 @@ SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhegv_2stage.f b/lapack-netlib/SRC/zhegv_2stage.f new file mode 100644 index 0000000000..1afd2e1873 --- /dev/null +++ b/lapack-netlib/SRC/zhegv_2stage.f @@ -0,0 +1,379 @@ +*> \brief \b ZHEGV_2STAGE +* +* @precisions fortran z -> c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHEGV_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHEGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, +* WORK, LWORK, RWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK( * ), W( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors +*> of a complex generalized Hermitian-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A and B are assumed to be Hermitian and B is also +*> positive definite. +*> This routine use the 2stage technique for the reduction to tridiagonal +*> which showed higher performance on recent architecture and for large +* sizes N>2000. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> Not available in this release. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the leading N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z of eigenvectors. The eigenvectors are normalized +*> as follows: +*> if ITYPE = 1 or 2, Z**H*B*Z = I; +*> if ITYPE = 3, Z**H*inv(B)*Z = I. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB, N) +*> On entry, the Hermitian positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**H*U or B = L*L**H. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1, when N <= 1; +*> otherwise +*> If JOBZ = 'N' and N > 1, LWORK must be queried. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N + N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N + N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: ZPOTRF or ZHEEV returned an error code: +*> <= N: if INFO = i, ZHEEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEeigen +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> All details about the 2stage techniques are available in: +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHEGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, + $ WORK, LWORK, RWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK driver 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 .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ), W( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER NEIG, LWMIN, LHTRD, LWTRD, KD, IB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHEGST, ZPOTRF, ZTRMM, ZTRSM, + $ ZHEEV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + KD = ILAENV( 17, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) + IB = ILAENV( 18, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) + LHTRD = ILAENV( 19, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWTRD = ILAENV( 20, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + LWMIN = N + LHTRD + LWTRD + WORK( 1 ) = LWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHEGV_2STAGE ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL ZPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL ZHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, + $ WORK, LWORK, RWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'C' + END IF +* + CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**H *y +* + IF( UPPER ) THEN + TRANS = 'C' + ELSE + TRANS = 'N' + END IF +* + CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWMIN +* + RETURN +* +* End of ZHEGV_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhegvd.f b/lapack-netlib/SRC/zhegvd.f index 5b70a749cc..b9bb05367e 100644 --- a/lapack-netlib/SRC/zhegvd.f +++ b/lapack-netlib/SRC/zhegvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -220,12 +220,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16HEeigen * @@ -249,10 +249,10 @@ SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhegvx.f b/lapack-netlib/SRC/zhegvx.f index 932e070e27..268a8226dc 100644 --- a/lapack-netlib/SRC/zhegvx.f +++ b/lapack-netlib/SRC/zhegvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHEGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHEGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, * VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, * LWORK, RWORK, IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,13 +132,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -146,14 +150,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -279,12 +288,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16HEeigen * @@ -298,10 +307,10 @@ SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/zherfs.f b/lapack-netlib/SRC/zherfs.f index f278265d8b..2b4095b88f 100644 --- a/lapack-netlib/SRC/zherfs.f +++ b/lapack-netlib/SRC/zherfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHERFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHERFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -179,12 +179,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -192,10 +192,10 @@ SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zherfsx.f b/lapack-netlib/SRC/zherfsx.f index 038ed8e78e..d176b102c4 100644 --- a/lapack-netlib/SRC/zherfsx.f +++ b/lapack-netlib/SRC/zherfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHERFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHERFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), RWORK( * ), * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) -* +* * *> \par Purpose: * ============= @@ -386,10 +386,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -401,7 +401,7 @@ SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -461,12 +461,11 @@ SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, ZLANHE, ZLA_HERCOND_X, ZLA_HERCOND_C DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_HERCOND_X, ZLA_HERCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/zhesv.f b/lapack-netlib/SRC/zhesv.f index 664cb22b0b..e9f60bfc51 100644 --- a/lapack-netlib/SRC/zhesv.f +++ b/lapack-netlib/SRC/zhesv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHESV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEsolve * @@ -171,10 +171,10 @@ SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhesv_aa.f b/lapack-netlib/SRC/zhesv_aa.f new file mode 100644 index 0000000000..56a3086af0 --- /dev/null +++ b/lapack-netlib/SRC/zhesv_aa.f @@ -0,0 +1,254 @@ +*> \brief ZHESV_AA computes the solution to system of linear equations A * X = B for HE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHESV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHESV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHESV_AA computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**H, if UPLO = 'U', or +*> A = L * T * L**H, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is Hermitian and tridiagonal. The factored form +*> of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**H or A = L*T*L**H as computed by +*> ZHETRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for best +*> performance LWORK >= max(1,N*NB), where NB is the optimal +*> blocksize for ZHETRF. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEsolve +* +* ===================================================================== + SUBROUTINE ZHESV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_HETRF, LWKOPT_HETRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHETRF, ZHETRS, ZHETRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL ZHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_HETRF = INT( WORK(1) ) + CALL ZHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_HETRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_HETRF, LWKOPT_HETRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHESV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**H or A = L*T*L**H. +* + CALL ZHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL ZHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHESV_AA +* + END diff --git a/lapack-netlib/SRC/zhesv_rk.f b/lapack-netlib/SRC/zhesv_rk.f new file mode 100644 index 0000000000..da0e6f26db --- /dev/null +++ b/lapack-netlib/SRC/zhesv_rk.f @@ -0,0 +1,317 @@ +*> \brief ZHESV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHESV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHESV_RK computes the solution to a complex system of linear +*> equations A * X = B, where A is an N-by-N Hermitian matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**H)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZHETRF_RK is called to compute the factorization of a complex +*> Hermitian matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine ZHETRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by ZHETRF_RK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of ZHETRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine ZHETRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of ZHETRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZHETRF_RK. +*> +*> For more info see the description of ZHETRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for ZHETRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHETRF_RK, ZHETRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHESV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = P*U*D*(U**H)*(P**T) or +* A = P*U*D*(U**H)*(P**T). +* + CALL ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHESV_RK +* + END diff --git a/lapack-netlib/SRC/zhesvx.f b/lapack-netlib/SRC/zhesvx.f index fd787c7f34..d706326943 100644 --- a/lapack-netlib/SRC/zhesvx.f +++ b/lapack-netlib/SRC/zhesvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHESVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHESVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,10 +271,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -285,7 +285,7 @@ SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zhesvxx.f b/lapack-netlib/SRC/zhesvxx.f index 27ce0fc5e9..375fc072df 100644 --- a/lapack-netlib/SRC/zhesvxx.f +++ b/lapack-netlib/SRC/zhesvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHESVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHESVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -491,10 +491,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -506,7 +506,7 @@ SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -551,7 +551,7 @@ SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, DOUBLE PRECISION DLAMCH, ZLA_HERPVGRW * .. * .. External Subroutines .. - EXTERNAL ZHECON, ZHEEQUB, ZHETRF, ZHETRS, ZLACPY, + EXTERNAL ZHEEQUB, ZHETRF, ZHETRS, ZLACPY, $ ZLAQHE, XERBLA, ZLASCL2, ZHERFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/zheswapr.f b/lapack-netlib/SRC/zheswapr.f index 8870350ea2..1eec8477fc 100644 --- a/lapack-netlib/SRC/zheswapr.f +++ b/lapack-netlib/SRC/zheswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHESWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHESWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHESWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEauxiliary * * ===================================================================== SUBROUTINE ZHESWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,14 +136,14 @@ SUBROUTINE ZHESWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL ZSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) * - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 * - swap A(I2,I1) and A(I1,I2) - + TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -169,12 +169,12 @@ SUBROUTINE ZHESWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from 1 to I1-1 +* - swap row I1 and I2 from 1 to I1-1 CALL ZSWAP ( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 * - swap A(I2,I1) and A(I1,I2) TMP=A(I1,I1) @@ -198,6 +198,6 @@ SUBROUTINE ZHESWAPR( UPLO, N, A, LDA, I1, I2) END DO * ENDIF - + END SUBROUTINE ZHESWAPR diff --git a/lapack-netlib/SRC/zhetd2.f b/lapack-netlib/SRC/zhetd2.f index dd8f9cf014..6c5b8aae3d 100644 --- a/lapack-netlib/SRC/zhetd2.f +++ b/lapack-netlib/SRC/zhetd2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -175,10 +175,10 @@ * ===================================================================== SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhetf2_rk.f b/lapack-netlib/SRC/zhetf2_rk.f new file mode 100644 index 0000000000..84d3a02486 --- /dev/null +++ b/lapack-netlib/SRC/zhetf2_rk.f @@ -0,0 +1,1039 @@ +*> \brief \b ZHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHETF2_RK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* ====================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE, UPPER + INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP, + $ P + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP, + $ ROWMAX, TT, SFMIN + COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. +* + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL LSAME, IZAMAX, DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**H using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( A( K, K ) ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the leading submatrix A(1:k,1:k) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.GT.1 ) + $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 14 J = P + 1, K - 1 + T = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( P, J ) ) + A( P, J ) = T + 14 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = DCONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( K, K ) ) + A( K, K ) = DBLE( A( P, P ) ) + A( P, P ) = R1 +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the leading submatrix A(1:k,1:k) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 15 J = KP + 1, KK - 1 + T = DCONJG( A( J, KK ) ) + A( J, KK ) = DCONJG( A( KP, J ) ) + A( KP, J ) = T + 15 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = DCONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( KK, KK ) ) + A( KK, KK ) = DBLE( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) +* (5) Swap row elements + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) ) + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / DBLE( A( K, K ) ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL ZDSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = DBLE( A( K, K ) ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* D = |A12| + D = DLAPY2( DBLE( A( K-1, K ) ), + $ DIMAG( A( K-1, K ) ) ) + D11 = A( K, K ) / D + D22 = A( K-1, K-1 ) / D + D12 = A( K-1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) + WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) +* +* Perform a rank-2 update of A(1:k-2,1:k-2) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*DCONJG( WK ) - + $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D + A( J, K-1 ) = WKM1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = CZERO + A( K-1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**H using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( A( K, K ) ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 42 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the trailing submatrix A(k:n,k:n) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.LT.N ) + $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 44 J = K + 1, P - 1 + T = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( P, J ) ) + A( P, J ) = T + 44 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = DCONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( K, K ) ) + A( K, K ) = DBLE( A( P, P ) ) + A( P, P ) = R1 +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the trailing submatrix A(k:n,k:n) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 45 J = KK + 1, KP - 1 + T = DCONJG( A( J, KK ) ) + A( J, KK ) = DCONJG( A( KP, J ) ) + A( KP, J ) = T + 45 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = DCONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( KK, KK ) ) + A( KK, KK ) = DBLE( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) +* (5) Swap row elements + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) ) + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of A now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* +* Handle division by a small number +* + IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / DBLE( A( K, K ) ) + CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL ZDSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = DBLE( A( K, K ) ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* D = |A21| + D = DLAPY2( DBLE( A( K+1, K ) ), + $ DIMAG( A( K+1, K ) ) ) + D11 = DBLE( A( K+1, K+1 ) ) / D + D22 = DBLE( A( K, K ) ) / D + D21 = A( K+1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) + WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*DCONJG( WK ) - + $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D + A( J, K+1 ) = WKP1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = CZERO + A( K+1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of ZHETF2_RK +* + END diff --git a/lapack-netlib/SRC/zhetrd.f b/lapack-netlib/SRC/zhetrd.f index c607484637..51c9fc2ec9 100644 --- a/lapack-netlib/SRC/zhetrd.f +++ b/lapack-netlib/SRC/zhetrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -192,10 +192,10 @@ * ===================================================================== SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhetrd_2stage.f b/lapack-netlib/SRC/zhetrd_2stage.f new file mode 100644 index 0000000000..4245b32057 --- /dev/null +++ b/lapack-netlib/SRC/zhetrd_2stage.f @@ -0,0 +1,337 @@ +*> \brief \b ZHETRD_2STAGE +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRD_2STAGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, +* HOUS2, LHOUS2, WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER VECT, UPLO +* INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), +* HOUS2( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRD_2STAGE reduces a complex Hermitian matrix A to real symmetric +*> tridiagonal form T by a unitary similarity transformation: +*> Q1**H Q2**H* A * Q2 * Q1 = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> in particular for the second stage (Band to +*> tridiagonal) and thus LHOUS2 is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate Q1 Q2 or to apply Q1 Q2, +*> then LHOUS2 is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the band superdiagonal +*> of A are overwritten by the corresponding elements of the +*> internal band-diagonal matrix AB, and the elements above +*> the KD superdiagonal, with the array TAU, represent the unitary +*> matrix Q1 as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and band subdiagonal of A are over- +*> written by the corresponding elements of the internal band-diagonal +*> matrix AB, and the elements below the KD subdiagonal, with +*> the array TAU, represent the unitary matrix Q1 as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-KD) +*> The scalar factors of the elementary reflectors of +*> the first stage (see Further Details). +*> \endverbatim +*> +*> \param[out] HOUS2 +*> \verbatim +*> HOUS2 is COMPLEX*16 array, dimension LHOUS2, that +*> store the Householder representation of the stage2 +*> band to tridiagonal. +*> \endverbatim +*> +*> \param[in] LHOUS2 +*> \verbatim +*> LHOUS2 is INTEGER +*> The dimension of the array HOUS2. LHOUS2 = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS2 array, returns +*> this value as the first entry of the HOUS2 array, and no error +*> message related to LHOUS2 is issued by XERBLA. +*> LHOUS2 = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS2=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = max(stage1,stage2) + (KD+1)*N +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) +*> + (KD+1)*N +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, + $ HOUS2, LHOUS2, WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER VECT, UPLO + INTEGER N, LDA, LWORK, LHOUS2, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), + $ HOUS2( * ), WORK( * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTQ + INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHETRD_HE2HB, ZHETRD_HB2ST +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + KD = ILAENV( 17, 'ZHETRD_2STAGE', VECT, N, -1, -1, -1 ) + IB = ILAENV( 18, 'ZHETRD_2STAGE', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'ZHETRD_2STAGE', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'ZHETRD_2STAGE', VECT, N, KD, IB, -1 ) +* WRITE(*,*),'ZHETRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, +* $ LHMIN, LWMIN +* + IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD_2STAGE', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDAB = KD+1 + LWRK = LWORK-LDAB*N + ABPOS = 1 + WPOS = ABPOS + LDAB*N + CALL ZHETRD_HE2HB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, + $ TAU, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD_HE2HB', -INFO ) + RETURN + END IF + CALL ZHETRD_HB2ST( 'Y', VECT, UPLO, N, KD, + $ WORK( ABPOS ), LDAB, D, E, + $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD_HB2ST', -INFO ) + RETURN + END IF +* +* + HOUS2( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of ZHETRD_2STAGE +* + END diff --git a/lapack-netlib/SRC/zhetrd_hb2st.F b/lapack-netlib/SRC/zhetrd_hb2st.F new file mode 100644 index 0000000000..d963d8c909 --- /dev/null +++ b/lapack-netlib/SRC/zhetrd_hb2st.F @@ -0,0 +1,587 @@ +*> \brief \b ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRD_HB2ST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRD_HB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, +* D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* #if defined(_OPENMP) +* use omp_lib +* #endif +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER STAGE1, UPLO, VECT +* INTEGER N, KD, IB, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* COMPLEX*16 AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric +*> tridiagonal form T by a unitary similarity transformation: +*> Q**H * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] STAGE +*> \verbatim +*> STAGE is CHARACTER*1 +*> = 'N': "No": to mention that the stage 1 of the reduction +*> from dense to band using the zhetrd_he2hb routine +*> was not called before this routine to reproduce AB. +*> In other term this routine is called as standalone. +*> = 'Y': "Yes": to mention that the stage 1 of the +*> reduction from dense to band using the zhetrd_he2hb +*> routine has been called to produce AB (e.g., AB is +*> the output of zhetrd_he2hb. +*> \endverbatim +*> +*> \param[in] VECT +*> \verbatim +*> VECT is CHARACTER*1 +*> = 'N': No need for the Housholder representation, +*> and thus LHOUS is of size max(1, 4*N); +*> = 'V': the Householder representation is needed to +*> either generate or to apply Q later on, +*> then LHOUS is to be queried and computed. +*> (NOT AVAILABLE IN THIS RELEASE). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the matrix A if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> \endverbatim +*> +*> \param[in,out] AB +*> \verbatim +*> AB is COMPLEX*16 array, dimension (LDAB,N) +*> On entry, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> On exit, the diagonal elements of AB are overwritten by the +*> diagonal elements of the tridiagonal matrix T; if KD > 0, the +*> elements on the first superdiagonal (if UPLO = 'U') or the +*> first subdiagonal (if UPLO = 'L') are overwritten by the +*> off-diagonal elements of T; the rest of AB is overwritten by +*> values generated during the reduction. +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the tridiagonal matrix T. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] HOUS +*> \verbatim +*> HOUS is COMPLEX*16 array, dimension LHOUS, that +*> store the Householder representation. +*> \endverbatim +*> +*> \param[in] LHOUS +*> \verbatim +*> LHOUS is INTEGER +*> The dimension of the array HOUS. LHOUS = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a query is assumed; the routine +*> only calculates the optimal size of the HOUS array, returns +*> this value as the first entry of the HOUS array, and no error +*> message related to LHOUS is issued by XERBLA. +*> LHOUS = MAX(1, dimension) where +*> dimension = 4*N if VECT='N' +*> not available now if VECT='H' +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK = MAX(1, dimension) +*> If LWORK = -1, or LHOUS=-1, +*> then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK = MAX(1, dimension) where +*> dimension = (2KD+1)*N + KD*NTHREADS +*> where KD is the blocking size of the reduction, +*> FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice +*> NTHREADS is the number of threads used when +*> openMP compilation is enabled, otherwise =1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHETRD_HB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, + $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) +* +* +#if defined(_OPENMP) + use omp_lib +#endif +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER STAGE1, UPLO, VECT + INTEGER N, KD, LDAB, LHOUS, LWORK, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 AB( LDAB, * ), HOUS( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RZERO + COMPLEX*16 ZERO, ONE + PARAMETER ( RZERO = 0.0D+0, + $ ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 + INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, + $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, + $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, + $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, + $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, + $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, + $ SIZEV, SIZETAU, LDV, LHMIN, LWMIN + DOUBLE PRECISION ABSTMP + COMPLEX*16 TMP +* .. +* .. External Subroutines .. + EXTERNAL ZHB2ST_KERNELS, ZLACPY, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX, CEILING, DBLE, REAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required. +* Test the input parameters +* + DEBUG = 0 + INFO = 0 + AFTERS1 = LSAME( STAGE1, 'Y' ) + WANTQ = LSAME( VECT, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) +* +* Determine the block size, the workspace size and the hous size. +* + IB = ILAENV( 18, 'ZHETRD_HB2ST', VECT, N, KD, -1, -1 ) + LHMIN = ILAENV( 19, 'ZHETRD_HB2ST', VECT, N, KD, IB, -1 ) + LWMIN = ILAENV( 20, 'ZHETRD_HB2ST', VECT, N, KD, IB, -1 ) +* + IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KD.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.(KD+1) ) THEN + INFO = -7 + ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD_HB2ST', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine pointer position +* + LDV = KD + IB + SIZETAU = 2 * N + SIZEV = 2 * N + INDTAU = 1 + INDV = INDTAU + SIZETAU + LDA = 2 * KD + 1 + SIZEA = LDA * N + INDA = 1 + INDW = INDA + SIZEA + NTHREADS = 1 + TID = 0 +* + IF( UPPER ) THEN + APOS = INDA + KD + AWPOS = INDA + DPOS = APOS + KD + OFDPOS = DPOS - 1 + ABDPOS = KD + 1 + ABOFDPOS = KD + ELSE + APOS = INDA + AWPOS = INDA + KD + 1 + DPOS = APOS + OFDPOS = DPOS + 1 + ABDPOS = 1 + ABOFDPOS = 2 + + ENDIF +* +* Case KD=0: +* The matrix is diagonal. We just copy it (convert to "real" for +* complex because D is double and the imaginary part should be 0) +* and store it in D. A sequential code here is better or +* in a parallel environment it might need two cores for D and E +* + IF( KD.EQ.0 ) THEN + DO 30 I = 1, N + D( I ) = DBLE( AB( ABDPOS, I ) ) + 30 CONTINUE + DO 40 I = 1, N-1 + E( I ) = RZERO + 40 CONTINUE +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Case KD=1: +* The matrix is already Tridiagonal. We have to make diagonal +* and offdiagonal elements real, and store them in D and E. +* For that, for real precision just copy the diag and offdiag +* to D and E while for the COMPLEX case the bulge chasing is +* performed to convert the hermetian tridiagonal to symmetric +* tridiagonal. A simpler coversion formula might be used, but then +* updating the Q matrix will be required and based if Q is generated +* or not this might complicate the story. +* + IF( KD.EQ.1 ) THEN + DO 50 I = 1, N + D( I ) = DBLE( AB( ABDPOS, I ) ) + 50 CONTINUE +* +* make off-diagonal elements real and copy them to E +* + IF( UPPER ) THEN + DO 60 I = 1, N - 1 + TMP = AB( ABOFDPOS, I+1 ) + ABSTMP = ABS( TMP ) + AB( ABOFDPOS, I+1 ) = ABSTMP + E( I ) = ABSTMP + IF( ABSTMP.NE.RZERO ) THEN + TMP = TMP / ABSTMP + ELSE + TMP = ONE + END IF + IF( I.LT.N-1 ) + $ AB( ABOFDPOS, I+2 ) = AB( ABOFDPOS, I+2 )*TMP +C IF( WANTZ ) THEN +C CALL ZSCAL( N, DCONJG( TMP ), Q( 1, I+1 ), 1 ) +C END IF + 60 CONTINUE + ELSE + DO 70 I = 1, N - 1 + TMP = AB( ABOFDPOS, I ) + ABSTMP = ABS( TMP ) + AB( ABOFDPOS, I ) = ABSTMP + E( I ) = ABSTMP + IF( ABSTMP.NE.RZERO ) THEN + TMP = TMP / ABSTMP + ELSE + TMP = ONE + END IF + IF( I.LT.N-1 ) + $ AB( ABOFDPOS, I+1 ) = AB( ABOFDPOS, I+1 )*TMP +C IF( WANTQ ) THEN +C CALL ZSCAL( N, TMP, Q( 1, I+1 ), 1 ) +C END IF + 70 CONTINUE + ENDIF +* + HOUS( 1 ) = 1 + WORK( 1 ) = 1 + RETURN + END IF +* +* Main code start here. +* Reduce the hermitian band of A to a tridiagonal matrix. +* + THGRSIZ = N + GRSIZ = 1 + SHIFT = 3 + NBTILES = CEILING( REAL(N)/REAL(KD) ) + STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) + THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) +* + CALL ZLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) + CALL ZLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) +* +* +* openMP parallelisation start here +* +#if defined(_OPENMP) +!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) +!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) +!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) +!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) +!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) +!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT ) +!$OMP MASTER +#endif +* +* main bulge chasing loop +* + DO 100 THGRID = 1, THGRNB + STT = (THGRID-1)*THGRSIZ+1 + THED = MIN( (STT + THGRSIZ -1), (N-1)) + DO 110 I = STT, N-1 + ED = MIN( I, THED ) + IF( STT.GT.ED ) EXIT + DO 120 M = 1, STEPERCOL + ST = STT + DO 130 SWEEPID = ST, ED + DO 140 K = 1, GRSIZ + MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) + $ + (M-1)*GRSIZ + K + IF ( MYID.EQ.1 ) THEN + TTYPE = 1 + ELSE + TTYPE = MOD( MYID, 2 ) + 2 + ENDIF + + IF( TTYPE.EQ.2 ) THEN + COLPT = (MYID/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + BLKLASTIND = COLPT + ELSE + COLPT = ((MYID+1)/2)*KD + SWEEPID + STIND = COLPT-KD+1 + EDIND = MIN(COLPT,N) + IF( ( STIND.GE.EDIND-1 ).AND. + $ ( EDIND.EQ.N ) ) THEN + BLKLASTIND = N + ELSE + BLKLASTIND = 0 + ENDIF + ENDIF +* +* Call the kernel +* +#if defined(_OPENMP) + IF( TTYPE.NE.1 ) THEN +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(in:WORK(MYID-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ELSE +!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) +!$OMP$ DEPEND(out:WORK(MYID)) + TID = OMP_GET_THREAD_NUM() + CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +!$OMP END TASK + ENDIF +#else + CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, + $ STIND, EDIND, SWEEPID, N, KD, IB, + $ WORK ( INDA ), LDA, + $ HOUS( INDV ), HOUS( INDTAU ), LDV, + $ WORK( INDW + TID*KD ) ) +#endif + IF ( BLKLASTIND.GE.(N-1) ) THEN + STT = STT + 1 + EXIT + ENDIF + 140 CONTINUE + 130 CONTINUE + 120 CONTINUE + 110 CONTINUE + 100 CONTINUE +* +#if defined(_OPENMP) +!$OMP END MASTER +!$OMP END PARALLEL +#endif +* +* Copy the diagonal from A to D. Note that D is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + DO 150 I = 1, N + D( I ) = DBLE( WORK( DPOS+(I-1)*LDA ) ) + 150 CONTINUE +* +* Copy the off diagonal from A to E. Note that E is REAL thus only +* the Real part is needed, the imaginary part should be zero. +* + IF( UPPER ) THEN + DO 160 I = 1, N-1 + E( I ) = DBLE( WORK( OFDPOS+I*LDA ) ) + 160 CONTINUE + ELSE + DO 170 I = 1, N-1 + E( I ) = DBLE( WORK( OFDPOS+(I-1)*LDA ) ) + 170 CONTINUE + ENDIF +* + HOUS( 1 ) = LHMIN + WORK( 1 ) = LWMIN + RETURN +* +* End of ZHETRD_HB2ST +* + END + diff --git a/lapack-netlib/SRC/zhetrd_he2hb.f b/lapack-netlib/SRC/zhetrd_he2hb.f new file mode 100644 index 0000000000..89fb1b8a53 --- /dev/null +++ b/lapack-netlib/SRC/zhetrd_he2hb.f @@ -0,0 +1,517 @@ +*> \brief \b ZHETRD_HE2HB +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRD_HE2HB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRD_HE2HB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, +* WORK, LWORK, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), AB( LDAB, * ), +* TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian +*> band-diagonal form AB by a unitary similarity transformation: +*> Q**H * A * Q = AB. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] KD +*> \verbatim +*> KD is INTEGER +*> The number of superdiagonals of the reduced matrix if UPLO = 'U', +*> or the number of subdiagonals if UPLO = 'L'. KD >= 0. +*> The reduced matrix is stored in the array AB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the unitary +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the unitary matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] AB +*> \verbatim +*> AB is COMPLEX*16 array, dimension (LDAB,N) +*> On exit, the upper or lower triangle of the Hermitian band +*> matrix A, stored in the first KD+1 rows of the array. The +*> j-th column of A is stored in the j-th column of the array AB +*> as follows: +*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; +*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). +*> \endverbatim +*> +*> \param[in] LDAB +*> \verbatim +*> LDAB is INTEGER +*> The leading dimension of the array AB. LDAB >= KD+1. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-KD) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK. +*> On exit, if INFO = 0, or if LWORK=-1, +*> WORK(1) returns the size of LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK which should be calculated +* by a workspace query. LWORK = MAX(1, LWORK_QUERY) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD +*> where FACTOPTNB is the blocking used by the QR or LQ +*> algorithm, usually FACTOPTNB=128 is a good choice otherwise +*> putting LWORK=-1 will provide the size of WORK. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Implemented by Azzam Haidar. +*> +*> All details are available on technical report, SC11, SC13 papers. +*> +*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. +*> Parallel reduction to condensed forms for symmetric eigenvalue problems +*> using aggregated fine-grained and memory-aware kernels. In Proceedings +*> of 2011 International Conference for High Performance Computing, +*> Networking, Storage and Analysis (SC '11), New York, NY, USA, +*> Article 8 , 11 pages. +*> http://doi.acm.org/10.1145/2063384.2063394 +*> +*> A. Haidar, J. Kurzak, P. Luszczek, 2013. +*> An improved parallel singular value algorithm and its implementation +*> for multicore hardware, In Proceedings of 2013 International Conference +*> for High Performance Computing, Networking, Storage and Analysis (SC '13). +*> Denver, Colorado, USA, 2013. +*> Article 90, 12 pages. +*> http://doi.acm.org/10.1145/2503210.2503292 +*> +*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> calculations based on fine-grained memory aware tasks. +*> International Journal of High Performance Computing Applications. +*> Volume 28 Issue 2, Pages 196-209, May 2014. +*> http://hpc.sagepub.com/content/28/2/196 +*> +*> \endverbatim +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in +*> A(i,i+kd+1:n), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = n-kd. +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in +* A(i+kd+2:n,i), and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( ab ab/v1 v1 v1 v1 ) ( ab ) +*> ( ab ab/v2 v2 v2 ) ( ab/v1 ab ) +*> ( ab ab/v3 v3 ) ( v1 ab/v2 ab ) +*> ( ab ab/v4 ) ( v1 v2 ab/v3 ab ) +*> ( ab ) ( v1 v2 v3 ab/v4 ab ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHETRD_HE2HB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, + $ WORK, LWORK, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDAB, LWORK, N, KD +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AB( LDAB, * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION RONE + COMPLEX*16 ZERO, ONE, HALF + PARAMETER ( RONE = 1.0D+0, + $ ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ), + $ HALF = ( 0.5D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, J, IINFO, LWMIN, PN, PK, LK, + $ LDT, LDW, LDS2, LDS1, + $ LS2, LS1, LW, LT, + $ TPOS, WPOS, S2POS, S1POS +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHER2K, ZHEMM, ZGEMM, + $ ZLARFT, ZGELQF, ZGEQRF, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN, MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Determine the minimal workspace size required +* and test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + LWMIN = ILAENV( 20, 'ZHETRD_HE2HB', '', N, KD, -1, -1 ) + + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KD.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN + INFO = -7 + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRD_HE2HB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWMIN + RETURN + END IF +* +* Quick return if possible +* Copy the upper/lower portion of A into AB +* + IF( N.LE.KD+1 ) THEN + IF( UPPER ) THEN + DO 100 I = 1, N + LK = MIN( KD+1, I ) + CALL ZCOPY( LK, A( I-LK+1, I ), 1, + $ AB( KD+1-LK+1, I ), 1 ) + 100 CONTINUE + ELSE + DO 110 I = 1, N + LK = MIN( KD+1, N-I+1 ) + CALL ZCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) + 110 CONTINUE + ENDIF + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the pointer position for the workspace +* + LDT = KD + LDS1 = KD + LT = LDT*KD + LW = N*KD + LS1 = LDS1*KD + LS2 = LWMIN - LT - LW - LS1 +* LS2 = N*MAX(KD,FACTOPTNB) + TPOS = 1 + WPOS = TPOS + LT + S1POS = WPOS + LW + S2POS = S1POS + LS1 + IF( UPPER ) THEN + LDW = KD + LDS2 = KD + ELSE + LDW = N + LDS2 = N + ENDIF +* +* +* Set the workspace of the triangular matrix T to zero once such a +* way everytime T is generated the upper/lower portion will be always zero +* + CALL ZLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) +* + IF( UPPER ) THEN + DO 10 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the LQ factorization of the current block +* + CALL ZGELQF( KD, PN, A( I, I+KD ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 20 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL ZCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 20 CONTINUE +* + CALL ZLASET( 'Lower', PK, PK, ZERO, ONE, + $ A( I, I+KD ), LDA ) +* +* Form the matrix T +* + CALL ZLARFT( 'Forward', 'Rowwise', PN, PK, + $ A( I, I+KD ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL ZGEMM( 'Conjugate', 'No transpose', PK, PN, PK, + $ ONE, WORK( TPOS ), LDT, + $ A( I, I+KD ), LDA, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL ZHEMM( 'Right', UPLO, PK, PN, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL ZGEMM( 'No transpose', 'Conjugate', PK, PK, PN, + $ ONE, WORK( WPOS ), LDW, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL ZGEMM( 'No transpose', 'No transpose', PK, PN, PK, + $ -HALF, WORK( S1POS ), LDS1, + $ A( I, I+KD ), LDA, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V'*W - W'*V +* + CALL ZHER2K( UPLO, 'Conjugate', PN, PK, + $ -ONE, A( I, I+KD ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) + 10 CONTINUE +* +* Copy the upper band to AB which is the band storage matrix +* + DO 30 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL ZCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) + 30 CONTINUE +* + ELSE +* +* Reduce the lower triangle of A to lower band matrix +* + DO 40 I = 1, N - KD, KD + PN = N-I-KD+1 + PK = MIN( N-I-KD+1, KD ) +* +* Compute the QR factorization of the current block +* + CALL ZGEQRF( PN, KD, A( I+KD, I ), LDA, + $ TAU( I ), WORK( S2POS ), LS2, IINFO ) +* +* Copy the upper portion of A into AB +* + DO 50 J = I, I+PK-1 + LK = MIN( KD, N-J ) + 1 + CALL ZCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 50 CONTINUE +* + CALL ZLASET( 'Upper', PK, PK, ZERO, ONE, + $ A( I+KD, I ), LDA ) +* +* Form the matrix T +* + CALL ZLARFT( 'Forward', 'Columnwise', PN, PK, + $ A( I+KD, I ), LDA, TAU( I ), + $ WORK( TPOS ), LDT ) +* +* Compute W: +* + CALL ZGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ ONE, A( I+KD, I ), LDA, + $ WORK( TPOS ), LDT, + $ ZERO, WORK( S2POS ), LDS2 ) +* + CALL ZHEMM( 'Left', UPLO, PN, PK, + $ ONE, A( I+KD, I+KD ), LDA, + $ WORK( S2POS ), LDS2, + $ ZERO, WORK( WPOS ), LDW ) +* + CALL ZGEMM( 'Conjugate', 'No transpose', PK, PK, PN, + $ ONE, WORK( S2POS ), LDS2, + $ WORK( WPOS ), LDW, + $ ZERO, WORK( S1POS ), LDS1 ) +* + CALL ZGEMM( 'No transpose', 'No transpose', PN, PK, PK, + $ -HALF, A( I+KD, I ), LDA, + $ WORK( S1POS ), LDS1, + $ ONE, WORK( WPOS ), LDW ) +* +* +* Update the unreduced submatrix A(i+kd:n,i+kd:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL ZHER2K( UPLO, 'No transpose', PN, PK, + $ -ONE, A( I+KD, I ), LDA, + $ WORK( WPOS ), LDW, + $ RONE, A( I+KD, I+KD ), LDA ) +* ================================================================== +* RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED +* DO 45 J = I, I+PK-1 +* LK = MIN( KD, N-J ) + 1 +* CALL ZCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) +* 45 CONTINUE +* ================================================================== + 40 CONTINUE +* +* Copy the lower band to AB which is the band storage matrix +* + DO 60 J = N-KD+1, N + LK = MIN(KD, N-J) + 1 + CALL ZCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) + 60 CONTINUE + + END IF +* + WORK( 1 ) = LWMIN + RETURN +* +* End of ZHETRD_HE2HB +* + END diff --git a/lapack-netlib/SRC/zhetrf.f b/lapack-netlib/SRC/zhetrf.f index a31eef06e6..3866abd73f 100644 --- a/lapack-netlib/SRC/zhetrf.f +++ b/lapack-netlib/SRC/zhetrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhetrf_aa.f b/lapack-netlib/SRC/zhetrf_aa.f new file mode 100644 index 0000000000..05844bb528 --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_aa.f @@ -0,0 +1,483 @@ +*> \brief \b ZHETRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRF_AA computes the factorization of a complex hermitian matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**H or A = L*T*L**H +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a hermitian tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N). For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +* ===================================================================== + SUBROUTINE ZHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = (0.0D+0, 0.0D+0), ONE = (1.0D+0, 0.0D+0) ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX*16 ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'ZHETRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + A( 1, 1 ) = DBLE( A( 1, 1 ) ) + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**H using the upper triangle of A +* ..................................................... +* +* copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLAHEF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = DCONJG( A( J, J+1 ) ) + A( J, J+1 ) = ONE + CALL ZCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMM( 'Conjugate transpose', 'Transpose', + $ 1, MJ, JB+1, + $ -ONE, A( J1-K2, J3 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with ZGEMM +* + CALL ZGEMM( 'Conjugate transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = DCONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**H using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLAHEF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = DCONJG( A( J+1, J ) ) + A( J+1, J ) = ONE + CALL ZCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ MJ, 1, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block column with ZGEMM +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = DCONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of ZHETRF_AA +* + END diff --git a/lapack-netlib/SRC/zhetrf_rk.f b/lapack-netlib/SRC/zhetrf_rk.f new file mode 100644 index 0000000000..42b829eaff --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b ZHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHETRF_RK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZLAHEF_RK, ZHETF2_RK, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'ZHETRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by ZLAHEF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL ZLAHEF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL ZHETF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL ZSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by ZLAHEF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL ZLAHEF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL ZHETF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL ZSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZHETRF_RK +* + END diff --git a/lapack-netlib/SRC/zhetrf_rook.f b/lapack-netlib/SRC/zhetrf_rook.f index 64e59aab58..afbad21c3f 100644 --- a/lapack-netlib/SRC/zhetrf_rook.f +++ b/lapack-netlib/SRC/zhetrf_rook.f @@ -150,7 +150,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date June 2016 * *> \ingroup complex16HEcomputational * @@ -199,7 +199,7 @@ *> *> \verbatim *> -*> November 2013, Igor Kozachenko, +*> June 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -212,10 +212,10 @@ * ===================================================================== SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -265,7 +265,7 @@ SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'ZHETRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * diff --git a/lapack-netlib/SRC/zhetri.f b/lapack-netlib/SRC/zhetri.f index 6a19da3d9c..020fe65d96 100644 --- a/lapack-netlib/SRC/zhetri.f +++ b/lapack-netlib/SRC/zhetri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhetri2.f b/lapack-netlib/SRC/zhetri2.f index 4659009f05..7e743a1262 100644 --- a/lapack-netlib/SRC/zhetri2.f +++ b/lapack-netlib/SRC/zhetri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE ZHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/zhetri2x.f b/lapack-netlib/SRC/zhetri2x.f index e8bc7be85b..169017221d 100644 --- a/lapack-netlib/SRC/zhetri2x.f +++ b/lapack-netlib/SRC/zhetri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -215,7 +215,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -231,7 +231,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -248,7 +248,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D WORK(K+1,INVD) = DCONJG (WORK(K,INVD+1) ) K=K+2 END IF @@ -265,7 +265,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -275,7 +275,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -338,7 +338,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**H*invD1*U11->U11 * CALL ZTRMM('L','U','C','U',NNB, NNB, @@ -382,7 +382,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -392,9 +392,9 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL ZHESWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL ZHESWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -408,7 +408,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -425,7 +425,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D WORK(K-1,INVD+1) = DCONJG (WORK(K,INVD+1) ) K=K-2 END IF @@ -442,7 +442,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -509,7 +509,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**H*invD1*L11->L11 * CALL ZTRMM('L',UPLO,'C','U',NNB, NNB, @@ -527,7 +527,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL ZGEMM('C','N',NNB,NNB,N-NNB-CUT,CONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**H*invD1*L11 + U01**H*invD*U01 * @@ -565,7 +565,7 @@ SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/zhetri_3.f b/lapack-netlib/SRC/zhetri_3.f new file mode 100644 index 0000000000..69d6e0b800 --- /dev/null +++ b/lapack-netlib/SRC/zhetri_3.f @@ -0,0 +1,248 @@ +*> \brief \b ZHETRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHETRI_3 computes the inverse of a complex Hermitian indefinite +*> matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZHETRI_3 sets the leading dimension of the workspace before calling +*> ZHETRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the Hermitian inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_RK or ZHETRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZHETRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'ZHETRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHETRI_3 +* + END diff --git a/lapack-netlib/SRC/zhetri_3x.f b/lapack-netlib/SRC/zhetri_3x.f new file mode 100644 index 0000000000..8be104cb92 --- /dev/null +++ b/lapack-netlib/SRC/zhetri_3x.f @@ -0,0 +1,649 @@ +*> \brief \b ZHETRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHETRI_3X computes the inverse of a complex Hermitian indefinite +*> matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the Hermitian inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_RK or ZHETRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + DOUBLE PRECISION AK, AKP1, T + COMPLEX*16 AKKP1, D, U01_I_J, U01_IP1_J, U11_I_J, + $ U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZHESWAPR, ZTRTRI, ZTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, DBLE, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**H) * inv(D) * inv(U) * P**T. +* + CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / DBLE( A( K, K ) ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = ABS( WORK( K+1, 1 ) ) + AK = DBLE( A( K, K ) ) / T + AKP1 = DBLE( A( K+1, K+1 ) ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = DCONJG( WORK( K, INVD+1 ) ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**H) = (inv(U))**H +* +* inv(U**H) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = CONE + DO J = 1, I-1 + WORK( U11+I, J ) = CZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**H * invD1 * U11 -> U11 +* + CALL ZTRMM( 'L', 'U', 'C', 'U', NNB, NNB, + $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**H * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL ZGEMM( 'C', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1), + $ N+NB+1 ) + +* +* U11 = U11**H * invD1 * U11 + U01**H * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**H * invD0 * U01 +* + CALL ZTRMM( 'L', UPLO, 'C', 'U', CUT, NNB, + $ CONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**H) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**H) * inv(D) * inv(L) * P**T. +* + CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = ONE / DBLE( A( K, K ) ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = ABS( WORK( K-1, 1 ) ) + AK = DBLE( A( K-1, K-1 ) ) / T + AKP1 = DBLE( A( K, K ) ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = DCONJG( WORK( K, INVD+1 ) ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**H) = (inv(L))**H +* +* inv(L**H) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = CONE + DO J = I+1, NNB + WORK( U11+I, J ) = CZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**H * invD1 * L11 -> L11 +* + CALL ZTRMM( 'L', UPLO, 'C', 'U', NNB, NNB, CONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**H * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL ZGEMM( 'C', 'N', NNB, NNB, N-NNB-CUT, CONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ CZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**H * invD1 * L11 + U01**H * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**H * invD2 * L21 +* + CALL ZTRMM( 'L', UPLO, 'C', 'U', N-NNB-CUT, NNB, CONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**H * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**H) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of ZHETRI_3X +* + END diff --git a/lapack-netlib/SRC/zhetrs.f b/lapack-netlib/SRC/zhetrs.f index 43a4998b5b..5af9542d4a 100644 --- a/lapack-netlib/SRC/zhetrs.f +++ b/lapack-netlib/SRC/zhetrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhetrs2.f b/lapack-netlib/SRC/zhetrs2.f index 15b460b448..77f60d4ba8 100644 --- a/lapack-netlib/SRC/zhetrs2.f +++ b/lapack-netlib/SRC/zhetrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,7 +101,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (N) +*> WORK is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] INFO @@ -114,23 +114,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== - SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -158,7 +158,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL ZLACGV, ZSCAL, ZSYCONV, ZSWAP, ZTRSM, XERBLA + EXTERNAL ZDSCAL, ZSYCONV, ZSWAP, ZTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG, MAX @@ -196,7 +196,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**H. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -221,7 +221,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL ZTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -274,7 +274,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**H. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -299,7 +299,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL ZTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -322,7 +322,7 @@ SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] -* +* CALL ZTRSM('L','L','C','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**H \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/zhetrs_3.f b/lapack-netlib/SRC/zhetrs_3.f new file mode 100644 index 0000000000..a73f51b418 --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_3.f @@ -0,0 +1,374 @@ +*> \brief \b ZHETRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZHETRS_3 solves a system of linear equations A * X = B with a complex +*> Hermitian matrix A using the factorization computed +*> by ZHETRF_RK or ZHETRF_BK: +*> +*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**H (or L**H) is the conjugate of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is Hermitian and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_RK or ZHETRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0,0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + DOUBLE PRECISION S + COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZSWAP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**H. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL ZTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + S = DBLE( ONE ) / DBLE( A( I, I ) ) + CALL ZDSCAL( NRHS, S, B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / DCONJG( AKM1K ) + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / DCONJG( AKM1K ) + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'U', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**H. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + S = DBLE( ONE ) / DBLE( A( I, I ) ) + CALL ZDSCAL( NRHS, S, B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / DCONJG( AKM1K ) + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / DCONJG( AKM1K ) + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] +* + CALL ZTRSM('L', 'L', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of ZHETRS_3 +* + END diff --git a/lapack-netlib/SRC/zhetrs_aa.f b/lapack-netlib/SRC/zhetrs_aa.f new file mode 100644 index 0000000000..044bf4cfa3 --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_aa.f @@ -0,0 +1,288 @@ +*> \brief \b ZHETRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRS_AA solves a system of linear equations A*X = B with a complex +*> hermitian matrix A using the factorization A = U*T*U**H or +*> A = L*T*L**T computed by ZHETRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**H; +*> = 'L': Lower triangular, form is A = L*T*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Details of factors computed by ZHETRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by ZHETRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +* ===================================================================== + SUBROUTINE ZHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX*16 ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGTSV, ZSWAP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL ZTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1) + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1) + CALL ZLACGV( N-1, WORK( 1 ), 1 ) + END IF + CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1) + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1) + CALL ZLACGV( N-1, WORK( 2*N ), 1 ) + END IF + CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of ZHETRS_AA +* + END diff --git a/lapack-netlib/SRC/zhfrk.f b/lapack-netlib/SRC/zhfrk.f index 3399706698..cfc3e111a1 100644 --- a/lapack-netlib/SRC/zhfrk.f +++ b/lapack-netlib/SRC/zhfrk.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHFRK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHFRK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, * C ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER K, LDA, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -168,10 +168,10 @@ SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, $ C ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/zhgeqz.f b/lapack-netlib/SRC/zhgeqz.f index 98d1fb06d2..b51cba4f72 100644 --- a/lapack-netlib/SRC/zhgeqz.f +++ b/lapack-netlib/SRC/zhgeqz.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHGEQZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHGEQZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, COMPZ, JOB * INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N @@ -32,7 +32,7 @@ * $ Q( LDQ, * ), T( LDT, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -44,18 +44,18 @@ *> using the single-shift QZ method. *> Matrix pairs of this type are produced by the reduction to *> generalized upper Hessenberg form of a complex matrix pair (A,B): -*> +*> *> A = Q1*H*Z1**H, B = Q1*T*Z1**H, -*> +*> *> as computed by ZGGHRD. -*> +*> *> If JOB='S', then the Hessenberg-triangular pair (H,T) is *> also reduced to generalized Schur form, -*> +*> *> H = Q*S*Z**H, T = Q*P*Z**H, -*> +*> *> where Q and Z are unitary matrices and S and P are upper triangular. -*> +*> *> Optionally, the unitary matrix Q from the generalized Schur *> factorization may be postmultiplied into an input matrix Q1, and the *> unitary matrix Z may be postmultiplied into an input matrix Z1. @@ -63,9 +63,9 @@ *> the matrix pair (A,B) to generalized Hessenberg form, then the output *> matrices Q1*Q and Z1*Z are the unitary factors from the generalized *> Schur factorization of (A,B): -*> +*> *> A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. -*> +*> *> To avoid overflow, eigenvalues of the matrix pair (H,T) *> (equivalently, of (A,B)) are computed as a pair of complex values *> (alpha,beta). If beta is nonzero, lambda = alpha / beta is an @@ -190,12 +190,12 @@ *> \param[in,out] Q *> \verbatim *> Q is COMPLEX*16 array, dimension (LDQ, N) -*> On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +*> On entry, if COMPQ = 'V', the unitary matrix Q1 used in the *> reduction of (A,B) to generalized Hessenberg form. -*> On exit, if COMPZ = 'I', the unitary matrix of left Schur -*> vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +*> On exit, if COMPQ = 'I', the unitary matrix of left Schur +*> vectors of (H,T), and if COMPQ = 'V', the unitary matrix of *> left Schur vectors of (A,B). -*> Not referenced if COMPZ = 'N'. +*> Not referenced if COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ @@ -261,10 +261,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -284,7 +284,7 @@ SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zhpcon.f b/lapack-netlib/SRC/zhpcon.f index 4b2058ddb3..dcf3231411 100644 --- a/lapack-netlib/SRC/zhpcon.f +++ b/lapack-netlib/SRC/zhpcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhpev.f b/lapack-netlib/SRC/zhpev.f index ecab968b83..2ac1c93736 100644 --- a/lapack-netlib/SRC/zhpev.f +++ b/lapack-netlib/SRC/zhpev.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -138,10 +138,10 @@ SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhpevd.f b/lapack-netlib/SRC/zhpevd.f index c2e9fcd73c..10b59c9377 100644 --- a/lapack-netlib/SRC/zhpevd.f +++ b/lapack-netlib/SRC/zhpevd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPEVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -188,12 +188,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -201,10 +201,10 @@ SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhpevx.f b/lapack-netlib/SRC/zhpevx.f index e804355671..7e32a3728c 100644 --- a/lapack-netlib/SRC/zhpevx.f +++ b/lapack-netlib/SRC/zhpevx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPEVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPEVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, * IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDZ, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -110,13 +113,17 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -219,12 +226,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHEReigen * @@ -233,10 +240,10 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO diff --git a/lapack-netlib/SRC/zhpgst.f b/lapack-netlib/SRC/zhpgst.f index cb83693488..cf2c51607e 100644 --- a/lapack-netlib/SRC/zhpgst.f +++ b/lapack-netlib/SRC/zhpgst.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), BP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhpgv.f b/lapack-netlib/SRC/zhpgv.f index 848279cc3c..c6a9a6a544 100644 --- a/lapack-netlib/SRC/zhpgv.f +++ b/lapack-netlib/SRC/zhpgv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -165,10 +165,10 @@ SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhpgvd.f b/lapack-netlib/SRC/zhpgvd.f index a12036ea8b..f0fad9ebab 100644 --- a/lapack-netlib/SRC/zhpgvd.f +++ b/lapack-netlib/SRC/zhpgvd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPGVD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHEReigen * @@ -231,10 +231,10 @@ SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO diff --git a/lapack-netlib/SRC/zhpgvx.f b/lapack-netlib/SRC/zhpgvx.f index 5495c00341..8e8ec13f4b 100644 --- a/lapack-netlib/SRC/zhpgvx.f +++ b/lapack-netlib/SRC/zhpgvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPGVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPGVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, * IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDZ, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION RWORK( * ), W( * ) * COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,13 +118,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -132,14 +136,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -249,12 +258,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHEReigen * @@ -268,10 +277,10 @@ SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO @@ -322,7 +331,7 @@ SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 - ELSE + ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) THEN INFO = -9 diff --git a/lapack-netlib/SRC/zhprfs.f b/lapack-netlib/SRC/zhprfs.f index 29dc3393aa..277a6e7500 100644 --- a/lapack-netlib/SRC/zhprfs.f +++ b/lapack-netlib/SRC/zhprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -180,10 +180,10 @@ SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhpsv.f b/lapack-netlib/SRC/zhpsv.f index d05a2f9ec2..37ca126d64 100644 --- a/lapack-netlib/SRC/zhpsv.f +++ b/lapack-netlib/SRC/zhpsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhpsvx.f b/lapack-netlib/SRC/zhpsvx.f index c34cade007..5dcb9f4fab 100644 --- a/lapack-netlib/SRC/zhpsvx.f +++ b/lapack-netlib/SRC/zhpsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zhptrd.f b/lapack-netlib/SRC/zhptrd.f index b844bbb5b7..a230e3dadc 100644 --- a/lapack-netlib/SRC/zhptrd.f +++ b/lapack-netlib/SRC/zhptrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ) * COMPLEX*16 AP( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -151,10 +151,10 @@ * ===================================================================== SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhptrf.f b/lapack-netlib/SRC/zhptrf.f index 53876b9a43..2fa2ee8ede 100644 --- a/lapack-netlib/SRC/zhptrf.f +++ b/lapack-netlib/SRC/zhptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -159,10 +159,10 @@ * ===================================================================== SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhptri.f b/lapack-netlib/SRC/zhptri.f index b58e1677b5..4df455d223 100644 --- a/lapack-netlib/SRC/zhptri.f +++ b/lapack-netlib/SRC/zhptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhptrs.f b/lapack-netlib/SRC/zhptrs.f index 76e01fdb22..71289d57c6 100644 --- a/lapack-netlib/SRC/zhptrs.f +++ b/lapack-netlib/SRC/zhptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zhsein.f b/lapack-netlib/SRC/zhsein.f index 57c99dbea6..652c7d7947 100644 --- a/lapack-netlib/SRC/zhsein.f +++ b/lapack-netlib/SRC/zhsein.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHSEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHSEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, * LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, * IFAILR, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EIGSRC, INITV, SIDE * INTEGER INFO, LDH, LDVL, LDVR, M, MM, N @@ -33,7 +33,7 @@ * COMPLEX*16 H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), * $ W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -221,12 +221,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -245,10 +245,10 @@ SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE diff --git a/lapack-netlib/SRC/zhseqr.f b/lapack-netlib/SRC/zhseqr.f index 994843688b..1e8134c39c 100644 --- a/lapack-netlib/SRC/zhseqr.f +++ b/lapack-netlib/SRC/zhseqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHSEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * CHARACTER COMPZ, JOB @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -211,12 +211,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -299,10 +299,10 @@ SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/zla_gbamv.f b/lapack-netlib/SRC/zla_gbamv.f index 0e38cf61f7..9d5291b88f 100644 --- a/lapack-netlib/SRC/zla_gbamv.f +++ b/lapack-netlib/SRC/zla_gbamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GBAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GBAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, * INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS @@ -29,7 +29,7 @@ * COMPLEX*16 AB( LDAB, * ), X( * ) * DOUBLE PRECISION Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -173,12 +173,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -186,10 +186,10 @@ SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, $ INCX, BETA, Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA @@ -400,7 +400,7 @@ SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, TEMP = CABS1( AB( KE-I+J, I ) ) SYMB_ZERO = SYMB_ZERO .AND. $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) - + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP JX = JX + INCX END DO @@ -412,9 +412,9 @@ SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, IY = IY + INCY END DO END IF - + END IF -* +* RETURN * * End of ZLA_GBAMV diff --git a/lapack-netlib/SRC/zla_gbrcond_c.f b/lapack-netlib/SRC/zla_gbrcond_c.f index 2b21daae26..20109124bc 100644 --- a/lapack-netlib/SRC/zla_gbrcond_c.f +++ b/lapack-netlib/SRC/zla_gbrcond_c.f @@ -2,27 +2,27 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GBRCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GBRCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, +* DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, * LDAB, AFB, LDAFB, IPIV, * C, CAPPLY, INFO, WORK, * RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CAPPLY @@ -32,8 +32,8 @@ * INTEGER IPIV( * ) * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) * DOUBLE PRECISION C( * ), RWORK( * ) -* -* +* +* * *> \par Purpose: * ============= @@ -148,25 +148,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, + DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, $ LDAB, AFB, LDAFB, IPIV, $ C, CAPPLY, INFO, WORK, $ RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zla_gbrcond_x.f b/lapack-netlib/SRC/zla_gbrcond_x.f index 10b7f6ab54..7e6c12ea5c 100644 --- a/lapack-netlib/SRC/zla_gbrcond_x.f +++ b/lapack-netlib/SRC/zla_gbrcond_x.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GBRCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GBRCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, * LDAB, AFB, LDAFB, IPIV, * X, INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO @@ -31,8 +31,8 @@ * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), * $ X( * ) * DOUBLE PRECISION RWORK( * ) -* -* +* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -155,10 +155,10 @@ DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, $ LDAB, AFB, LDAFB, IPIV, $ X, INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zla_gbrfsx_extended.f b/lapack-netlib/SRC/zla_gbrfsx_extended.f index 7707efd376..c95e48ba04 100644 --- a/lapack-netlib/SRC/zla_gbrfsx_extended.f +++ b/lapack-netlib/SRC/zla_gbrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GBRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GBRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * ERR_BNDS_COMP, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, * $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -394,12 +394,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -412,10 +412,10 @@ SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, diff --git a/lapack-netlib/SRC/zla_gbrpvgrw.f b/lapack-netlib/SRC/zla_gbrpvgrw.f index 20cac93643..b2ae02bf66 100644 --- a/lapack-netlib/SRC/zla_gbrpvgrw.f +++ b/lapack-netlib/SRC/zla_gbrpvgrw.f @@ -2,32 +2,32 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GBRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GBRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, * LDAB, AFB, LDAFB ) -* +* * .. Scalar Arguments .. * INTEGER N, KL, KU, NCOLS, LDAB, LDAFB * .. * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,12 +104,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBcomputational * @@ -117,10 +117,10 @@ DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, $ LDAB, AFB, LDAFB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N, KL, KU, NCOLS, LDAB, LDAFB diff --git a/lapack-netlib/SRC/zla_geamv.f b/lapack-netlib/SRC/zla_geamv.f index 845375e163..8d221691b2 100644 --- a/lapack-netlib/SRC/zla_geamv.f +++ b/lapack-netlib/SRC/zla_geamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, * Y, INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDA, M, N @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), X( * ) * DOUBLE PRECISION Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -175,10 +175,10 @@ SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, $ Y, INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/zla_gercond_c.f b/lapack-netlib/SRC/zla_gercond_c.f index 367d7902c7..e629f90e80 100644 --- a/lapack-netlib/SRC/zla_gercond_c.f +++ b/lapack-netlib/SRC/zla_gercond_c.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GERCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GERCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, +* DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, * LDAF, IPIV, C, CAPPLY, * INFO, WORK, RWORK ) -* +* * .. Scalar Aguments .. * CHARACTER TRANS * LOGICAL CAPPLY @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) * DOUBLE PRECISION C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,24 +129,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, + DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, $ LDAF, IPIV, C, CAPPLY, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Aguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zla_gercond_x.f b/lapack-netlib/SRC/zla_gercond_x.f index 44dc9ddc3f..244bf58a3b 100644 --- a/lapack-netlib/SRC/zla_gercond_x.f +++ b/lapack-netlib/SRC/zla_gercond_x.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GERCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GERCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, * LDAF, IPIV, X, INFO, * WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER N, LDA, LDAF, INFO @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * DOUBLE PRECISION RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -136,10 +136,10 @@ DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, $ LDAF, IPIV, X, INFO, $ WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zla_gerfsx_extended.f b/lapack-netlib/SRC/zla_gerfsx_extended.f index 4c1fd7829f..2382d6044a 100644 --- a/lapack-netlib/SRC/zla_gerfsx_extended.f +++ b/lapack-netlib/SRC/zla_gerfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -24,7 +24,7 @@ * ERRS_N, ERRS_C, RES, AYB, DY, * Y_TAIL, RCOND, ITHRESH, RTHRESH, * DZ_UB, IGNORE_CWISE, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ TRANS_TYPE, N_NORMS @@ -39,7 +39,7 @@ * DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), * $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -381,12 +381,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -398,10 +398,10 @@ SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, $ Y_TAIL, RCOND, ITHRESH, RTHRESH, $ DZ_UB, IGNORE_CWISE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/zla_gerpvgrw.f b/lapack-netlib/SRC/zla_gerpvgrw.f index aae5e6667e..a5f5174677 100644 --- a/lapack-netlib/SRC/zla_gerpvgrw.f +++ b/lapack-netlib/SRC/zla_gerpvgrw.f @@ -2,39 +2,39 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_GERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_GERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLA_GERPVGRW( N, NCOLS, A, LDA, AF, * LDAF ) -* +* * .. Scalar Arguments .. * INTEGER N, NCOLS, LDA, LDAF * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), AF( LDAF, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> ZLA_GERPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -61,7 +61,7 @@ *> *> \param[in] A *> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the N-by-N matrix A. *> \endverbatim *> @@ -73,7 +73,7 @@ *> *> \param[in] AF *> \verbatim -*> AF is DOUBLE PRECISION array, dimension (LDAF,N) +*> AF is COMPLEX*16 array, dimension (LDAF,N) *> The factors L and U from the factorization *> A = P*L*U as computed by ZGETRF. *> \endverbatim @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16GEcomputational * @@ -100,10 +100,10 @@ DOUBLE PRECISION FUNCTION ZLA_GERPVGRW( N, NCOLS, A, LDA, AF, $ LDAF ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER N, NCOLS, LDA, LDAF diff --git a/lapack-netlib/SRC/zla_heamv.f b/lapack-netlib/SRC/zla_heamv.f index 3729c8d706..1fa0e0a81b 100644 --- a/lapack-netlib/SRC/zla_heamv.f +++ b/lapack-netlib/SRC/zla_heamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_HEAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_HEAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDA, N, UPLO @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), X( * ) * DOUBLE PRECISION Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -178,10 +178,10 @@ SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/zla_hercond_c.f b/lapack-netlib/SRC/zla_hercond_c.f index 81dfebf895..61cfe95f10 100644 --- a/lapack-netlib/SRC/zla_hercond_c.f +++ b/lapack-netlib/SRC/zla_hercond_c.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_HERCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_HERCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, +* DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, * LDAF, IPIV, C, CAPPLY, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) * DOUBLE PRECISION C ( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,24 +126,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, + DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, $ LDAF, IPIV, C, CAPPLY, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_hercond_x.f b/lapack-netlib/SRC/zla_hercond_x.f index 0dd80dc6a1..9c19b487dd 100644 --- a/lapack-netlib/SRC/zla_hercond_x.f +++ b/lapack-netlib/SRC/zla_hercond_x.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_HERCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_HERCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, * LDAF, IPIV, X, INFO, * WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * DOUBLE PRECISION RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -133,10 +133,10 @@ DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, $ LDAF, IPIV, X, INFO, $ WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_herfsx_extended.f b/lapack-netlib/SRC/zla_herfsx_extended.f index fadd0d9530..e80a5910a9 100644 --- a/lapack-netlib/SRC/zla_herfsx_extended.f +++ b/lapack-netlib/SRC/zla_herfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_HERFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_HERFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,7 +41,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -398,10 +398,10 @@ SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/zla_herpvgrw.f b/lapack-netlib/SRC/zla_herpvgrw.f index e1fb5c4dc1..557d6e8308 100644 --- a/lapack-netlib/SRC/zla_herpvgrw.f +++ b/lapack-netlib/SRC/zla_herpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_HERPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_HERPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, * LDAF, IPIV, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -30,14 +30,14 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ) * DOUBLE PRECISION WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> ZLA_HERPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -104,18 +104,18 @@ *> *> \param[in] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension (2*N) +*> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16HEcomputational * @@ -123,10 +123,10 @@ DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, $ LDAF, IPIV, WORK ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -147,7 +147,7 @@ DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, COMPLEX*16 ZDUM * .. * .. External Functions .. - EXTERNAL LSAME, ZLASET + EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, DIMAG, MAX, MIN diff --git a/lapack-netlib/SRC/zla_lin_berr.f b/lapack-netlib/SRC/zla_lin_berr.f index 161eed970f..91be519399 100644 --- a/lapack-netlib/SRC/zla_lin_berr.f +++ b/lapack-netlib/SRC/zla_lin_berr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_LIN_BERR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_LIN_BERR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) -* +* * .. Scalar Arguments .. * INTEGER N, NZ, NRHS * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) * COMPLEX*16 RES( N, NRHS ) * .. -* +* * *> \par Purpose: * ============= @@ -67,7 +67,7 @@ *> *> \param[in] RES *> \verbatim -*> RES is DOUBLE PRECISION array, dimension (N,NRHS) +*> RES is COMPLEX*16 array, dimension (N,NRHS) *> The residual matrix, i.e., the matrix R in the relative backward *> error formula above. *> \endverbatim @@ -79,32 +79,32 @@ *> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B *> are from iterative refinement (see zla_gerfsx_extended.f). *> \endverbatim -*> +*> *> \param[out] BERR *> \verbatim -*> BERR is COMPLEX*16 array, dimension (NRHS) +*> BERR is DOUBLE PRECISION array, dimension (NRHS) *> The componentwise relative backward error from the formula above. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER N, NZ, NRHS diff --git a/lapack-netlib/SRC/zla_porcond_c.f b/lapack-netlib/SRC/zla_porcond_c.f index 1c82321cd7..a74295b417 100644 --- a/lapack-netlib/SRC/zla_porcond_c.f +++ b/lapack-netlib/SRC/zla_porcond_c.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_PORCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_PORCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, +* DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, * LDAF, C, CAPPLY, INFO, * WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) * DOUBLE PRECISION C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,24 +118,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, + DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, $ LDAF, C, CAPPLY, INFO, $ WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_porcond_x.f b/lapack-netlib/SRC/zla_porcond_x.f index 0a374cca6b..0b2c84f421 100644 --- a/lapack-netlib/SRC/zla_porcond_x.f +++ b/lapack-netlib/SRC/zla_porcond_x.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_PORCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_PORCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, * LDAF, X, INFO, WORK, * RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * DOUBLE PRECISION RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16POcomputational * @@ -125,10 +125,10 @@ DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, $ LDAF, X, INFO, WORK, $ RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_porfsx_extended.f b/lapack-netlib/SRC/zla_porfsx_extended.f index 40ffa9fca1..34a0ac58cb 100644 --- a/lapack-netlib/SRC/zla_porfsx_extended.f +++ b/lapack-netlib/SRC/zla_porfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_PORFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_PORFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -40,7 +40,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -372,12 +372,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16POcomputational * @@ -390,10 +390,10 @@ SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/zla_porpvgrw.f b/lapack-netlib/SRC/zla_porpvgrw.f index 682a670a9e..cd71635ec9 100644 --- a/lapack-netlib/SRC/zla_porpvgrw.f +++ b/lapack-netlib/SRC/zla_porpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_PORPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_PORPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, +* DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, * LDAF, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER NCOLS, LDA, LDAF @@ -29,14 +29,14 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ) * DOUBLE PRECISION WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> ZLA_PORPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -88,29 +88,29 @@ *> *> \param[in] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension (2*N) +*> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16POcomputational * * ===================================================================== - DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, + DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, $ LDAF, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -130,7 +130,7 @@ DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, COMPLEX*16 ZDUM * .. * .. External Functions .. - EXTERNAL LSAME, ZLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/zla_syamv.f b/lapack-netlib/SRC/zla_syamv.f index 43871dc594..01854a9ba9 100644 --- a/lapack-netlib/SRC/zla_syamv.f +++ b/lapack-netlib/SRC/zla_syamv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_SYAMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_SYAMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER INCX, INCY, LDA, N @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), X( * ) * DOUBLE PRECISION Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -179,10 +179,10 @@ SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA diff --git a/lapack-netlib/SRC/zla_syrcond_c.f b/lapack-netlib/SRC/zla_syrcond_c.f index 2cd65e922e..be9d14bd00 100644 --- a/lapack-netlib/SRC/zla_syrcond_c.f +++ b/lapack-netlib/SRC/zla_syrcond_c.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_SYRCOND_C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_SYRCOND_C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, * LDAF, IPIV, C, CAPPLY, * INFO, WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * LOGICAL CAPPLY @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) * DOUBLE PRECISION C( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -140,10 +140,10 @@ DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, $ LDAF, IPIV, C, CAPPLY, $ INFO, WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_syrcond_x.f b/lapack-netlib/SRC/zla_syrcond_x.f index 20cd0fd62a..2d02690923 100644 --- a/lapack-netlib/SRC/zla_syrcond_x.f +++ b/lapack-netlib/SRC/zla_syrcond_x.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_SYRCOND_X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_SYRCOND_X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, * LDAF, IPIV, X, INFO, * WORK, RWORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N, LDA, LDAF, INFO @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) * DOUBLE PRECISION RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -133,10 +133,10 @@ DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, $ LDAF, IPIV, X, INFO, $ WORK, RWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zla_syrfsx_extended.f b/lapack-netlib/SRC/zla_syrfsx_extended.f index 2f4966fd56..0091e81331 100644 --- a/lapack-netlib/SRC/zla_syrfsx_extended.f +++ b/lapack-netlib/SRC/zla_syrfsx_extended.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_SYRFSX_EXTENDED + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_SYRFSX_EXTENDED + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -25,7 +25,7 @@ * AYB, DY, Y_TAIL, RCOND, ITHRESH, * RTHRESH, DZ_UB, IGNORE_CWISE, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, * $ N_NORMS, ITHRESH @@ -41,7 +41,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -380,12 +380,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -398,10 +398,10 @@ SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, $ RTHRESH, DZ_UB, IGNORE_CWISE, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, diff --git a/lapack-netlib/SRC/zla_syrpvgrw.f b/lapack-netlib/SRC/zla_syrpvgrw.f index 5359ca9bd5..ccf4fc2d66 100644 --- a/lapack-netlib/SRC/zla_syrpvgrw.f +++ b/lapack-netlib/SRC/zla_syrpvgrw.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_SYRPVGRW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_SYRPVGRW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, * LDAF, IPIV, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER*1 UPLO * INTEGER N, INFO, LDA, LDAF @@ -30,14 +30,14 @@ * DOUBLE PRECISION WORK( * ) * INTEGER IPIV( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> +*> *> ZLA_SYRPVGRW computes the reciprocal pivot growth factor *> norm(A)/norm(U). The "max absolute element" norm is used. If this is *> much less than 1, the stability of the LU factorization of the @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -123,10 +123,10 @@ DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, $ LDAF, IPIV, WORK ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*1 UPLO @@ -150,7 +150,7 @@ DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, INTRINSIC ABS, REAL, DIMAG, MAX, MIN * .. * .. External Subroutines .. - EXTERNAL LSAME, ZLASET + EXTERNAL LSAME LOGICAL LSAME * .. * .. Statement Functions .. diff --git a/lapack-netlib/SRC/zla_wwaddw.f b/lapack-netlib/SRC/zla_wwaddw.f index 2cd9aef9a5..b4f9df3328 100644 --- a/lapack-netlib/SRC/zla_wwaddw.f +++ b/lapack-netlib/SRC/zla_wwaddw.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLA_WWADDW + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLA_WWADDW + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLA_WWADDW( N, X, Y, W ) -* +* * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * COMPLEX*16 X( * ), Y( * ), W( * ) * .. -* +* * *> \par Purpose: * ============= @@ -69,22 +69,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLA_WWADDW( N, X, Y, W ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/SRC/zlabrd.f b/lapack-netlib/SRC/zlabrd.f index 24fa76ba33..07b5e9fcf0 100644 --- a/lapack-netlib/SRC/zlabrd.f +++ b/lapack-netlib/SRC/zlabrd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLABRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), * $ Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -212,10 +212,10 @@ SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB diff --git a/lapack-netlib/SRC/zlacgv.f b/lapack-netlib/SRC/zlacgv.f index 315c4de5ce..1e3ca6e73f 100644 --- a/lapack-netlib/SRC/zlacgv.f +++ b/lapack-netlib/SRC/zlacgv.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACGV( N, X, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * .. * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,22 +62,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/zlacn2.f b/lapack-netlib/SRC/zlacn2.f index 391546f400..9d92773efc 100644 --- a/lapack-netlib/SRC/zlacn2.f +++ b/lapack-netlib/SRC/zlacn2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST @@ -28,7 +28,7 @@ * INTEGER ISAVE( 3 ) * COMPLEX*16 V( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -70,7 +70,7 @@ *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to ZLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -91,12 +91,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -133,10 +133,10 @@ * ===================================================================== SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/zlacon.f b/lapack-netlib/SRC/zlacon.f index f1d36c08b3..c7c2f5f202 100644 --- a/lapack-netlib/SRC/zlacon.f +++ b/lapack-netlib/SRC/zlacon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACON( N, V, X, EST, KASE ) -* +* * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 V( N ), X( N ) * .. -* +* * *> \par Purpose: * ============= @@ -69,7 +69,7 @@ *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and JUMP = 3, EST should be *> unchanged from the previous call to ZLACON. -*> On exit, EST is an estimate (a lower bound) for norm(A). +*> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE ZLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KASE, N diff --git a/lapack-netlib/SRC/zlacp2.f b/lapack-netlib/SRC/zlacp2.f index 1593af3c1c..647e82a3a1 100644 --- a/lapack-netlib/SRC/zlacp2.f +++ b/lapack-netlib/SRC/zlacp2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION A( LDA, * ) * COMPLEX*16 B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlacpy.f b/lapack-netlib/SRC/zlacpy.f index 73f0e57042..81932b8870 100644 --- a/lapack-netlib/SRC/zlacpy.f +++ b/lapack-netlib/SRC/zlacpy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlacrm.f b/lapack-netlib/SRC/zlacrm.f index 6e4ffe4c85..a3f919d0e1 100644 --- a/lapack-netlib/SRC/zlacrm.f +++ b/lapack-netlib/SRC/zlacrm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACRM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACRM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, M, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION B( LDB, * ), RWORK( * ) * COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,7 +61,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA, N) -*> A contains the M by N matrix A. +*> On entry, A contains the M by N matrix A. *> \endverbatim *> *> \param[in] LDA @@ -73,7 +73,7 @@ *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) -*> B contains the N by N matrix B. +*> On entry, B contains the N by N matrix B. *> \endverbatim *> *> \param[in] LDB @@ -82,10 +82,10 @@ *> The leading dimension of the array B. LDB >=max(1,N). *> \endverbatim *> -*> \param[in] C +*> \param[out] C *> \verbatim *> C is COMPLEX*16 array, dimension (LDC, N) -*> C contains the M by N matrix C. +*> On exit, C contains the M by N matrix C. *> \endverbatim *> *> \param[in] LDC @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, M, N diff --git a/lapack-netlib/SRC/zlacrt.f b/lapack-netlib/SRC/zlacrt.f index 922509a684..3e849986cc 100644 --- a/lapack-netlib/SRC/zlacrt.f +++ b/lapack-netlib/SRC/zlacrt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLACRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLACRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * COMPLEX*16 C, S @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/zladiv.f b/lapack-netlib/SRC/zladiv.f index 8f01fe3e63..0bf6ea87d5 100644 --- a/lapack-netlib/SRC/zladiv.f +++ b/lapack-netlib/SRC/zladiv.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* +* * .. Scalar Arguments .. * COMPLEX*16 X, Y * .. -* +* * *> \par Purpose: * ============= @@ -52,22 +52,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== COMPLEX*16 FUNCTION ZLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 X, Y diff --git a/lapack-netlib/SRC/zlaed0.f b/lapack-netlib/SRC/zlaed0.f index f10185bf5f..92672456fa 100644 --- a/lapack-netlib/SRC/zlaed0.f +++ b/lapack-netlib/SRC/zlaed0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAED0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDQ, LDQS, N, QSIZ * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION D( * ), E( * ), RWORK( * ) * COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -145,10 +145,10 @@ SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDQ, LDQS, N, QSIZ diff --git a/lapack-netlib/SRC/zlaed7.f b/lapack-netlib/SRC/zlaed7.f index ae6e9a36a4..90416af8e9 100644 --- a/lapack-netlib/SRC/zlaed7.f +++ b/lapack-netlib/SRC/zlaed7.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAED7 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, * GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, * $ TLVLS @@ -34,7 +34,7 @@ * DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) * COMPLEX*16 Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,7 +57,7 @@ *> *> The first stage consists of deflating the size of the problem *> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurence the dimension of the +*> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLAED2. *> @@ -234,12 +234,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -249,10 +249,10 @@ SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, diff --git a/lapack-netlib/SRC/zlaed8.f b/lapack-netlib/SRC/zlaed8.f index 6716b1720c..48057270ee 100644 --- a/lapack-netlib/SRC/zlaed8.f +++ b/lapack-netlib/SRC/zlaed8.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAED8 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, * Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, * GIVCOL, GIVNUM, INFO ) -* +* * .. Scalar Arguments .. * INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ * DOUBLE PRECISION RHO @@ -33,7 +33,7 @@ * $ Z( * ) * COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) * .. -* +* * *> \par Purpose: * ============= @@ -214,12 +214,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -228,10 +228,10 @@ SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, $ GIVCOL, GIVNUM, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ @@ -291,8 +291,8 @@ SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, END IF * * Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed +* to prevent an unspecified code behavior (usually sigfault) +* when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 diff --git a/lapack-netlib/SRC/zlaein.f b/lapack-netlib/SRC/zlaein.f index 5ce96cff67..0376e60b2c 100644 --- a/lapack-netlib/SRC/zlaein.f +++ b/lapack-netlib/SRC/zlaein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, * EPS3, SMLNUM, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL NOINIT, RIGHTV * INTEGER INFO, LDB, LDH, N @@ -31,7 +31,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 B( LDB, * ), H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -149,10 +149,10 @@ SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, $ EPS3, SMLNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL NOINIT, RIGHTV diff --git a/lapack-netlib/SRC/zlaesy.f b/lapack-netlib/SRC/zlaesy.f index 3a42ff6acf..2ff9b3530e 100644 --- a/lapack-netlib/SRC/zlaesy.f +++ b/lapack-netlib/SRC/zlaesy.f @@ -2,28 +2,28 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAESY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAESY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) -* +* * .. Scalar Arguments .. * COMPLEX*16 A, B, C, CS1, EVSCAL, RT1, RT2, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 A, B, C, CS1, EVSCAL, RT1, RT2, SN1 diff --git a/lapack-netlib/SRC/zlaev2.f b/lapack-netlib/SRC/zlaev2.f index 502dbfa814..d93dd605af 100644 --- a/lapack-netlib/SRC/zlaev2.f +++ b/lapack-netlib/SRC/zlaev2.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAEV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS1, RT1, RT2 * COMPLEX*16 A, B, C, SN1 * .. -* +* * *> \par Purpose: * ============= @@ -90,12 +90,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -121,10 +121,10 @@ * ===================================================================== SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS1, RT1, RT2 diff --git a/lapack-netlib/SRC/zlag2c.f b/lapack-netlib/SRC/zlag2c.f index a8c1ce1fbd..f1fc59a5e1 100644 --- a/lapack-netlib/SRC/zlag2c.f +++ b/lapack-netlib/SRC/zlag2c.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAG2C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAG2C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDSA, M, N * .. @@ -27,7 +27,7 @@ * COMPLEX SA( LDSA, * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -38,7 +38,7 @@ *> *> RMAX is the overflow for the SINGLE PRECISION arithmetic *> ZLAG2C checks that all the entries of A are between -RMAX and -*> RMAX. If not the convertion is aborted and a flag is raised. +*> RMAX. If not the conversion is aborted and a flag is raised. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDSA, M, N diff --git a/lapack-netlib/SRC/zlags2.f b/lapack-netlib/SRC/zlags2.f index 4c59246cb6..d00cd4e950 100644 --- a/lapack-netlib/SRC/zlags2.f +++ b/lapack-netlib/SRC/zlags2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, * SNV, CSQ, SNQ ) -* +* * .. Scalar Arguments .. * LOGICAL UPPER * DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV * COMPLEX*16 A2, B2, SNQ, SNU, SNV * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -158,10 +158,10 @@ SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL UPPER @@ -176,8 +176,8 @@ SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB12, AVB11, - $ AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, + DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB12, AVB11, + $ AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, $ SNL, SNR, UA11R, UA22R, VB11R, VB22R COMPLEX*16 B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11, $ VB12, VB21, VB22 diff --git a/lapack-netlib/SRC/zlagtm.f b/lapack-netlib/SRC/zlagtm.f index a02ce734ca..5c3e99abe6 100644 --- a/lapack-netlib/SRC/zlagtm.f +++ b/lapack-netlib/SRC/zlagtm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAGTM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAGTM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -145,10 +145,10 @@ SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/zlahef.f b/lapack-netlib/SRC/zlahef.f index 36b9b73ce9..0c8484d8e2 100644 --- a/lapack-netlib/SRC/zlahef.f +++ b/lapack-netlib/SRC/zlahef.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAHEF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAHEF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -155,12 +155,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16HEcomputational * @@ -169,7 +169,7 @@ *> *> \verbatim *> -*> November 2013, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> \endverbatim @@ -177,10 +177,10 @@ * ===================================================================== SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlahef_aa.f b/lapack-netlib/SRC/zlahef_aa.f new file mode 100644 index 0000000000..5698ba0576 --- /dev/null +++ b/lapack-netlib/SRC/zlahef_aa.f @@ -0,0 +1,513 @@ +*> \brief \b ZLAHEF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHEF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHEF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAHEF_AA factorizes a panel of a complex hermitian matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by ZHETRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +* ===================================================================== + SUBROUTINE ZLAHEF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = (0.0D+0, 0.0D+0), ONE = (1.0D+0, 0.0D+0) ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX*16 PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from ZHETRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZLACGV( J-K1, A( 1, J ), 1 ) + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + CALL ZLACGV( J-K1, A( 1, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -DCONJG( A( K-1, J ) ) + CALL ZAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = DBLE( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL ZAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) + CALL ZLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA ) + CALL ZLACGV( I2-I1-1, A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL ZSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + END IF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL ZCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL ZSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL ZLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from ZHETRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZLACGV( J-K1, A( J, 1 ), LDA ) + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + CALL ZLACGV( J-K1, A( J, 1 ), LDA ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -DCONJG( A( J, K-1 ) ) + CALL ZAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = DBLE( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL ZAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) + CALL ZLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 ) + CALL ZLACGV( I2-I1-1, A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL ZSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL ZCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL ZSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL ZLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M) + $ .AND. (INFO.EQ.0) ) INFO = J + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of ZLAHEF_AA +* + END diff --git a/lapack-netlib/SRC/zlahef_rk.f b/lapack-netlib/SRC/zlahef_rk.f new file mode 100644 index 0000000000..d8d54f4ce4 --- /dev/null +++ b/lapack-netlib/SRC/zlahef_rk.f @@ -0,0 +1,1234 @@ +*> \brief \b ZLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHEF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZLAHEF_RK computes a partial factorization of a complex Hermitian +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> ZLAHEF_RK is an auxiliary routine called by ZHETRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), W( LDW, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, K, KK, KKW, + $ KP, KSTEP, KW, P + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T, + $ SFMIN + COMPLEX*16 D11, D21, D22, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 (note that conjg(W) is actually stored) +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + IF( K.GT.1 ) + $ CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = DBLE( A( K, K ) ) + IF( K.LT.N ) THEN + CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) + W( K, KW ) = DBLE( W( K, KW ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( W( K, KW ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( W( K, KW ) ) + IF( K.GT.1 ) + $ CALL ZCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* +* Lop until pivot found +* + DONE = .FALSE. +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + IF( IMAX.GT.1 ) + $ CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), + $ 1 ) + W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) ) +* + CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) THEN + CALL ZGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) + W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( W( IMAX,KW-1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* +* Interchange rows and columns P and K. +* Updated column P is already stored in column KW of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P of submatrix A +* at step K. No need to copy element into columns +* K and K-1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = DBLE( A( K, K ) ) + CALL ZCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + CALL ZLACGV( K-1-P, A( P, P+1 ), LDA ) + IF( P.GT.1 ) + $ CALL ZCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in the last K+1 to N columns of A +* (columns K and K-1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) + CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), + $ LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = DBLE( A( KK, KK ) ) + CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) + IF( KP.GT.1 ) + $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) + CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column kw of W now holds +* +* W(kw) = U(k)*D(k), +* +* where U(k) is the k-th column of U +* +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = DBLE( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE + DO 14 II = 1, K-1 + A( II, K ) = A( II, K ) / T + 14 CONTINUE + END IF +* +* (2) Conjugate column W(kw) +* + CALL ZLACGV( K-1, W( 1, KW ), 1 ) +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold +* +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) +* + IF( K.GT.2 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / DCONJG( D21 ) + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( DBLE( D11*D22 )-ONE ) +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = CZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = CZERO +* +* (2) Conjugate columns W(kw) and W(kw-1) +* + CALL ZLACGV( K-1, W( 1, KW ), 1 ) + CALL ZLACGV( K-2, W( 1, KW-1 ), 1 ) +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**H = A11 - U12*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 (note that conjg(W) is actually stored) +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update column K of W +* + W( K, K ) = DBLE( A( K, K ) ) + IF( K.LT.N ) + $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + IF( K.GT.1 ) THEN + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) + W( K, K ) = DBLE( W( K, K ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( W( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( W( K, K ) ) + IF( K.LT.N ) + $ CALL ZCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column k+1 of W and update it +* + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) ) +* + IF( IMAX.LT.N ) + $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, + $ W( IMAX+1, K+1 ), 1 ) +* + IF( K.GT.1 ) THEN + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = CABS1( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( W( IMAX,K+1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* +* End pivot search loop body +* + IF( .NOT.DONE ) GOTO 72 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* Interchange rows and columns P and K (only for 2-by-2 pivot). +* Updated column P is already stored in column K of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column KK-1 to column P of submatrix A +* at step K. No need to copy element into columns +* K and K+1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = DBLE( A( K, K ) ) + CALL ZCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + CALL ZLACGV( P-K-1, A( P, K+1 ), LDA ) + IF( P.LT.N ) + $ CALL ZCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* +* Interchange rows K and P in first K-1 columns of A +* (columns K and K+1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = DBLE( A( KK, KK ) ) + CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) + IF( KP.LT.N ) + $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* +* Interchange rows KK and KP in first K-1 columns of A +* (column K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = DBLE( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / T + 74 CONTINUE + END IF +* +* (2) Conjugate column W(k) +* + CALL ZLACGV( N-K, W( K+1, K ), 1 ) +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored. +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) +* + IF( K.LT.N-1 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / DCONJG( D21 ) + T = ONE / ( DBLE( D11*D22 )-ONE ) +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = CZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = CZERO +* +* (2) Conjugate columns W(k) and W(k+1) +* + CALL ZLACGV( N-K, W( K+1, K ), 1 ) + CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**H = A22 - L21*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of ZLAHEF_RK +* + END diff --git a/lapack-netlib/SRC/zlahqr.f b/lapack-netlib/SRC/zlahqr.f index e554f8a037..19015b3fa3 100644 --- a/lapack-netlib/SRC/zlahqr.f +++ b/lapack-netlib/SRC/zlahqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAHQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -166,12 +166,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N @@ -313,7 +313,7 @@ SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * * ITMAX is the total number of QR iterations allowed. * - ITMAX = 30 * MAX( 10, NH ) + ITMAX = 30 * MAX( 10, NH ) * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works diff --git a/lapack-netlib/SRC/zlahr2.f b/lapack-netlib/SRC/zlahr2.f index ed64243b6a..063b515c46 100644 --- a/lapack-netlib/SRC/zlahr2.f +++ b/lapack-netlib/SRC/zlahr2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAHR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. @@ -27,7 +27,7 @@ * COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -181,10 +181,10 @@ * ===================================================================== SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -198,7 +198,7 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Parameters .. COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. @@ -226,10 +226,10 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Update I-th column of A - Y * V**H * - CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) - CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) * * Apply I - V * T**H * V**H to this column (call it b) from the * left, using the last column of T as workspace @@ -242,31 +242,31 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * w := V1**H * b1 * CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**H * b2 * - CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**H * w * - CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * - CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * - CALL ZTRMV( 'Lower', 'NO TRANSPOSE', + CALL ZTRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) @@ -284,13 +284,13 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * Compute Y(K+1:N,I) * - CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) @@ -298,7 +298,7 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute T(1:I,I) * CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) @@ -309,15 +309,15 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * Compute Y(1:K,1:NB) * CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) - $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) - CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * diff --git a/lapack-netlib/SRC/zlaic1.f b/lapack-netlib/SRC/zlaic1.f index 14b6f126c9..1000922201 100644 --- a/lapack-netlib/SRC/zlaic1.f +++ b/lapack-netlib/SRC/zlaic1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAIC1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAIC1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) -* +* * .. Scalar Arguments .. * INTEGER J, JOB * DOUBLE PRECISION SEST, SESTPR @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 W( J ), X( J ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER J, JOB diff --git a/lapack-netlib/SRC/zlals0.f b/lapack-netlib/SRC/zlals0.f index 13da3c3ef4..1946ad9c00 100644 --- a/lapack-netlib/SRC/zlals0.f +++ b/lapack-netlib/SRC/zlals0.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLALS0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLALS0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, * $ LDGNUM, NL, NR, NRHS, SQRE @@ -34,7 +34,7 @@ * $ RWORK( * ), Z( * ) * COMPLEX*16 B( LDB, * ), BX( LDBX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -249,12 +249,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -270,10 +270,10 @@ SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, diff --git a/lapack-netlib/SRC/zlalsa.f b/lapack-netlib/SRC/zlalsa.f index 9cd7a1844f..6ad6cc5efe 100644 --- a/lapack-netlib/SRC/zlalsa.f +++ b/lapack-netlib/SRC/zlalsa.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLALSA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLALSA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, * GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, * $ SMLSIZ @@ -35,7 +35,7 @@ * $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * ) * COMPLEX*16 B( LDB, * ), BX( LDBX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -246,12 +246,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -268,10 +268,10 @@ SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, diff --git a/lapack-netlib/SRC/zlalsd.f b/lapack-netlib/SRC/zlalsd.f index 592af30634..372b382233 100644 --- a/lapack-netlib/SRC/zlalsd.f +++ b/lapack-netlib/SRC/zlalsd.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLALSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLALSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, * RANK, WORK, RWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ @@ -31,7 +31,7 @@ * DOUBLE PRECISION D( * ), E( * ), RWORK( * ) * COMPLEX*16 B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, RWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlamswlq.f b/lapack-netlib/SRC/zlamswlq.f new file mode 100644 index 0000000000..8068114b8a --- /dev/null +++ b/lapack-netlib/SRC/zlamswlq.f @@ -0,0 +1,417 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAMQRTS overwrites the general real M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> where Q is a real orthogonal matrix defined as the product of blocked +*> elementary reflectors computed by short wide LQ +*> factorization (ZLASWLQ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> M >= K >= 0; +*> +*> \endverbatim +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > M. +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the blocked +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DLASWLQ in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension +*> ( M * Number of blocks(CEIL(N-K/NB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,NB) * MB; +*> if SIDE = 'R', LWORK >= max(1,M) * MB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC, LW +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL ZTPMLQT, ZGEMLQT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * MB + ELSE + LW = M * MB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, MB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAMSWLQ', -INFO ) + WORK(1) = LW + RETURN + ELSE IF (LQUERY) THEN + WORK(1) = LW + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((NB.LE.K).OR.(NB.GE.MAX(M,N,K))) THEN + CALL ZGEMLQT( SIDE, TRANS, M, N, K, MB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(NB-K)) + CTR = (M-K)/(NB-K) +* + IF (KK.GT.0) THEN + II=M-KK+1 + CALL ZTPMLQT('L','C',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1,CTR*K+1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+NB) +* + CTR = CTR - 1 + CALL ZTPMLQT('L','C',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1,CTR*K+1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:NB) +* + CALL ZGEMLQT('L','C',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(NB-K)) + II=M-KK+1 + CTR = 1 + CALL ZGEMLQT('L','N',NB , N, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (I:I+NB,1:N) +* + CALL ZTPMLQT('L','N',NB-K , N, K, 0,MB, A(1,I), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL ZTPMLQT('L','N',KK , N, K, 0, MB, A(1,II), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(NB-K)) + CTR = (N-K)/(NB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL ZTPMLQT('R','N',M , KK, K, 0, MB, A(1, II), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(NB-K),NB+1,-(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL ZTPMLQT('R','N', M, NB-K, K, 0, MB, A(1, I), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL ZGEMLQT('R','N',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(NB-K)) + II=N-KK+1 + CALL ZGEMLQT('R','C',M , NB, K, MB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) + CTR = 1 +* + DO I=NB+1,II-NB+K,(NB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL ZTPMLQT('R','C',M , NB-K, K, 0,MB, A(1,I), LDA, + $ T(1,CTR *K+1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL ZTPMLQT('R','C',M , KK, K, 0,MB, A(1,II), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of ZLAMSWLQ +* + END diff --git a/lapack-netlib/SRC/zlamtsqr.f b/lapack-netlib/SRC/zlamtsqr.f new file mode 100644 index 0000000000..855083a6f2 --- /dev/null +++ b/lapack-netlib/SRC/zlamtsqr.f @@ -0,0 +1,415 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, +* $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), +* $ T( LDT, * ) +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAMTSQR overwrites the general complex M-by-N matrix C with +*> +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**C * C C * Q**C +*> where Q is a real orthogonal matrix defined as the product +*> of blocked elementary reflectors computed by tall skinny +*> QR factorization (ZLATSQR) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Conjugate Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >=0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> N >= K >= 0; +*> +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. +*> MB > N. (must be the same as DLATSQR) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> blockedelementary reflector H(i), for i = 1,2,...,k, as +*> returned by DLATSQR in the first k columns of +*> its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension +*> ( N * Number of blocks(CEIL(M-K/MB-K)), +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See below +*> for further details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> If SIDE = 'L', LWORK >= max(1,N)*NB; +*> if SIDE = 'R', LWORK >= max(1,MB)*NB. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, + $ LDT, C, LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), + $ T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN, LQUERY + INTEGER I, II, KK, LW, CTR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL ZGEMQRT, ZTPMQRT, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + LQUERY = LWORK.LT.0 + NOTRAN = LSAME( TRANS, 'N' ) + TRAN = LSAME( TRANS, 'C' ) + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + IF (LEFT) THEN + LW = N * NB + ELSE + LW = M * NB + END IF +* + INFO = 0 + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, NB) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN + INFO = -15 + END IF +* +* Determine the block size if it is tall skinny or short and wide +* + IF( INFO.EQ.0) THEN + WORK(1) = LW + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAMTSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N,K).EQ.0 ) THEN + RETURN + END IF +* + IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN + CALL ZGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA, + $ T, LDT, C, LDC, WORK, INFO) + RETURN + END IF +* + IF(LEFT.AND.NOTRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((M-K),(MB-K)) + CTR = (M-K)/(MB-K) + IF (KK.GT.0) THEN + II=M-KK+1 + CALL ZTPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA, + $ T(1, CTR * K + 1),LDT , C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) + ELSE + II=M+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CTR = CTR - 1 + CALL ZTPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:MB,1:N) +* + CALL ZGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (LEFT.AND.TRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((M-K),(MB-K)) + II=M-KK+1 + CTR = 1 + CALL ZGEMQRT('L','C',MB , N, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (I:I+MB,1:N) +* + CALL ZTPMQRT('L','C',MB-K , N, K, 0,NB, A(I,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(I,1), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.M) THEN +* +* Multiply Q to the last block of C +* + CALL ZTPMQRT('L','C',KK , N, K, 0,NB, A(II,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(II,1), LDC, WORK, INFO ) +* + END IF +* + ELSE IF(RIGHT.AND.TRAN) THEN +* +* Multiply Q to the last block of C +* + KK = MOD((N-K),(MB-K)) + CTR = (N-K)/(MB-K) + IF (KK.GT.0) THEN + II=N-KK+1 + CALL ZTPMQRT('R','C',M , KK, K, 0, NB, A(II,1), LDA, + $ T(1,CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) + ELSE + II=N+1 + END IF +* + DO I=II-(MB-K),MB+1,-(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CTR = CTR - 1 + CALL ZTPMQRT('R','C',M , MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1), LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + + END DO +* +* Multiply Q to the first block of C (1:M,1:MB) +* + CALL ZGEMQRT('R','C',M , MB, K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + ELSE IF (RIGHT.AND.NOTRAN) THEN +* +* Multiply Q to the first block of C +* + KK = MOD((N-K),(MB-K)) + II=N-KK+1 + CTR = 1 + CALL ZGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T + $ ,LDT ,C(1,1), LDC, WORK, INFO ) +* + DO I=MB+1,II-MB+K,(MB-K) +* +* Multiply Q to the current block of C (1:M,I:I+MB) +* + CALL ZTPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA, + $ T(1, CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,I), LDC, WORK, INFO ) + CTR = CTR + 1 +* + END DO + IF(II.LE.N) THEN +* +* Multiply Q to the last block of C +* + CALL ZTPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA, + $ T(1,CTR * K + 1),LDT, C(1,1), LDC, + $ C(1,II), LDC, WORK, INFO ) +* + END IF +* + END IF +* + WORK(1) = LW + RETURN +* +* End of ZLAMTSQR +* + END diff --git a/lapack-netlib/SRC/zlangb.f b/lapack-netlib/SRC/zlangb.f index 65c1eaefae..949bb2c01d 100644 --- a/lapack-netlib/SRC/zlangb.f +++ b/lapack-netlib/SRC/zlangb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER KL, KU, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBauxiliary * @@ -125,10 +125,10 @@ DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zlange.f b/lapack-netlib/SRC/zlange.f index c49555b151..5407decef9 100644 --- a/lapack-netlib/SRC/zlange.f +++ b/lapack-netlib/SRC/zlange.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zlangt.f b/lapack-netlib/SRC/zlangt.f index 91b20a7316..f55904aab4 100644 --- a/lapack-netlib/SRC/zlangt.f +++ b/lapack-netlib/SRC/zlangt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANGT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANGT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 D( * ), DL( * ), DU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM @@ -149,11 +149,11 @@ DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 - IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) + IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) $ ANORM = ABS(DL(I)) - IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) + IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) $ ANORM = ABS(D(I)) - IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) + IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) $ ANORM = ABS(DU(I)) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN @@ -164,7 +164,7 @@ DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) - TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) + TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP DO 20 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) diff --git a/lapack-netlib/SRC/zlanhb.f b/lapack-netlib/SRC/zlanhb.f index 39e6475ec5..b3717804f9 100644 --- a/lapack-netlib/SRC/zlanhb.f +++ b/lapack-netlib/SRC/zlanhb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -132,10 +132,10 @@ DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlanhe.f b/lapack-netlib/SRC/zlanhe.f index 3093a151af..7c7f7f3be4 100644 --- a/lapack-netlib/SRC/zlanhe.f +++ b/lapack-netlib/SRC/zlanhe.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlanhf.f b/lapack-netlib/SRC/zlanhf.f index 6c37f3e4c3..0e73c861b1 100644 --- a/lapack-netlib/SRC/zlanhf.f +++ b/lapack-netlib/SRC/zlanhf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, TRANSR, UPLO * INTEGER N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( 0: * ) * COMPLEX*16 A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -246,10 +246,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, TRANSR, UPLO @@ -339,11 +339,11 @@ DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) J = 0 * -> L(0,0) TEMP = ABS( DBLE( A( J+J*LDA ) ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP DO I = 1, N - 1 TEMP = ABS( A( I+J*LDA ) ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO DO J = 1, K - 1 @@ -726,7 +726,7 @@ DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) - IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) + IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE diff --git a/lapack-netlib/SRC/zlanhp.f b/lapack-netlib/SRC/zlanhp.f index ce14895067..9ded607460 100644 --- a/lapack-netlib/SRC/zlanhp.f +++ b/lapack-netlib/SRC/zlanhp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlanhs.f b/lapack-netlib/SRC/zlanhs.f index f20cd74f92..f2d36b3042 100644 --- a/lapack-netlib/SRC/zlanhs.f +++ b/lapack-netlib/SRC/zlanhs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zlanht.f b/lapack-netlib/SRC/zlanht.f index a6b8b2b752..70f9e3ce63 100644 --- a/lapack-netlib/SRC/zlanht.f +++ b/lapack-netlib/SRC/zlanht.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANHT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANHT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E ) -* +* * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM diff --git a/lapack-netlib/SRC/zlansb.f b/lapack-netlib/SRC/zlansb.f index 776038b590..3468c49b3a 100644 --- a/lapack-netlib/SRC/zlansb.f +++ b/lapack-netlib/SRC/zlansb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -130,10 +130,10 @@ DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlansp.f b/lapack-netlib/SRC/zlansp.f index 07db74acf8..84fb972bbe 100644 --- a/lapack-netlib/SRC/zlansp.f +++ b/lapack-netlib/SRC/zlansp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlansy.f b/lapack-netlib/SRC/zlansy.f index 45a8b1b22c..58269a911f 100644 --- a/lapack-netlib/SRC/zlansy.f +++ b/lapack-netlib/SRC/zlansy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO diff --git a/lapack-netlib/SRC/zlantb.f b/lapack-netlib/SRC/zlantb.f index 64c0e3c704..3077ba1515 100644 --- a/lapack-netlib/SRC/zlantb.f +++ b/lapack-netlib/SRC/zlantb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANTB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANTB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, * LDAB, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER K, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -141,10 +141,10 @@ DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/zlantp.f b/lapack-netlib/SRC/zlantp.f index 07d51edd4c..69dbaa5bca 100644 --- a/lapack-netlib/SRC/zlantp.f +++ b/lapack-netlib/SRC/zlantp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER N @@ -28,7 +28,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,22 +113,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/zlantr.f b/lapack-netlib/SRC/zlantr.f index fb9553b322..04ee482f7d 100644 --- a/lapack-netlib/SRC/zlantr.f +++ b/lapack-netlib/SRC/zlantr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLANTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLANTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * WORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER LDA, M, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -142,10 +142,10 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/zlapll.f b/lapack-netlib/SRC/zlapll.f index 684837a736..2eebe88e4c 100644 --- a/lapack-netlib/SRC/zlapll.f +++ b/lapack-netlib/SRC/zlapll.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAPLL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAPLL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * DOUBLE PRECISION SSMIN @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,22 +88,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/zlapmr.f b/lapack-netlib/SRC/zlapmr.f index 6d2317b363..757a9597d0 100644 --- a/lapack-netlib/SRC/zlapmr.f +++ b/lapack-netlib/SRC/zlapmr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAPMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAPMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * COMPLEX*16 X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/zlapmt.f b/lapack-netlib/SRC/zlapmt.f index 35a43d392b..963ced2ed2 100644 --- a/lapack-netlib/SRC/zlapmt.f +++ b/lapack-netlib/SRC/zlapmt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAPMT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAPMT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K ) -* +* * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N @@ -28,7 +28,7 @@ * INTEGER K( * ) * COMPLEX*16 X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD diff --git a/lapack-netlib/SRC/zlaqgb.f b/lapack-netlib/SRC/zlaqgb.f index db9b7f2d8f..9aaa941c93 100644 --- a/lapack-netlib/SRC/zlaqgb.f +++ b/lapack-netlib/SRC/zlaqgb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQGB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQGB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER KL, KU, LDAB, M, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -147,12 +147,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GBauxiliary * @@ -160,10 +160,10 @@ SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/zlaqge.f b/lapack-netlib/SRC/zlaqge.f index bce3e20d05..c7e2cc17fb 100644 --- a/lapack-netlib/SRC/zlaqge.f +++ b/lapack-netlib/SRC/zlaqge.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER LDA, M, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION C( * ), R( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEauxiliary * @@ -143,10 +143,10 @@ SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED diff --git a/lapack-netlib/SRC/zlaqhb.f b/lapack-netlib/SRC/zlaqhb.f index 498ac6271f..8d2a53ce7b 100644 --- a/lapack-netlib/SRC/zlaqhb.f +++ b/lapack-netlib/SRC/zlaqhb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQHB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQHB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -29,14 +29,14 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZLAQHB equilibrates a Hermitian band matrix A +*> ZLAQHB equilibrates a Hermitian band matrix A *> using the scaling factors in the vector S. *> \endverbatim * @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlaqhe.f b/lapack-netlib/SRC/zlaqhe.f index a7b5563fef..5e6520bd5b 100644 --- a/lapack-netlib/SRC/zlaqhe.f +++ b/lapack-netlib/SRC/zlaqhe.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQHE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16HEauxiliary * * ===================================================================== SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlaqhp.f b/lapack-netlib/SRC/zlaqhp.f index cac99264d2..03f2ac2d1c 100644 --- a/lapack-netlib/SRC/zlaqhp.f +++ b/lapack-netlib/SRC/zlaqhp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQHP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQHP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlaqp2.f b/lapack-netlib/SRC/zlaqp2.f index a8947370c2..e7bb15f9b8 100644 --- a/lapack-netlib/SRC/zlaqp2.f +++ b/lapack-netlib/SRC/zlaqp2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQP2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION VN1( * ), VN2( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -142,17 +142,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET diff --git a/lapack-netlib/SRC/zlaqps.f b/lapack-netlib/SRC/zlaqps.f index b18fa9ebfd..c142e8c69d 100644 --- a/lapack-netlib/SRC/zlaqps.f +++ b/lapack-netlib/SRC/zlaqps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, * VN2, AUXV, F, LDF ) -* +* * .. Scalar Arguments .. * INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. @@ -29,7 +29,7 @@ * DOUBLE PRECISION VN1( * ), VN2( * ) * COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -170,17 +170,17 @@ *> LAPACK Working Note 176 * *> \htmlonly -*> [PDF] -*> \endhtmlonly +*> [PDF] +*> \endhtmlonly * * ===================================================================== SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET @@ -354,9 +354,9 @@ SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * -* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) +* SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP diff --git a/lapack-netlib/SRC/zlaqr0.f b/lapack-netlib/SRC/zlaqr0.f index 3dc4fcc5c8..59b8ed7a6e 100644 --- a/lapack-netlib/SRC/zlaqr0.f +++ b/lapack-netlib/SRC/zlaqr0.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -210,12 +210,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -241,10 +241,10 @@ SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/zlaqr1.f b/lapack-netlib/SRC/zlaqr1.f index 8240bb7ae4..f945672ca8 100644 --- a/lapack-netlib/SRC/zlaqr1.f +++ b/lapack-netlib/SRC/zlaqr1.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) -* +* * .. Scalar Arguments .. * COMPLEX*16 S1, S2 * INTEGER LDH, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), V( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,12 +89,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -107,10 +107,10 @@ * ===================================================================== SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 S1, S2 diff --git a/lapack-netlib/SRC/zlaqr2.f b/lapack-netlib/SRC/zlaqr2.f index 8a3cc3da47..d8396d2314 100644 --- a/lapack-netlib/SRC/zlaqr2.f +++ b/lapack-netlib/SRC/zlaqr2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, * NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -31,7 +31,7 @@ * COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,7 +141,7 @@ *> Z is COMPLEX*16 array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the unitary *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -250,12 +250,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -270,10 +270,10 @@ SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/zlaqr3.f b/lapack-netlib/SRC/zlaqr3.f index 3988014716..402644fd0c 100644 --- a/lapack-netlib/SRC/zlaqr3.f +++ b/lapack-netlib/SRC/zlaqr3.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, * NV, WV, LDWV, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW @@ -31,7 +31,7 @@ * COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), * $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,7 +138,7 @@ *> Z is COMPLEX*16 array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the unitary *> similarity transformation mentioned above has been -*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -247,12 +247,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -267,10 +267,10 @@ SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, diff --git a/lapack-netlib/SRC/zlaqr4.f b/lapack-netlib/SRC/zlaqr4.f index dd2bcdf282..012fa37e29 100644 --- a/lapack-netlib/SRC/zlaqr4.f +++ b/lapack-netlib/SRC/zlaqr4.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, * IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -216,12 +216,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -247,10 +247,10 @@ SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/zlaqr5.f b/lapack-netlib/SRC/zlaqr5.f index e33a30d652..3e0392cb49 100644 --- a/lapack-netlib/SRC/zlaqr5.f +++ b/lapack-netlib/SRC/zlaqr5.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQR5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, * WV, LDWV, NH, WH, LDWH ) -* +* * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, * $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV @@ -31,7 +31,7 @@ * COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), * $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,10 +142,10 @@ *> *> \param[in,out] Z *> \verbatim -*> Z is COMPLEX*16 array of size (LDZ,IHI) +*> Z is COMPLEX*16 array of size (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep unitary *> similarity transformation is accumulated into -*> Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> @@ -223,12 +223,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -251,10 +251,10 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, $ WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, diff --git a/lapack-netlib/SRC/zlaqsb.f b/lapack-netlib/SRC/zlaqsb.f index 5555f39348..3d3912cf8e 100644 --- a/lapack-netlib/SRC/zlaqsb.f +++ b/lapack-netlib/SRC/zlaqsb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQSB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQSB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -129,22 +129,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlaqsp.f b/lapack-netlib/SRC/zlaqsp.f index 5bd2b3839f..339408fb1a 100644 --- a/lapack-netlib/SRC/zlaqsp.f +++ b/lapack-netlib/SRC/zlaqsp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQSP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQSP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlaqsy.f b/lapack-netlib/SRC/zlaqsy.f index 4244785765..0118201063 100644 --- a/lapack-netlib/SRC/zlaqsy.f +++ b/lapack-netlib/SRC/zlaqsy.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAQSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAQSY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,22 +122,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO diff --git a/lapack-netlib/SRC/zlar1v.f b/lapack-netlib/SRC/zlar1v.f index 9f3a87d21f..bb3a66eb8c 100644 --- a/lapack-netlib/SRC/zlar1v.f +++ b/lapack-netlib/SRC/zlar1v.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAR1V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAR1V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, * PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, * R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) -* +* * .. Scalar Arguments .. * LOGICAL WANTNC * INTEGER B1, BN, N, NEGCNT, R @@ -34,7 +34,7 @@ * $ WORK( * ) * COMPLEX*16 Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -207,12 +207,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -230,10 +230,10 @@ SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTNC diff --git a/lapack-netlib/SRC/zlar2v.f b/lapack-netlib/SRC/zlar2v.f index b7fd888d03..0f7fe63b02 100644 --- a/lapack-netlib/SRC/zlar2v.f +++ b/lapack-netlib/SRC/zlar2v.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAR2V + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAR2V + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION C( * ) * COMPLEX*16 S( * ), X( * ), Y( * ), Z( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, N diff --git a/lapack-netlib/SRC/zlarcm.f b/lapack-netlib/SRC/zlarcm.f index e72c1061b6..77a709f474 100644 --- a/lapack-netlib/SRC/zlarcm.f +++ b/lapack-netlib/SRC/zlarcm.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARCM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARCM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, M, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION A( LDA, * ), RWORK( * ) * COMPLEX*16 B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,7 +61,7 @@ *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, M) -*> A contains the M by M matrix A. +*> On entry, A contains the M by M matrix A. *> \endverbatim *> *> \param[in] LDA @@ -72,8 +72,8 @@ *> *> \param[in] B *> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> B contains the M by N matrix B. +*> B is COMPLEX*16 array, dimension (LDB, N) +*> On entry, B contains the M by N matrix B. *> \endverbatim *> *> \param[in] LDB @@ -82,10 +82,10 @@ *> The leading dimension of the array B. LDB >=max(1,M). *> \endverbatim *> -*> \param[in] C +*> \param[out] C *> \verbatim *> C is COMPLEX*16 array, dimension (LDC, N) -*> C contains the M by N matrix C. +*> On exit, C contains the M by N matrix C. *> \endverbatim *> *> \param[in] LDC @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, M, N diff --git a/lapack-netlib/SRC/zlarf.f b/lapack-netlib/SRC/zlarf.f index f51e1d7383..f1be80d37b 100644 --- a/lapack-netlib/SRC/zlarf.f +++ b/lapack-netlib/SRC/zlarf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/zlarfb.f b/lapack-netlib/SRC/zlarfb.f index 480f543fa8..b4a2b4d1a0 100644 --- a/lapack-netlib/SRC/zlarfb.f +++ b/lapack-netlib/SRC/zlarfb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, * T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,10 +154,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date June 2013 * @@ -195,7 +195,7 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- * June 2013 diff --git a/lapack-netlib/SRC/zlarfg.f b/lapack-netlib/SRC/zlarfg.f index e37c683fc9..f8a795d547 100644 --- a/lapack-netlib/SRC/zlarfg.f +++ b/lapack-netlib/SRC/zlarfg.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX*16 ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/zlarfgp.f b/lapack-netlib/SRC/zlarfgp.f index 90e376c2d0..54ce6e63fa 100644 --- a/lapack-netlib/SRC/zlarfgp.f +++ b/lapack-netlib/SRC/zlarfgp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFGP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFGP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * COMPLEX*16 ALPHA, TAU @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N @@ -222,7 +222,7 @@ SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU ) IF ( ABS(TAU).LE.SMLNUM ) THEN * * In the case where the computed TAU ends up being a denormalized number, -* it loses relative accuracy. This is a BIG problem. Solution: flush TAU +* it loses relative accuracy. This is a BIG problem. Solution: flush TAU * to ZERO (or TWO or whatever makes a nonnegative real number for BETA). * * (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) @@ -249,7 +249,7 @@ SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU ) BETA = XNORM END IF * - ELSE + ELSE * * This is the general case. * diff --git a/lapack-netlib/SRC/zlarft.f b/lapack-netlib/SRC/zlarft.f index b9ac939763..78ad2f1481 100644 --- a/lapack-netlib/SRC/zlarft.f +++ b/lapack-netlib/SRC/zlarft.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -163,10 +163,10 @@ * ===================================================================== SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -187,7 +187,7 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. - EXTERNAL ZGEMV, ZLACGV, ZTRMV, ZGEMM + EXTERNAL ZGEMV, ZTRMV, ZGEMM * .. * .. External Functions .. LOGICAL LSAME @@ -222,13 +222,13 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) * CALL ZGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, + $ -TAU( I ), V( I+1, 1 ), LDV, $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) ELSE * Skip any trailing zeros. @@ -237,14 +237,14 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) - END DO + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H * CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) + $ ONE, T( 1, I ), LDT ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) @@ -281,7 +281,7 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) @@ -296,14 +296,14 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO + END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H * CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) + $ ONE, T( I+1, I ), LDT ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) diff --git a/lapack-netlib/SRC/zlarfx.f b/lapack-netlib/SRC/zlarfx.f index 3551b9b4a6..685d164ebb 100644 --- a/lapack-netlib/SRC/zlarfx.f +++ b/lapack-netlib/SRC/zlarfx.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARFX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,22 +107,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/zlarfy.f b/lapack-netlib/SRC/zlarfy.f new file mode 100644 index 0000000000..57605731bf --- /dev/null +++ b/lapack-netlib/SRC/zlarfy.f @@ -0,0 +1,163 @@ +*> \brief \b ZLARFY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* COMPLEX*16 TAU +* .. +* .. Array Arguments .. +* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARFY applies an elementary reflector, or Householder matrix, H, +*> to an n x n Hermitian matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER INCV, LDC, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO, HALF + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ), + $ HALF = ( 0.5D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZHEMV, ZHER2 +* .. +* .. External Functions .. + COMPLEX*16 ZDOTC + EXTERNAL ZDOTC +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL ZHEMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*ZDOTC( N, WORK, 1, V, INCV ) + CALL ZAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL ZHER2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of ZLARFY +* + END diff --git a/lapack-netlib/SRC/zlargv.f b/lapack-netlib/SRC/zlargv.f index eac86f938a..1e17983d5a 100644 --- a/lapack-netlib/SRC/zlargv.f +++ b/lapack-netlib/SRC/zlargv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION C( * ) * COMPLEX*16 X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,12 +99,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -122,10 +122,10 @@ * ===================================================================== SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/zlarnv.f b/lapack-netlib/SRC/zlarnv.f index d6501a7be9..7541652289 100644 --- a/lapack-netlib/SRC/zlarnv.f +++ b/lapack-netlib/SRC/zlarnv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARNV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARNV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, N * .. @@ -27,7 +27,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -76,12 +76,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -99,10 +99,10 @@ * ===================================================================== SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, N diff --git a/lapack-netlib/SRC/zlarrv.f b/lapack-netlib/SRC/zlarrv.f index 3992f14d54..c7656811d4 100644 --- a/lapack-netlib/SRC/zlarrv.f +++ b/lapack-netlib/SRC/zlarrv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARRV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARRV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -23,7 +23,7 @@ * RTOL1, RTOL2, W, WERR, WGAP, * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, * WORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER DOL, DOU, INFO, LDZ, M, N * DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU @@ -35,7 +35,7 @@ * $ WGAP( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,12 +59,15 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> Lower bound of the interval that contains the desired +*> eigenvalues. VL < VU. Needed to compute gaps on the left or right +*> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION -*> Lower and upper bounds of the interval that contains the desired +*> Upper bound of the interval that contains the desired *> eigenvalues. VL < VU. Needed to compute gaps on the left or right *> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim @@ -81,7 +84,7 @@ *> L is DOUBLE PRECISION array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the unit *> bidiagonal matrix L are in elements 1 to N-1 of L -*> (if the matrix is not splitted.) At the end of each block +*> (if the matrix is not split.) At the end of each block *> is stored the corresponding shift as given by DLARRE. *> On exit, L is overwritten. *> \endverbatim @@ -236,7 +239,7 @@ *> INFO is INTEGER *> = 0: successful exit *> -*> > 0: A problem occured in ZLARRV. +*> > 0: A problem occurred in ZLARRV. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. @@ -258,12 +261,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -283,10 +286,10 @@ SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER DOL, DOU, INFO, LDZ, M, N diff --git a/lapack-netlib/SRC/zlarscl2.f b/lapack-netlib/SRC/zlarscl2.f index b54f02c988..0d7cb1e887 100644 --- a/lapack-netlib/SRC/zlarscl2.f +++ b/lapack-netlib/SRC/zlarscl2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARSCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARSCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. @@ -27,7 +27,7 @@ * COMPLEX*16 X( LDX, * ) * DOUBLE PRECISION D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,28 +73,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/zlartg.f b/lapack-netlib/SRC/zlartg.f index 3e2260223e..8989bb8960 100644 --- a/lapack-netlib/SRC/zlartg.f +++ b/lapack-netlib/SRC/zlartg.f @@ -2,29 +2,29 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS * COMPLEX*16 F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -80,12 +80,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -103,10 +103,10 @@ * ===================================================================== SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK auxiliary 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS diff --git a/lapack-netlib/SRC/zlartv.f b/lapack-netlib/SRC/zlartv.f index f6e6c142b6..d6c7ee7422 100644 --- a/lapack-netlib/SRC/zlartv.f +++ b/lapack-netlib/SRC/zlartv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARTV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARTV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC ) -* +* * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION C( * ) * COMPLEX*16 S( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N diff --git a/lapack-netlib/SRC/zlarz.f b/lapack-netlib/SRC/zlarz.f index a06e711062..5c28cee281 100644 --- a/lapack-netlib/SRC/zlarz.f +++ b/lapack-netlib/SRC/zlarz.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, L, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -147,10 +147,10 @@ * ===================================================================== SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE diff --git a/lapack-netlib/SRC/zlarzb.f b/lapack-netlib/SRC/zlarzb.f index 19d5eb93e9..e27c7e0dfc 100644 --- a/lapack-netlib/SRC/zlarzb.f +++ b/lapack-netlib/SRC/zlarzb.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARZB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARZB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * LDV, T, LDT, C, LDC, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N @@ -29,7 +29,7 @@ * COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -159,12 +159,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -183,10 +183,10 @@ SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff --git a/lapack-netlib/SRC/zlarzt.f b/lapack-netlib/SRC/zlarzt.f index eb1131ca80..ccd8c4b841 100644 --- a/lapack-netlib/SRC/zlarzt.f +++ b/lapack-netlib/SRC/zlarzt.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARZT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARZT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -185,10 +185,10 @@ * ===================================================================== SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff --git a/lapack-netlib/SRC/zlascl.f b/lapack-netlib/SRC/zlascl.f index 51a4f0f614..c53c6f5ad7 100644 --- a/lapack-netlib/SRC/zlascl.f +++ b/lapack-netlib/SRC/zlascl.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,7 +114,11 @@ *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO @@ -127,22 +131,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER TYPE diff --git a/lapack-netlib/SRC/zlascl2.f b/lapack-netlib/SRC/zlascl2.f index eebdebb4da..e1a0f97b91 100644 --- a/lapack-netlib/SRC/zlascl2.f +++ b/lapack-netlib/SRC/zlascl2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASCL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASCL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASCL2 ( M, N, D, X, LDX ) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDX * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,28 +73,28 @@ *> \param[in] LDX *> \verbatim *> LDX is INTEGER -*> The leading dimension of the vector X. LDX >= 0. +*> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLASCL2 ( M, N, D, X, LDX ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX diff --git a/lapack-netlib/SRC/zlaset.f b/lapack-netlib/SRC/zlaset.f index fb72e7c425..796678217b 100644 --- a/lapack-netlib/SRC/zlaset.f +++ b/lapack-netlib/SRC/zlaset.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlasr.f b/lapack-netlib/SRC/zlasr.f index 5243d8304a..69891ba522 100644 --- a/lapack-netlib/SRC/zlasr.f +++ b/lapack-netlib/SRC/zlasr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION C( * ), S( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,23 +49,23 @@ *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. -*> +*> *> When DIRECT = 'F' (Forward sequence), then -*> +*> *> P = P(z-1) * ... * P(2) * P(1) -*> +*> *> and when DIRECT = 'B' (Backward sequence), then -*> +*> *> P = P(1) * P(2) * ... * P(z-1) -*> +*> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> +*> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). -*> +*> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -74,13 +74,13 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. -*> +*> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form -*> +*> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) @@ -89,12 +89,12 @@ *> ( 1 ) *> ( ... ) *> ( 1 ) -*> +*> *> where R(k) appears in rows and columns 1 and k+1. -*> +*> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form -*> +*> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) @@ -103,7 +103,7 @@ *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) -*> +*> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim @@ -188,22 +188,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE diff --git a/lapack-netlib/SRC/zlassq.f b/lapack-netlib/SRC/zlassq.f index 5b7e66c30b..fd13811bd9 100644 --- a/lapack-netlib/SRC/zlassq.f +++ b/lapack-netlib/SRC/zlassq.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* +* * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, N diff --git a/lapack-netlib/SRC/zlaswlq.f b/lapack-netlib/SRC/zlaswlq.f new file mode 100644 index 0000000000..cd7bcc3a21 --- /dev/null +++ b/lapack-netlib/SRC/zlaswlq.f @@ -0,0 +1,258 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASWLQ computes a blocked Short-Wide LQ factorization of a +*> M-by-N matrix A, where N >= M: +*> A = L * Q +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= M >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> M >= MB >= 1 +*> \endverbatim +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> NB > M. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and bleow the diagonal +*> of the array contain the N-by-N lower triangular matrix L; +*> the elements above the diagonal represent Q by the rows +*> of blocked V (see Further Details). +*> +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((N-M)/(NB-M)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> +*> \endverbatim +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= MB*M. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> +*> \endverbatim +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: +*> Q(1) zeros out the upper diagonal entries of rows 1:NB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A +*> . . . +*> +*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GELQT. +*> +*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors +*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK, + $ INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LWORK, LDT +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ), T( LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL ZGELQT, ZTPLQT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.LT.M ) THEN + INFO = -2 + ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN + INFO = -3 + ELSE IF( NB.LE.M ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.MB ) THEN + INFO = -8 + ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = MB*M + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLASWLQ', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The LQ Decomposition +* + IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN + CALL ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF +* + KK = MOD((N-M),(NB-M)) + II=N-KK+1 +* +* Compute the LQ factorization of the first block A(1:M,1:NB) +* + CALL ZGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO) + CTR = 1 +* + DO I = NB+1, II-NB+M , (NB-M) +* +* Compute the QR factorization of the current block A(1:M,I:I+NB-M) +* + CALL ZTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ), + $ LDA, T(1, CTR * M + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(1:M,II:N) +* + IF (II.LE.N) THEN + CALL ZTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ), + $ LDA, T(1, CTR * M + 1), LDT, + $ WORK, INFO ) + END IF +* + WORK( 1 ) = M * MB + RETURN +* +* End of ZLASWLQ +* + END diff --git a/lapack-netlib/SRC/zlaswp.f b/lapack-netlib/SRC/zlaswp.f index 76d7a422bd..81ceba2cc9 100644 --- a/lapack-netlib/SRC/zlaswp.f +++ b/lapack-netlib/SRC/zlaswp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* +* * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. @@ -27,7 +27,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,15 +71,15 @@ *> \param[in] K2 *> \verbatim *> K2 is INTEGER -*> The last element of IPIV for which a row interchange will -*> be done. +*> (K2-K1+1) is the number of elements of IPIV for which a row +*> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim -*> IPIV is INTEGER array, dimension (K2*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K2 of IPIV are accessed. +*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K1+(K2-K1)*INCX of IPIV are accessed. *> IPIV(K) = L implies rows K and L are to be interchanged. *> \endverbatim *> @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -114,10 +114,10 @@ * ===================================================================== SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -143,7 +143,7 @@ SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX + IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 diff --git a/lapack-netlib/SRC/zlasyf_aa.f b/lapack-netlib/SRC/zlasyf_aa.f new file mode 100644 index 0000000000..7ac4ff3dce --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_aa.f @@ -0,0 +1,506 @@ +*> \brief \b ZLASYF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASYF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AA factorizes a panel of a complex symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diagonals), while +*> the diagonal and subdiagonal of A are overwritten by those of T. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by ZSYTRF_AA, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 workspace, dimension (M). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +* ===================================================================== + SUBROUTINE ZLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX*16 PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from ZSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL ZAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( K.GT.1 ) THEN + ALPHA = -A( K, J ) + CALL ZAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL ZSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL ZCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL ZSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL ZLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from ZSYTRF_AA, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL ZAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( K.GT.1 ) THEN + ALPHA = -A( J, K ) + CALL ZAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL ZSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL ZCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL ZSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL ZLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of ZLASYF_AA +* + END diff --git a/lapack-netlib/SRC/zlasyf_rk.f b/lapack-netlib/SRC/zlasyf_rk.f new file mode 100644 index 0000000000..664ed93f3b --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_rk.f @@ -0,0 +1,974 @@ +*> \brief \b ZLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASYF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZLASYF_RK computes a partial factorization of a complex symmetric +*> matrix A using the bounded Bunch-Kaufman (rook) diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> ZLASYF_RK is an auxiliary routine called by ZSYTRF_RK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,N-KB+1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,N-KB+1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,N-KB+1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the submatrix A(1:N,1:KB). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the submatrix A(1:N,1:KB). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, + $ KP, KSTEP, P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, SFMIN, DTEMP + COMPLEX*16 D11, D12, D21, D22, R1, T, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL ZCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL ZCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL ZSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL ZSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = CONE / ( D11*D22-CONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy superdiagonal element of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = CZERO + A( K, K ) = W( K, KW ) + E( K ) = W( K-1, KW ) + E( K-1 ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), + $ LDW, CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = CABS1( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL ZCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL ZCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL ZSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL ZSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy diagonal elements of D(K) to A, +* copy subdiagonal element of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = CZERO + A( K+1, K+1 ) = W( K+1, K+1 ) + E( K ) = W( K+1, K ) + E( K+1 ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF +* + RETURN +* +* End of ZLASYF_RK +* + END diff --git a/lapack-netlib/SRC/zlat2c.f b/lapack-netlib/SRC/zlat2c.f index 8b9af86004..dad8fa8047 100644 --- a/lapack-netlib/SRC/zlat2c.f +++ b/lapack-netlib/SRC/zlat2c.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAT2C + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAT2C + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDSA, N @@ -28,7 +28,7 @@ * COMPLEX SA( LDSA, * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -40,7 +40,7 @@ *> *> RMAX is the overflow for the SINGLE PRECISION arithmetic *> ZLAT2C checks that all the entries of A are between -RMAX and -*> RMAX. If not the convertion is aborted and a flag is raised. +*> RMAX. If not the conversion is aborted and a flag is raised. *> *> This is an auxiliary routine so there is no argument checking. *> \endverbatim @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlatbs.f b/lapack-netlib/SRC/zlatbs.f index 2277282b96..ef2d67c9c6 100644 --- a/lapack-netlib/SRC/zlatbs.f +++ b/lapack-netlib/SRC/zlatbs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATBS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATBS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, * SCALE, CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION CNORM( * ) * COMPLEX*16 AB( LDAB, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -243,10 +243,10 @@ SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/zlatdf.f b/lapack-netlib/SRC/zlatdf.f index e90bfede01..ab88570c55 100644 --- a/lapack-netlib/SRC/zlatdf.f +++ b/lapack-netlib/SRC/zlatdf.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATDF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATDF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * DOUBLE PRECISION RDSCAL, RDSUM @@ -29,7 +29,7 @@ * INTEGER IPIV( * ), JPIV( * ) * COMPLEX*16 RHS( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -58,7 +58,7 @@ *> Zx = +-e - f with the sign giving the greater value of *> 2-norm(x). About 5 times as expensive as Default. *> IJOB .ne. 2: Local look ahead strategy where -*> all entries of the r.h.s. b is choosen as either +1 or +*> all entries of the r.h.s. b is chosen as either +1 or *> -1. Default. *> \endverbatim *> @@ -70,7 +70,7 @@ *> *> \param[in] Z *> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> Z is COMPLEX*16 array, dimension (LDZ, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix Z computed by ZGETC2: Z = P * L * U * Q *> \endverbatim @@ -83,7 +83,7 @@ *> *> \param[in,out] RHS *> \verbatim -*> RHS is DOUBLE PRECISION array, dimension (N). +*> RHS is COMPLEX*16 array, dimension (N). *> On entry, RHS contains contributions from other subsystems. *> On exit, RHS contains the solution of the subsystem with *> entries according to the value of IJOB (see above). @@ -129,12 +129,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16OTHERauxiliary * @@ -169,10 +169,10 @@ SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IJOB, LDZ, N diff --git a/lapack-netlib/SRC/zlatps.f b/lapack-netlib/SRC/zlatps.f index e5e3cf05f2..d6523382cf 100644 --- a/lapack-netlib/SRC/zlatps.f +++ b/lapack-netlib/SRC/zlatps.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATPS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATPS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION CNORM( * ) * COMPLEX*16 AP( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -231,10 +231,10 @@ SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/zlatrd.f b/lapack-netlib/SRC/zlatrd.f index 619d7280c4..ccc040993f 100644 --- a/lapack-netlib/SRC/zlatrd.f +++ b/lapack-netlib/SRC/zlatrd.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB @@ -28,7 +28,7 @@ * DOUBLE PRECISION E( * ) * COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -199,10 +199,10 @@ * ===================================================================== SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlatrs.f b/lapack-netlib/SRC/zlatrs.f index 91ab9dc36b..36ddba9704 100644 --- a/lapack-netlib/SRC/zlatrs.f +++ b/lapack-netlib/SRC/zlatrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION CNORM( * ) * COMPLEX*16 A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -239,10 +239,10 @@ SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff --git a/lapack-netlib/SRC/zlatrz.f b/lapack-netlib/SRC/zlatrz.f index 996cc538ba..5d415fe76a 100644 --- a/lapack-netlib/SRC/zlatrz.f +++ b/lapack-netlib/SRC/zlatrz.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLATRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLATRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK ) -* +* * .. Scalar Arguments .. * INTEGER L, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -140,10 +140,10 @@ * ===================================================================== SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER L, LDA, M, N diff --git a/lapack-netlib/SRC/zlatsqr.f b/lapack-netlib/SRC/zlatsqr.f new file mode 100644 index 0000000000..1fdf3be241 --- /dev/null +++ b/lapack-netlib/SRC/zlatsqr.f @@ -0,0 +1,255 @@ +* +* Definition: +* =========== +* +* SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, +* LWORK, INFO) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLATSQR computes a blocked Tall-Skinny QR factorization of +*> an M-by-N matrix A, where M >= N: +*> A = Q * R . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The row block size to be used in the blocked QR. +*> MB > N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The column block size to be used in the blocked QR. +*> N >= NB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the elements on and above the diagonal +*> of the array contain the N-by-N upper triangular matrix R; +*> the elements below the diagonal represent Q by the columns +*> of blocked V (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, +*> dimension (LDT, N * Number_of_row_blocks) +*> where Number_of_row_blocks = CEIL((M-N)/(MB-N)) +*> The blocked upper triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. +*> See Further Details below. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> The dimension of the array WORK. LWORK >= NB*N. +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, +*> representing Q as a product of other orthogonal matrices +*> Q = Q(1) * Q(2) * . . . * Q(k) +*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: +*> Q(1) zeros out the subdiagonal entries of rows 1:MB of A +*> Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A +*> Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A +*> . . . +*> +*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors +*> stored under the diagonal of rows 1:MB of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,1:N). +*> For more information see Further Details in GEQRT. +*> +*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors +*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular +*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). +*> The last Q(k) may use fewer rows. +*> For more information see Further Details in TPQRT. +*> +*> For more details of the overall algorithm, see the description of +*> Sequential TSQR in Section 2.2 of [1]. +*> +*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,” +*> J. Demmel, L. Grigori, M. Hoemmen, J. Langou, +*> SIAM J. Sci. Comput, vol. 34, no. 1, 2012 +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, + $ LWORK, INFO) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ), T(LDT, *) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, II, KK, CTR +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL ZGEQRT, ZTPQRT, XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 +* + LQUERY = ( LWORK.EQ.-1 ) +* + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. M.LT.N ) THEN + INFO = -2 + ELSE IF( MB.LE.N ) THEN + INFO = -3 + ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDT.LT.NB ) THEN + INFO = -8 + ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN + INFO = -10 + END IF + IF( INFO.EQ.0) THEN + WORK(1) = NB*N + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLATSQR', -INFO ) + RETURN + ELSE IF (LQUERY) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( MIN(M,N).EQ.0 ) THEN + RETURN + END IF +* +* The QR Decomposition +* + IF ((MB.LE.N).OR.(MB.GE.M)) THEN + CALL ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO) + RETURN + END IF + KK = MOD((M-N),(MB-N)) + II=M-KK+1 +* +* Compute the QR factorization of the first block A(1:MB,1:N) +* + CALL ZGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO ) + CTR = 1 +* + DO I = MB+1, II-MB+N , (MB-N) +* +* Compute the QR factorization of the current block A(I:I+MB-N,1:N) +* + CALL ZTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA, + $ T(1, CTR * N + 1), + $ LDT, WORK, INFO ) + CTR = CTR + 1 + END DO +* +* Compute the QR factorization of the last block A(II:M,1:N) +* + IF (II.LE.M) THEN + CALL ZTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA, + $ T(1,CTR * N + 1), LDT, + $ WORK, INFO ) + END IF +* + work( 1 ) = N*NB + RETURN +* +* End of ZLATSQR +* + END diff --git a/lapack-netlib/SRC/zlauu2.f b/lapack-netlib/SRC/zlauu2.f index 92792cd2de..3e3623f2d3 100644 --- a/lapack-netlib/SRC/zlauu2.f +++ b/lapack-netlib/SRC/zlauu2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAUU2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAUU2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zlauum.f b/lapack-netlib/SRC/zlauum.f index d152819716..5afadda098 100644 --- a/lapack-netlib/SRC/zlauum.f +++ b/lapack-netlib/SRC/zlauum.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLAUUM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLAUUM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbcon.f b/lapack-netlib/SRC/zpbcon.f index 03e48cad3e..debbcae6f2 100644 --- a/lapack-netlib/SRC/zpbcon.f +++ b/lapack-netlib/SRC/zpbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -133,10 +133,10 @@ SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbequ.f b/lapack-netlib/SRC/zpbequ.f index ae0c3a948d..d05fd82d8f 100644 --- a/lapack-netlib/SRC/zpbequ.f +++ b/lapack-netlib/SRC/zpbequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbrfs.f b/lapack-netlib/SRC/zpbrfs.f index a75f563ae9..4e62245380 100644 --- a/lapack-netlib/SRC/zpbrfs.f +++ b/lapack-netlib/SRC/zpbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, * LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,7 +75,7 @@ *> *> \param[in] AB *> \verbatim -*> AB is DOUBLE PRECISION array, dimension (LDAB,N) +*> AB is COMPLEX*16 array, dimension (LDAB,N) *> The upper or lower triangle of the Hermitian band matrix A, *> stored in the first KD+1 rows of the array. The j-th column *> of A is stored in the j-th column of the array AB as follows: @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbstf.f b/lapack-netlib/SRC/zpbstf.f index 016840733e..b4482103e8 100644 --- a/lapack-netlib/SRC/zpbstf.f +++ b/lapack-netlib/SRC/zpbstf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBSTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBSTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbsv.f b/lapack-netlib/SRC/zpbsv.f index 8df5915de1..4daf6b3e40 100644 --- a/lapack-netlib/SRC/zpbsv.f +++ b/lapack-netlib/SRC/zpbsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsolve * @@ -164,10 +164,10 @@ * ===================================================================== SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbsvx.f b/lapack-netlib/SRC/zpbsvx.f index 5f20719445..bff6f3615f 100644 --- a/lapack-netlib/SRC/zpbsvx.f +++ b/lapack-netlib/SRC/zpbsvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, * EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -296,10 +296,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -342,7 +342,7 @@ SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zpbtf2.f b/lapack-netlib/SRC/zpbtf2.f index 64792e5066..b39f1de81f 100644 --- a/lapack-netlib/SRC/zpbtf2.f +++ b/lapack-netlib/SRC/zpbtf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbtrf.f b/lapack-netlib/SRC/zpbtrf.f index acc448df24..0eee3b6bdf 100644 --- a/lapack-netlib/SRC/zpbtrf.f +++ b/lapack-netlib/SRC/zpbtrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -142,10 +142,10 @@ * ===================================================================== SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpbtrs.f b/lapack-netlib/SRC/zpbtrs.f index e2a44aa2f8..a5a3db0846 100644 --- a/lapack-netlib/SRC/zpbtrs.f +++ b/lapack-netlib/SRC/zpbtrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpftrf.f b/lapack-netlib/SRC/zpftrf.f index 179bcac00a..fd303300f3 100644 --- a/lapack-netlib/SRC/zpftrf.f +++ b/lapack-netlib/SRC/zpftrf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPFTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPFTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER N, INFO * .. * .. Array Arguments .. * COMPLEX*16 A( 0: * ) -* +* * *> \par Purpose: * ============= @@ -69,7 +69,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is COMPLEX array, dimension ( N*(N+1)/2 ); +*> A is COMPLEX*16 array, dimension ( N*(N+1)/2 ); *> On entry, the Hermitian matrix A in RFP format. RFP format is *> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' *> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is @@ -199,22 +199,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/zpftri.f b/lapack-netlib/SRC/zpftri.f index f827328de1..e63846b00d 100644 --- a/lapack-netlib/SRC/zpftri.f +++ b/lapack-netlib/SRC/zpftri.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. Array Arguments .. * COMPLEX*16 A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,12 +92,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -212,10 +212,10 @@ * ===================================================================== SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/zpftrs.f b/lapack-netlib/SRC/zpftrs.f index 4e9009a4ae..b045f89883 100644 --- a/lapack-netlib/SRC/zpftrs.f +++ b/lapack-netlib/SRC/zpftrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPFTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPFTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( 0: * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,12 +100,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -220,10 +220,10 @@ * ===================================================================== SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/zpocon.f b/lapack-netlib/SRC/zpocon.f index 32ec72f1b3..ba22de0955 100644 --- a/lapack-netlib/SRC/zpocon.f +++ b/lapack-netlib/SRC/zpocon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * @@ -121,10 +121,10 @@ SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpoequ.f b/lapack-netlib/SRC/zpoequ.f index cb3079666a..99b94f3ba1 100644 --- a/lapack-netlib/SRC/zpoequ.f +++ b/lapack-netlib/SRC/zpoequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -28,7 +28,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/zpoequb.f b/lapack-netlib/SRC/zpoequb.f index d0dd0d93d4..6902bdb78d 100644 --- a/lapack-netlib/SRC/zpoequb.f +++ b/lapack-netlib/SRC/zpoequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ) * DOUBLE PRECISION S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,13 +36,19 @@ *> \verbatim *> *> ZPOEQUB computes row and column scalings intended to equilibrate a -*> symmetric positive definite matrix A and reduce its condition number +*> Hermitian positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. +*> +*> This routine differs from ZPOEQU by restricting the scaling factors +*> to a power of the radix. Barring over- and underflow, scaling by +*> these factors introduces no additional rounding errors. However, the +*> scaled diagonal entries are no longer approximately 1 but lie +*> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: @@ -57,7 +63,7 @@ *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) -*> The N-by-N symmetric positive definite matrix whose scaling +*> The N-by-N Hermitian positive definite matrix whose scaling *> factors are to be computed. Only the diagonal elements of A *> are referenced. *> \endverbatim @@ -101,22 +107,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/SRC/zporfs.f b/lapack-netlib/SRC/zporfs.f index d27d689447..3b9753e0fd 100644 --- a/lapack-netlib/SRC/zporfs.f +++ b/lapack-netlib/SRC/zporfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPORFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPORFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, * LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * @@ -183,10 +183,10 @@ SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zporfsx.f b/lapack-netlib/SRC/zporfsx.f index 4a8ae903b8..ee8cfbc6ac 100644 --- a/lapack-netlib/SRC/zporfsx.f +++ b/lapack-netlib/SRC/zporfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPORFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPORFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -378,10 +378,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -393,7 +393,7 @@ SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -453,12 +453,11 @@ SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/zposv.f b/lapack-netlib/SRC/zposv.f index ec85ee0808..07ee5b14ea 100644 --- a/lapack-netlib/SRC/zposv.f +++ b/lapack-netlib/SRC/zposv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POsolve * * ===================================================================== SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zposvx.f b/lapack-netlib/SRC/zposvx.f index cb95cc50ba..5f67bb80a2 100644 --- a/lapack-netlib/SRC/zposvx.f +++ b/lapack-netlib/SRC/zposvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, * S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -292,10 +292,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -306,7 +306,7 @@ SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zposvxx.f b/lapack-netlib/SRC/zposvxx.f index c6a77065cf..8126f14bee 100644 --- a/lapack-netlib/SRC/zposvxx.f +++ b/lapack-netlib/SRC/zposvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -36,7 +36,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -478,10 +478,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -493,7 +493,7 @@ SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 @@ -537,7 +537,7 @@ SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, DOUBLE PRECISION DLAMCH, ZLA_PORPVGRW * .. * .. External Subroutines .. - EXTERNAL ZPOCON, ZPOEQUB, ZPOTRF, ZPOTRS, ZLACPY, + EXTERNAL ZPOEQUB, ZPOTRF, ZPOTRS, ZLACPY, $ ZLAQHE, XERBLA, ZLASCL2, ZPORFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/zpotf2.f b/lapack-netlib/SRC/zpotf2.f index 959314b820..0aa457fbfa 100644 --- a/lapack-netlib/SRC/zpotf2.f +++ b/lapack-netlib/SRC/zpotf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpotrf.f b/lapack-netlib/SRC/zpotrf.f index a4da7e7328..044cb90d7e 100644 --- a/lapack-netlib/SRC/zpotrf.f +++ b/lapack-netlib/SRC/zpotrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,22 +95,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpotrf2.f b/lapack-netlib/SRC/zpotrf2.f index c2a0829101..e37c9f6d63 100644 --- a/lapack-netlib/SRC/zpotrf2.f +++ b/lapack-netlib/SRC/zpotrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -41,7 +41,7 @@ *> *> The subroutine calls itself to factor A11. Update and scale A21 *> or A12, update A22 then call itself to factor A22. -*> +*> *> \endverbatim * * Arguments: @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -128,7 +128,7 @@ RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) PARAMETER ( CONE = (1.0D+0, 0.0D+0) ) * .. * .. Local Scalars .. - LOGICAL UPPER + LOGICAL UPPER INTEGER N1, N2, IINFO DOUBLE PRECISION AJJ * .. @@ -193,7 +193,7 @@ RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO RETURN - END IF + END IF * * Compute the Cholesky factorization A = U**H*U * @@ -205,7 +205,7 @@ RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) * * Update and factor A22 -* +* CALL ZHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) diff --git a/lapack-netlib/SRC/zpotri.f b/lapack-netlib/SRC/zpotri.f index ce6312e744..68f61e87eb 100644 --- a/lapack-netlib/SRC/zpotri.f +++ b/lapack-netlib/SRC/zpotri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpotrs.f b/lapack-netlib/SRC/zpotrs.f index 897d68c24a..b476bcb9d3 100644 --- a/lapack-netlib/SRC/zpotrs.f +++ b/lapack-netlib/SRC/zpotrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPOTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16POcomputational * * ===================================================================== SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zppcon.f b/lapack-netlib/SRC/zppcon.f index 3d014b8154..44d32e044c 100644 --- a/lapack-netlib/SRC/zppcon.f +++ b/lapack-netlib/SRC/zppcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zppequ.f b/lapack-netlib/SRC/zppequ.f index 112017c7e8..424e338f6d 100644 --- a/lapack-netlib/SRC/zppequ.f +++ b/lapack-netlib/SRC/zppequ.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPEQU + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPEQU + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,22 +105,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpprfs.f b/lapack-netlib/SRC/zpprfs.f index 2755a0f664..ae6a76ead8 100644 --- a/lapack-netlib/SRC/zpprfs.f +++ b/lapack-netlib/SRC/zpprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, * BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zppsv.f b/lapack-netlib/SRC/zppsv.f index 0d0786bbe0..49b2e0be12 100644 --- a/lapack-netlib/SRC/zppsv.f +++ b/lapack-netlib/SRC/zppsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsolve * @@ -144,10 +144,10 @@ * ===================================================================== SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zppsvx.f b/lapack-netlib/SRC/zppsvx.f index 8b65562147..d527748383 100644 --- a/lapack-netlib/SRC/zppsvx.f +++ b/lapack-netlib/SRC/zppsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, * X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -278,10 +278,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -311,7 +311,7 @@ SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zpptrf.f b/lapack-netlib/SRC/zpptrf.f index c34aff332a..6e50b46828 100644 --- a/lapack-netlib/SRC/zpptrf.f +++ b/lapack-netlib/SRC/zpptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpptri.f b/lapack-netlib/SRC/zpptri.f index 0946797450..cde2f6dc72 100644 --- a/lapack-netlib/SRC/zpptri.f +++ b/lapack-netlib/SRC/zpptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpptrs.f b/lapack-netlib/SRC/zpptrs.f index 9e3e556108..4856134907 100644 --- a/lapack-netlib/SRC/zpptrs.f +++ b/lapack-netlib/SRC/zpptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zpstf2.f b/lapack-netlib/SRC/zpstf2.f index 6f2ba2731e..696d83f293 100644 --- a/lapack-netlib/SRC/zpstf2.f +++ b/lapack-netlib/SRC/zpstf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPSTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPSTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK @@ -30,7 +30,7 @@ * DOUBLE PRECISION WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -130,22 +130,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL @@ -252,7 +252,7 @@ SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) DO 130 I = J, N * IF( J.GT.1 ) THEN - WORK( I ) = WORK( I ) + + WORK( I ) = WORK( I ) + $ DBLE( DCONJG( A( J-1, I ) )* $ A( J-1, I ) ) END IF @@ -324,7 +324,7 @@ SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) DO 160 I = J, N * IF( J.GT.1 ) THEN - WORK( I ) = WORK( I ) + + WORK( I ) = WORK( I ) + $ DBLE( DCONJG( A( I, J-1 ) )* $ A( I, J-1 ) ) END IF diff --git a/lapack-netlib/SRC/zpstrf.f b/lapack-netlib/SRC/zpstrf.f index c9be199812..2a2937c5d8 100644 --- a/lapack-netlib/SRC/zpstrf.f +++ b/lapack-netlib/SRC/zpstrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPSTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPSTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK @@ -30,7 +30,7 @@ * DOUBLE PRECISION WORK( 2*N ) * INTEGER PIV( N ) * .. -* +* * *> \par Purpose: * ============= @@ -130,22 +130,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL diff --git a/lapack-netlib/SRC/zptcon.f b/lapack-netlib/SRC/zptcon.f index fe966658a2..d2b560f91d 100644 --- a/lapack-netlib/SRC/zptcon.f +++ b/lapack-netlib/SRC/zptcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), RWORK( * ) * COMPLEX*16 E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTcomputational * @@ -119,10 +119,10 @@ * ===================================================================== SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/zpteqr.f b/lapack-netlib/SRC/zpteqr.f index 544f38d699..0b443e18f7 100644 --- a/lapack-netlib/SRC/zpteqr.f +++ b/lapack-netlib/SRC/zpteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,22 +133,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTcomputational * * ===================================================================== SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/zptrfs.f b/lapack-netlib/SRC/zptrfs.f index a1ab332f67..f12ac3150a 100644 --- a/lapack-netlib/SRC/zptrfs.f +++ b/lapack-netlib/SRC/zptrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 B( LDB, * ), E( * ), EF( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTcomputational * @@ -183,10 +183,10 @@ SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zptsv.f b/lapack-netlib/SRC/zptsv.f index 037e6e350c..4ae2fcfbd5 100644 --- a/lapack-netlib/SRC/zptsv.f +++ b/lapack-netlib/SRC/zptsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTsolve * * ===================================================================== SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zptsvx.f b/lapack-netlib/SRC/zptsvx.f index 613321cdfa..085fb2e571 100644 --- a/lapack-netlib/SRC/zptsvx.f +++ b/lapack-netlib/SRC/zptsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 B( LDB, * ), E( * ), EF( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -221,12 +221,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTsolve * @@ -234,10 +234,10 @@ SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER FACT diff --git a/lapack-netlib/SRC/zpttrf.f b/lapack-netlib/SRC/zpttrf.f index 2f7b630d6e..d46a1c3b32 100644 --- a/lapack-netlib/SRC/zpttrf.f +++ b/lapack-netlib/SRC/zpttrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTTRF( N, D, E, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -80,22 +80,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16PTcomputational * * ===================================================================== SUBROUTINE ZPTTRF( N, D, E, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/SRC/zpttrs.f b/lapack-netlib/SRC/zpttrs.f index 8d6aa39120..146a8e222d 100644 --- a/lapack-netlib/SRC/zpttrs.f +++ b/lapack-netlib/SRC/zpttrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,7 +87,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> B is COMPLEX*16 array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. @@ -109,22 +109,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16PTcomputational * * ===================================================================== SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zptts2.f b/lapack-netlib/SRC/zptts2.f index 3be100a231..0d40d03d3c 100644 --- a/lapack-netlib/SRC/zptts2.f +++ b/lapack-netlib/SRC/zptts2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZPTTS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZPTTS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER IUPLO, LDB, N, NRHS * .. @@ -27,7 +27,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 B( LDB, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,7 +86,7 @@ *> *> \param[in,out] B *> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> B is COMPLEX*16 array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2016 * *> \ingroup complex16PTcomputational * * ===================================================================== SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* June 2016 * * .. Scalar Arguments .. INTEGER IUPLO, LDB, N, NRHS diff --git a/lapack-netlib/SRC/zrot.f b/lapack-netlib/SRC/zrot.f index 3f45090152..f372df0880 100644 --- a/lapack-netlib/SRC/zrot.f +++ b/lapack-netlib/SRC/zrot.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZROT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZROT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * DOUBLE PRECISION C @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 CX( * ), CY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/SRC/zspcon.f b/lapack-netlib/SRC/zspcon.f index 320c1345b9..eae8f9eb99 100644 --- a/lapack-netlib/SRC/zspcon.f +++ b/lapack-netlib/SRC/zspcon.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,22 +106,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zspmv.f b/lapack-netlib/SRC/zspmv.f index 5208d6dfeb..94428010fd 100644 --- a/lapack-netlib/SRC/zspmv.f +++ b/lapack-netlib/SRC/zspmv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,22 +139,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zspr.f b/lapack-netlib/SRC/zspr.f index 9c8fe95c25..f91a99a32d 100644 --- a/lapack-netlib/SRC/zspr.f +++ b/lapack-netlib/SRC/zspr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * * ===================================================================== SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsprfs.f b/lapack-netlib/SRC/zsprfs.f index 5c3e7015f9..3474d75037 100644 --- a/lapack-netlib/SRC/zsprfs.f +++ b/lapack-netlib/SRC/zsprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -167,12 +167,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -180,10 +180,10 @@ SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zspsv.f b/lapack-netlib/SRC/zspsv.f index bc79b478b2..f4c79db3f4 100644 --- a/lapack-netlib/SRC/zspsv.f +++ b/lapack-netlib/SRC/zspsv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERsolve * @@ -162,10 +162,10 @@ * ===================================================================== SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zspsvx.f b/lapack-netlib/SRC/zspsvx.f index 63d66ffeb1..8c4dc105c7 100644 --- a/lapack-netlib/SRC/zspsvx.f +++ b/lapack-netlib/SRC/zspsvx.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -32,7 +32,7 @@ * COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -244,10 +244,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -277,7 +277,7 @@ SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zsptrf.f b/lapack-netlib/SRC/zsptrf.f index 0711550a47..07c6eec4dc 100644 --- a/lapack-netlib/SRC/zsptrf.f +++ b/lapack-netlib/SRC/zsptrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -158,10 +158,10 @@ * ===================================================================== SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsptri.f b/lapack-netlib/SRC/zsptri.f index 82c215f9f7..cb9efc8398 100644 --- a/lapack-netlib/SRC/zsptri.f +++ b/lapack-netlib/SRC/zsptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsptrs.f b/lapack-netlib/SRC/zsptrs.f index e888aa15e5..feb29bcee0 100644 --- a/lapack-netlib/SRC/zsptrs.f +++ b/lapack-netlib/SRC/zsptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zstedc.f b/lapack-netlib/SRC/zstedc.f index b831bc25a1..7809372bcc 100644 --- a/lapack-netlib/SRC/zstedc.f +++ b/lapack-netlib/SRC/zstedc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEDC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, * LRWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION D( * ), E( * ), RWORK( * ) * COMPLEX*16 WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -194,12 +194,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -213,10 +213,10 @@ SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/zstegr.f b/lapack-netlib/SRC/zstegr.f index 16a4e789c6..71f304c1ce 100644 --- a/lapack-netlib/SRC/zstegr.f +++ b/lapack-netlib/SRC/zstegr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEGR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEGR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N @@ -32,7 +32,7 @@ * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,7 +48,7 @@ *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> -*> ZSTEGR is a compatability wrapper around the improved ZSTEMR routine. +*> ZSTEGR is a compatibility wrapper around the improved ZSTEMR routine. *> See DSTEMR for further details. *> *> One important change is that the ABSTOL parameter no longer provides any @@ -105,13 +105,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -119,14 +123,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -235,12 +244,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -256,10 +265,10 @@ SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE diff --git a/lapack-netlib/SRC/zstein.f b/lapack-netlib/SRC/zstein.f index 012c6743ae..ff8384ad4b 100644 --- a/lapack-netlib/SRC/zstein.f +++ b/lapack-netlib/SRC/zstein.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEIN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEIN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * IWORK, IFAIL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDZ, M, N * .. @@ -30,7 +30,7 @@ * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N @@ -221,8 +221,8 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * .. * .. External Functions .. INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH, DNRM2 - EXTERNAL IDAMAX, DASUM, DLAMCH, DNRM2 + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA diff --git a/lapack-netlib/SRC/zstemr.f b/lapack-netlib/SRC/zstemr.f index cc815666ad..681c87adc0 100644 --- a/lapack-netlib/SRC/zstemr.f +++ b/lapack-netlib/SRC/zstemr.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEMR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEMR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, * IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * LOGICAL TRYRAC @@ -33,7 +33,7 @@ * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,13 +153,17 @@ *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION +*> +*> If RANGE='V', the lower bound of the interval to +*> be searched for eigenvalues. VL < VU. +*> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> -*> If RANGE='V', the lower and upper bounds of the interval to +*> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim @@ -167,14 +171,19 @@ *> \param[in] IL *> \verbatim *> IL is INTEGER +*> +*> If RANGE='I', the index of the +*> smallest eigenvalue to be returned. +*> 1 <= IL <= IU <= N, if N > 0. +*> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> -*> If RANGE='I', the indices (in ascending order) of the -*> smallest and largest eigenvalues to be returned. +*> If RANGE='I', the index of the +*> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim @@ -306,12 +315,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -329,10 +338,10 @@ SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -409,7 +418,7 @@ SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, IIL = 0 IIU = 0 NSPLIT = 0 - + IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' * The interval (WL, WU] contains all the wanted eigenvalues. diff --git a/lapack-netlib/SRC/zsteqr.f b/lapack-netlib/SRC/zsteqr.f index 33af78e854..ac47890685 100644 --- a/lapack-netlib/SRC/zsteqr.f +++ b/lapack-netlib/SRC/zsteqr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N @@ -28,7 +28,7 @@ * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * COMPLEX*16 Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,22 +120,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ diff --git a/lapack-netlib/SRC/zsycon.f b/lapack-netlib/SRC/zsycon.f index e0d5009527..98ec83e374 100644 --- a/lapack-netlib/SRC/zsycon.f +++ b/lapack-netlib/SRC/zsycon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -125,10 +125,10 @@ SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsycon_3.f b/lapack-netlib/SRC/zsycon_3.f new file mode 100644 index 0000000000..f279f3c60b --- /dev/null +++ b/lapack-netlib/SRC/zsycon_3.f @@ -0,0 +1,287 @@ +*> \brief \b ZSYCON_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYCON_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYCON_3 estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex symmetric matrix A using the factorization +*> computed by ZSYTRF_RK or ZSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> This routine uses BLAS3 solver ZSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_RK or ZSYTRF_BK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, + $ WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZSYTRS_3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYCON_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + END DO + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL ZSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of ZSYCON_3 +* + END diff --git a/lapack-netlib/SRC/zsycon_rook.f b/lapack-netlib/SRC/zsycon_rook.f index 0828698d35..c7c0c43850 100644 --- a/lapack-netlib/SRC/zsycon_rook.f +++ b/lapack-netlib/SRC/zsycon_rook.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYCON_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -125,7 +125,7 @@ * ================== *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -139,10 +139,10 @@ SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsyconv.f b/lapack-netlib/SRC/zsyconv.f index 68e5ee9c51..94235ef575 100644 --- a/lapack-netlib/SRC/zsyconv.f +++ b/lapack-netlib/SRC/zsyconv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYCONV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, WAY * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), E( * ) * .. -* +* * *> \par Purpose: * ============= @@ -36,7 +36,7 @@ *> \verbatim *> *> ZSYCONV converts A given by ZHETRF into L and D or vice-versa. -*> Get nondiagonal elements of D (returned in workspace) and +*> Get nondiagonal elements of D (returned in workspace) and *> apply or reverse permutation done in TRF. *> \endverbatim * @@ -55,7 +55,7 @@ *> \param[in] WAY *> \verbatim *> WAY is CHARACTER*1 -*> = 'C': Convert +*> = 'C': Convert *> = 'R': Revert *> \endverbatim *> @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, WAY @@ -195,7 +195,7 @@ SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) END DO * * Convert PERMUTATIONS -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0) THEN @@ -226,7 +226,7 @@ SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * Revert A (A is upper) * * Revert PERMUTATIONS -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/zsyconvf.f b/lapack-netlib/SRC/zsyconvf.f new file mode 100644 index 0000000000..5bd93199d6 --- /dev/null +++ b/lapack-netlib/SRC/zsyconvf.f @@ -0,0 +1,562 @@ +*> \brief \b ZSYCONVF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYCONVF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> ZSYCONVF converts the factorization output format used in +*> ZSYTRF provided on entry in parameter A into the factorization +*> output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored +*> on exit in parameters A and E. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in ZSYTRF into +*> the format used in ZSYTRF_RK (or ZSYTRF_BK). +*> +*> If parameter WAY = 'R': +*> ZSYCONVF performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in ZSYTRF_RK +*> (or ZSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in ZSYTRF that is stored +*> on exit in parameter A. It also coverts in place details of +*> the intechanges stored in IPIV from the format used in ZSYTRF_RK +*> (or ZSYTRF_BK) into the format used in ZSYTRF. +*> +*> ZSYCONVF can also convert in Hermitian matrix case, i.e. between +*> formats used in ZHETRF and ZHETRF_RK (or ZHETRF_BK). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> ZSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> ZSYTRF_RK or ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> ZSYTRF_RK or ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> ZSYTRF: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in,out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> +*> 1) If WAY ='C': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in ZSYTRF. +*> On exit, details of the interchanges and the block +*> structure of D in the format used in ZSYTRF_RK +*> ( or ZSYTRF_BK). +*> +*> 1) If WAY ='R': +*> On entry, details of the interchanges and the block +*> structure of D in the format used in ZSYTRF_RK +*> ( or ZSYTRF_BK). +*> On exit, details of the interchanges and the block +*> structure of D in the format used in ZSYTRF. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE ZSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL ZSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYCONVF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL ZSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.(I-1) ) THEN + CALL ZSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i-1 and IPIV(i-1), +* so this should be recorded in two consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I-1 ) +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where k increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL ZSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is no interchnge of rows i and and IPIV(i), +* so this should be reflected in IPIV format for +* *SYTRF_RK ( or *SYTRF_BK) +* + IPIV( I ) = I +* + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS and IPIV +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.(I+1) ) THEN + CALL ZSWAP( I-1, A( IP, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + END IF +* +* Convert IPIV +* There is one interchange of rows i+1 and IPIV(i+1), +* so this should be recorded in consecutive entries +* in IPIV format for *SYTRF +* + IPIV( I ) = IPIV( I+1 ) +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of ZSYCONVF +* + END diff --git a/lapack-netlib/SRC/zsyconvf_rook.f b/lapack-netlib/SRC/zsyconvf_rook.f new file mode 100644 index 0000000000..daddd26012 --- /dev/null +++ b/lapack-netlib/SRC/zsyconvf_rook.f @@ -0,0 +1,547 @@ +*> \brief \b ZSYCONVF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYCONVF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> If parameter WAY = 'C': +*> ZSYCONVF_ROOK converts the factorization output format used in +*> ZSYTRF_ROOK provided on entry in parameter A into the factorization +*> output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored +*> on exit in parameters A and E. IPIV format for ZSYTRF_ROOK and +*> ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted. +*> +*> If parameter WAY = 'R': +*> ZSYCONVF_ROOK performs the conversion in reverse direction, i.e. +*> converts the factorization output format used in ZSYTRF_RK +*> (or ZSYTRF_BK) provided on entry in parameters A and E into +*> the factorization output format used in ZSYTRF_ROOK that is stored +*> on exit in parameter A. IPIV format for ZSYTRF_ROOK and +*> ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted. +*> +*> ZSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between +*> formats used in ZHETRF_ROOK and ZHETRF_RK (or ZHETRF_BK). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix A. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> +*> 1) If WAY ='C': +*> +*> On entry, contains factorization details in format used in +*> ZSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> ZSYTRF_RK or ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains factorization details in format used in +*> ZSYTRF_RK or ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, contains factorization details in format used in +*> ZSYTRF_ROOK: +*> a) all elements of the symmetric block diagonal +*> matrix D on the diagonal of A and on superdiagonal +*> (or subdiagonal) of A, and +*> b) If UPLO = 'U': multipliers used to obtain factor U +*> in the superdiagonal part of A. +*> If UPLO = 'L': multipliers used to obtain factor L +*> in the superdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> +*> 1) If WAY ='C': +*> +*> On entry, just a workspace. +*> +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> 2) If WAY = 'R': +*> +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> On exit, is not changed +*> \endverbatim +*. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On entry, details of the interchanges and the block +*> structure of D as determined: +*> 1) by ZSYTRF_ROOK, if WAY ='C'; +*> 2) by ZSYTRF_RK (or ZSYTRF_BK), if WAY ='R'. +*> The IPIV format is the same for all these routines. +*> +*> On exit, is not changed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* ===================================================================== + SUBROUTINE ZSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL ZSWAP, XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, IP2 +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYCONVF_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin A is UPPER +* + IF ( CONVERT ) THEN +* +* Convert A (A is upper) +* +* +* Convert VALUE +* +* Assign superdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = N + E( 1 ) = ZERO + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + E( I ) = A( I-1, I ) + E( I-1 ) = ZERO + A( I-1, I ) = ZERO + I = I - 1 + ELSE + E( I ) = ZERO + END IF + I = I - 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i-1 and IPIV(i-1) +* in A(1:i,N-i:N) +* + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( I, I+1 ), LDA, + $ A( IP, I+1 ), LDA ) + END IF + IF( IP2.NE.(I-1) ) THEN + CALL ZSWAP( N-I, A( I-1, I+1 ), LDA, + $ A( IP2, I+1 ), LDA ) + END IF + END IF + I = I - 1 +* + END IF + I = I - 1 + END DO +* + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of upper part of A +* in reverse factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(1:i,N-i:N) +* + IP = IPIV( I ) + IF( I.LT.N ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i-1 and IPIV(i-1) and i and IPIV(i) +* in A(1:i,N-i:N) +* + I = I + 1 + IP = -IPIV( I ) + IP2 = -IPIV( I-1 ) + IF( I.LT.N ) THEN + IF( IP2.NE.(I-1) ) THEN + CALL ZSWAP( N-I, A( IP2, I+1 ), LDA, + $ A( I-1, I+1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL ZSWAP( N-I, A( IP, I+1 ), LDA, + $ A( I, I+1 ), LDA ) + END IF + END IF +* + END IF + I = I + 1 + END DO +* +* Revert VALUE +* Assign superdiagonal entries of D from array E to +* superdiagonal entries of A. +* + I = N + DO WHILE ( I.GT.1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I-1, I ) = E( I ) + I = I - 1 + END IF + I = I - 1 + END DO +* +* End A is UPPER +* + END IF +* + ELSE +* +* Begin A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* Assign subdiagonal entries of D to array E and zero out +* corresponding entries in input storage A +* + I = 1 + E( N ) = ZERO + DO WHILE ( I.LE.N ) + IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN + E( I ) = A( I+1, I ) + E( I+1 ) = ZERO + A( I+1, I ) = ZERO + I = I + 1 + ELSE + E( I ) = ZERO + END IF + I = I + 1 + END DO +* +* Convert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in factorization order where i increases from 1 to N +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i and IPIV(i) and i+1 and IPIV(i+1) +* in A(i:N,1:i-1) +* + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + IF( IP2.NE.(I+1) ) THEN + CALL ZSWAP( I-1, A( I+1, 1 ), LDA, + $ A( IP2, 1 ), LDA ) + END IF + END IF + I = I + 1 +* + END IF + I = I + 1 + END DO +* + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* +* Apply permutaions to submatrices of lower part of A +* in reverse factorization order where i decreases from N to 1 +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN +* +* 1-by-1 pivot interchange +* +* Swap rows i and IPIV(i) in A(i:N,1:i-1) +* + IP = IPIV( I ) + IF ( I.GT.1 ) THEN + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot interchange +* +* Swap rows i+1 and IPIV(i+1) and i and IPIV(i) +* in A(i:N,1:i-1) +* + I = I - 1 + IP = -IPIV( I ) + IP2 = -IPIV( I+1 ) + IF ( I.GT.1 ) THEN + IF( IP2.NE.(I+1) ) THEN + CALL ZSWAP( I-1, A( IP2, 1 ), LDA, + $ A( I+1, 1 ), LDA ) + END IF + IF( IP.NE.I ) THEN + CALL ZSWAP( I-1, A( IP, 1 ), LDA, + $ A( I, 1 ), LDA ) + END IF + END IF +* + END IF + I = I - 1 + END DO +* +* Revert VALUE +* Assign subdiagonal entries of D from array E to +* subgiagonal entries of A. +* + I = 1 + DO WHILE ( I.LE.N-1 ) + IF( IPIV( I ).LT.0 ) THEN + A( I + 1, I ) = E( I ) + I = I + 1 + END IF + I = I + 1 + END DO +* + END IF +* +* End A is LOWER +* + END IF + + RETURN +* +* End of ZSYCONVF_ROOK +* + END diff --git a/lapack-netlib/SRC/zsyequb.f b/lapack-netlib/SRC/zsyequb.f index 71b41baa36..715f32b333 100644 --- a/lapack-netlib/SRC/zsyequb.f +++ b/lapack-netlib/SRC/zsyequb.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYEQUB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYEQUB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), WORK( * ) * DOUBLE PRECISION S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -37,12 +37,11 @@ *> \verbatim *> *> ZSYEQUB computes row and column scalings intended to equilibrate a -*> symmetric matrix A and reduce its condition number -*> (with respect to the two-norm). S contains the scale factors, -*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -*> choice of S puts the condition number of B within a factor N of the -*> smallest possible condition number over all possible diagonal +*> symmetric matrix A (with respect to the Euclidean norm) and reduce +*> its condition number. The scale factors S are computed by the BIN +*> algorithm (see references) so that the scaled matrix B with elements +*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of +*> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * @@ -52,30 +51,27 @@ *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 -*> Specifies whether the details of the factorization are stored -*> as an upper or lower triangular matrix. -*> = 'U': Upper triangular, form is A = U*D*U**T; -*> = 'L': Lower triangular, form is A = L*D*L**T. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The order of the matrix A. N >= 0. +*> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is COMPLEX*16 array, dimension (LDA,N) -*> The N-by-N symmetric matrix whose scaling -*> factors are to be computed. Only the diagonal elements of A -*> are referenced. +*> The N-by-N symmetric matrix whose scaling factors are to be +*> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). +*> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S @@ -88,21 +84,21 @@ *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to -*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too +*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION -*> Absolute value of largest matrix element. If AMAX is very -*> close to overflow or very close to underflow, the matrix -*> should be scaled. +*> Largest absolute value of any matrix element. If AMAX is +*> very close to overflow or very close to underflow, the +*> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension (3*N) +*> WORK is COMPLEX*16 array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO @@ -116,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -130,16 +126,16 @@ *> *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n -*> DOI 10.1023/B:NUMA.0000016606.32820.69 \n -*> Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf +*> DOI 10.1023/B:NUMA.0000016606.32820.69 \n +*> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 *> * ===================================================================== SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -180,7 +176,7 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. -* Statement Function Definitions +* .. Statement Function Definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) * .. * .. Executable Statements .. @@ -189,15 +185,15 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * INFO = 0 IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 + INFO = -1 ELSE IF ( N .LT. 0 ) THEN - INFO = -2 + INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 + INFO = -4 END IF IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'ZSYEQUB', -INFO ) - RETURN + CALL XERBLA( 'ZSYEQUB', -INFO ) + RETURN END IF UP = LSAME( UPLO, 'U' ) @@ -206,12 +202,12 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * Quick return if possible. * IF ( N .EQ. 0 ) THEN - SCOND = ONE - RETURN + SCOND = ONE + RETURN END IF DO I = 1, N - S( I ) = ZERO + S( I ) = ZERO END DO AMAX = ZERO @@ -222,7 +218,7 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO - S( J ) = MAX( S( J ), CABS1( A( J, J) ) ) + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) END DO ELSE @@ -231,102 +227,101 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) DO I = J+1, N S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) - S( J ) = MAX( S( J ), CABS1 (A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) END DO END DO END IF DO J = 1, N - S( J ) = 1.0D+0 / S( J ) + S( J ) = 1.0D0 / S( J ) END DO TOL = ONE / SQRT( 2.0D0 * N ) DO ITER = 1, MAX_ITER - SCALE = 0.0D+0 - SUMSQ = 0.0D+0 -* beta = |A|s - DO I = 1, N - WORK( I ) = ZERO - END DO - IF ( UP ) THEN - DO J = 1, N - DO I = 1, J-1 - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - END DO - ELSE - DO J = 1, N - WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) - DO I = J+1, N - T = CABS1( A( I, J ) ) - WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) - WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) - END DO - END DO - END IF + SCALE = 0.0D0 + SUMSQ = 0.0D0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF -* avg = s^T beta / n - AVG = 0.0D+0 - DO I = 1, N - AVG = AVG + S( I )*WORK( I ) - END DO - AVG = AVG / N +* avg = s^T beta / n + AVG = 0.0D0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N - STD = 0.0D+0 - DO I = N+1, 2*N - WORK( I ) = S( I-N ) * WORK( I-N ) - AVG - END DO - CALL ZLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) - STD = SCALE * SQRT( SUMSQ / N ) + STD = 0.0D0 + DO I = N+1, 2*N + WORK( I ) = S( I-N ) * WORK( I-N ) - AVG + END DO + CALL ZLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) - IF ( STD .LT. TOL * AVG ) GOTO 999 + IF ( STD .LT. TOL * AVG ) GOTO 999 - DO I = 1, N - T = CABS1( A( I, I ) ) - SI = S( I ) - C2 = ( N-1 ) * T - C1 = ( N-2 ) * ( WORK( I ) - T*SI ) - C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG - D = C1*C1 - 4*C0*C2 + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 - IF ( D .LE. 0 ) THEN - INFO = -1 - RETURN - END IF - SI = -2*C0 / ( C1 + SQRT( D ) ) + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) - D = SI - S( I ) - U = ZERO - IF ( UP ) THEN - DO J = 1, I - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - ELSE - DO J = 1, I - T = CABS1( A( I, J ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - DO J = I+1,N - T = CABS1( A( J, I ) ) - U = U + S( J )*T - WORK( J ) = WORK( J ) + D*T - END DO - END IF - AVG = AVG + ( U + WORK( I ) ) * D / N - S( I ) = SI - END DO + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO END DO 999 CONTINUE @@ -339,9 +334,9 @@ SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) BASE = DLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N - S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) - SMIN = MIN( SMIN, S( I ) ) - SMAX = MAX( SMAX, S( I ) ) + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) * diff --git a/lapack-netlib/SRC/zsymv.f b/lapack-netlib/SRC/zsymv.f index 0924b2ce27..926a05f258 100644 --- a/lapack-netlib/SRC/zsymv.f +++ b/lapack-netlib/SRC/zsymv.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYMV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYMV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,22 +145,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsyr.f b/lapack-netlib/SRC/zsyr.f index 3f772eb108..2bed66371d 100644 --- a/lapack-netlib/SRC/zsyr.f +++ b/lapack-netlib/SRC/zsyr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, LDA, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsyrfs.f b/lapack-netlib/SRC/zsyrfs.f index 4f9e3f2f54..c114f40c09 100644 --- a/lapack-netlib/SRC/zsyrfs.f +++ b/lapack-netlib/SRC/zsyrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -179,12 +179,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -192,10 +192,10 @@ SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsyrfsx.f b/lapack-netlib/SRC/zsyrfsx.f index 4f48630b50..3420d70cd9 100644 --- a/lapack-netlib/SRC/zsyrfsx.f +++ b/lapack-netlib/SRC/zsyrfsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYRFSX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYRFSX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, * ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO, EQUED * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ) * .. -* +* * *> \par Purpose: * ============= @@ -387,10 +387,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -402,7 +402,7 @@ SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, $ WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -463,12 +463,11 @@ SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, INTRINSIC MAX, SQRT, TRANSFER * .. * .. External Functions .. - EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL LSAME, ILAPREC EXTERNAL DLAMCH, ZLANSY, ZLA_SYRCOND_X, ZLA_SYRCOND_C DOUBLE PRECISION DLAMCH, ZLANSY, ZLA_SYRCOND_X, ZLA_SYRCOND_C LOGICAL LSAME - INTEGER BLAS_FPINFO_X - INTEGER ILATRANS, ILAPREC + INTEGER ILAPREC * .. * .. Executable Statements .. * diff --git a/lapack-netlib/SRC/zsysv.f b/lapack-netlib/SRC/zsysv.f index 717824b4ba..2ff196ca8c 100644 --- a/lapack-netlib/SRC/zsysv.f +++ b/lapack-netlib/SRC/zsysv.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYsolve * @@ -171,10 +171,10 @@ SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK driver 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsysv_aa.f b/lapack-netlib/SRC/zsysv_aa.f new file mode 100644 index 0000000000..c650bed23c --- /dev/null +++ b/lapack-netlib/SRC/zsysv_aa.f @@ -0,0 +1,254 @@ +*> \brief ZSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYSV_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYSV computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. The factored +*> form of A is then used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> ZSYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= MAX(1,2*N,3*N-2), and for +*> the best performance, LWORK >= MAX(1,N*NB), where NB is +*> the optimal blocksize for ZSYTRF_AA. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYsolve +* +* ===================================================================== + SUBROUTINE ZSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, LWKOPT_SYTRF, LWKOPT_SYTRS +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSYTRF, ZSYTRS, ZSYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL ZSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT_SYTRF = INT( WORK(1) ) + CALL ZSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ -1, INFO ) + LWKOPT_SYTRS = INT( WORK(1) ) + LWKOPT = MAX( LWKOPT_SYTRF, LWKOPT_SYTRS ) + WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYSV_AA ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL ZSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL ZSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZSYSV_AA +* + END diff --git a/lapack-netlib/SRC/zsysv_rk.f b/lapack-netlib/SRC/zsysv_rk.f new file mode 100644 index 0000000000..8cc79a728a --- /dev/null +++ b/lapack-netlib/SRC/zsysv_rk.f @@ -0,0 +1,317 @@ +*> \brief ZSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYSV_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYSV_RK computes the solution to a complex system of linear +*> equations A * X = B, where A is an N-by-N symmetric matrix +*> and X and B are N-by-NRHS matrices. +*> +*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used +*> to factor A as +*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or +*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L', +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZSYTRF_RK is called to compute the factorization of a complex +*> symmetric matrix. The factored form of A is then used to solve +*> the system of equations A * X = B by calling BLAS3 routine ZSYTRS_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, if INFO = 0, diagonal of the block diagonal +*> matrix D and factors U or L as computed by ZSYTRF_RK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> For more info see the description of ZSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the output computed by the factorization +*> routine ZSYTRF_RK, i.e. the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> +*> For more info see the description of ZSYTRF_RK routine. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZSYTRF_RK. +*> +*> For more info see the description of ZSYTRF_RK routine. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ). +*> Work array used in the factorization stage. +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1. For best performance +*> of factorization stage LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for ZSYTRF_RK. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array for factorization stage, returns this value as +*> the first entry of the WORK array, and no error message +*> related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSYTRF_RK, ZSYTRS_3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYSV_RK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = P*U*D*(U**T)*(P**T) or +* A = P*U*D*(U**T)*(P**T). +* + CALL ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO ) +* + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B with BLAS3 solver, overwriting B with X. +* + CALL ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZSYSV_RK +* + END diff --git a/lapack-netlib/SRC/zsysv_rook.f b/lapack-netlib/SRC/zsysv_rook.f index 00ba305472..f1448e9dce 100644 --- a/lapack-netlib/SRC/zsysv_rook.f +++ b/lapack-netlib/SRC/zsysv_rook.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYSV_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -47,13 +47,13 @@ *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with -*> 1-by-1 and 2-by-2 diagonal blocks. +*> 1-by-1 and 2-by-2 diagonal blocks. *> *> ZSYTRF_ROOK is called to compute the factorization of a complex *> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal *> pivoting method. *> -*> The factored form of A is then used to solve the system +*> The factored form of A is then used to solve the system *> of equations A * X = B by calling ZSYTRS_ROOK. *> \endverbatim * @@ -154,7 +154,7 @@ *> The length of WORK. LWORK >= 1, and for best performance *> LWORK >= max(1,N*NB), where NB is the optimal blocksize for *> ZSYTRF_ROOK. -*> +*> *> TRS will be done with Level 2 BLAS *> *> If LWORK = -1, then a workspace query is assumed; the routine @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYsolve * @@ -190,7 +190,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -204,10 +204,10 @@ SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsysvx.f b/lapack-netlib/SRC/zsysvx.f index 475a03b5c7..ebebe2e463 100644 --- a/lapack-netlib/SRC/zsysvx.f +++ b/lapack-netlib/SRC/zsysvx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYSVX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYSVX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -271,10 +271,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -285,7 +285,7 @@ SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK driver 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zsysvxx.f b/lapack-netlib/SRC/zsysvxx.f index c2f2f8d7bd..ef44d09d3a 100644 --- a/lapack-netlib/SRC/zsysvxx.f +++ b/lapack-netlib/SRC/zsysvxx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYSVXX + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYSVXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -22,7 +22,7 @@ * EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, * N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, * NPARAMS, PARAMS, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, @@ -37,7 +37,7 @@ * $ ERR_BNDS_NORM( NRHS, * ), * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -491,10 +491,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -506,7 +506,7 @@ SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, $ NPARAMS, PARAMS, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK driver 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..-- * April 2012 @@ -551,7 +551,7 @@ SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, DOUBLE PRECISION DLAMCH, ZLA_SYRPVGRW * .. * .. External Subroutines .. - EXTERNAL ZSYCON, ZSYEQUB, ZSYTRF, ZSYTRS, ZLACPY, + EXTERNAL ZSYEQUB, ZSYTRF, ZSYTRS, ZLACPY, $ ZLAQSY, XERBLA, ZLASCL2, ZSYRFSX * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/SRC/zsyswapr.f b/lapack-netlib/SRC/zsyswapr.f index 712de9d63a..ea79c8fc05 100644 --- a/lapack-netlib/SRC/zsyswapr.f +++ b/lapack-netlib/SRC/zsyswapr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYSWAPR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYSWAPR( UPLO, N, A, LDA, I1, I2) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, N ) -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * * ===================================================================== SUBROUTINE ZSYSWAPR( UPLO, N, A, LDA, I1, I2) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -136,12 +136,12 @@ SUBROUTINE ZSYSWAPR( UPLO, N, A, LDA, I1, I2) * * UPPER * first swap -* - swap column I1 and I2 from I1 to I1-1 +* - swap column I1 and I2 from I1 to I1-1 CALL ZSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP @@ -164,12 +164,12 @@ SUBROUTINE ZSYSWAPR( UPLO, N, A, LDA, I1, I2) * * LOWER * first swap -* - swap row I1 and I2 from I1 to I1-1 +* - swap row I1 and I2 from I1 to I1-1 CALL ZSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) -* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP diff --git a/lapack-netlib/SRC/zsytf2.f b/lapack-netlib/SRC/zsytf2.f index f244ba6b59..766d61c835 100644 --- a/lapack-netlib/SRC/zsytf2.f +++ b/lapack-netlib/SRC/zsytf2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -191,10 +191,10 @@ * ===================================================================== SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsytf2_rk.f b/lapack-netlib/SRC/zsytf2_rk.f new file mode 100644 index 0000000000..b1a02f4a5a --- /dev/null +++ b/lapack-netlib/SRC/zsytf2_rk.f @@ -0,0 +1,952 @@ +*> \brief \b ZSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTF2_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E ( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYTF2_RK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put further details +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., +*> Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN + COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT, DIMAG, DBLE +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTF2_RK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* Initilize the first entry of array E, where superdiagonal +* elements of D are stored +* + E( 1 ) = CZERO +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 34 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.GT.1 ) + $ E( K ) = CZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX )) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL ZSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert upper triangle of A into U form by applying +* the interchanges in columns k+1:N. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) +* + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = CONE / A( K, K ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL ZSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF +* +* Store the superdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = CONE / ( D11*D22-CONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* +* Copy superdiagonal elements of D(K) to E(K) and +* ZERO out superdiagonal entry of A +* + E( K ) = A( K-1, K ) + E( K-1 ) = CZERO + A( K-1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 34 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* Initilize the unused last entry of the subdiagonal array E. +* + E( N ) = CZERO +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 64 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K +* +* Set E( K ) to zero +* + IF( K.LT.N ) + $ E( K ) = CZERO +* + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX )) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) +* + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF +* +* Convert lower triangle of A into L form by applying +* the interchanges in columns 1:k-1. +* + IF ( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) +* + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = CONE / A( K, K ) + CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL ZSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF +* +* Store the subdiagonal element of D in array E +* + E( K ) = CZERO +* + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* +* Copy subdiagonal elements of D(K) to E(K) and +* ZERO out subdiagonal entry of A +* + E( K ) = A( K+1, K ) + E( K+1 ) = CZERO + A( K+1, K ) = CZERO +* + END IF +* +* End column K is nonsingular +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + 64 CONTINUE +* + END IF +* + RETURN +* +* End of ZSYTF2_RK +* + END diff --git a/lapack-netlib/SRC/zsytrf.f b/lapack-netlib/SRC/zsytrf.f index a8888da3c8..663199c8a5 100644 --- a/lapack-netlib/SRC/zsytrf.f +++ b/lapack-netlib/SRC/zsytrf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -182,10 +182,10 @@ * ===================================================================== SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsytrf_aa.f b/lapack-netlib/SRC/zsytrf_aa.f new file mode 100644 index 0000000000..02f8cdda95 --- /dev/null +++ b/lapack-netlib/SRC/zsytrf_aa.f @@ -0,0 +1,480 @@ +*> \brief \b ZSYTRF_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRF_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTRF_AA computes the factorization of a complex symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a complex symmetric tridiagonal matrix. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=MAX(1,2*N). For optimum performance +*> LWORK >= N*(1+NB), where NB is the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +* ===================================================================== + SUBROUTINE ZSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX*16 ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'ZSYTRF', UPLO, N, -1, -1, -1 ) +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRF_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL ZCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with ZGEMM +* + CALL ZGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLASYF_AA( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL ZCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with ZGEMM +* + CALL ZGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of ZSYTRF_AA +* + END diff --git a/lapack-netlib/SRC/zsytrf_rk.f b/lapack-netlib/SRC/zsytrf_rk.f new file mode 100644 index 0000000000..2fabf9d1a3 --- /dev/null +++ b/lapack-netlib/SRC/zsytrf_rk.f @@ -0,0 +1,498 @@ +*> \brief \b ZSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRF_RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYTRF_RK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> For more information see Further Details section. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. +*> If UPLO = 'U': the leading N-by-N upper triangular part +*> of A contains the upper triangular part of the matrix A, +*> and the strictly lower triangular part of A is not +*> referenced. +*> +*> If UPLO = 'L': the leading N-by-N lower triangular part +*> of A contains the lower triangular part of the matrix A, +*> and the strictly upper triangular part of A is not +*> referenced. +*> +*> On exit, contains: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> are stored on exit in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On exit, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is set to 0 in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> IPIV describes the permutation matrix P in the factorization +*> of matrix A as follows. The absolute value of IPIV(k) +*> represents the index of row and column that were +*> interchanged with the k-th row and column. The value of UPLO +*> describes the order in which the interchanges were applied. +*> Also, the sign of IPIV represents the block structure of +*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 +*> diagonal blocks which correspond to 1 or 2 interchanges +*> at each factorization step. For more info see Further +*> Details section. +*> +*> If UPLO = 'U', +*> ( in factorization order, k decreases from N to 1 ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N); +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k-1) < 0 means: +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k-1) != k-1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k-1) = k-1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> +*> If UPLO = 'L', +*> ( in factorization order, k increases from 1 to N ): +*> a) A single positive entry IPIV(k) > 0 means: +*> D(k,k) is a 1-by-1 diagonal block. +*> If IPIV(k) != k, rows and columns k and IPIV(k) were +*> interchanged in the matrix A(1:N,1:N). +*> If IPIV(k) = k, no interchange occurred. +*> +*> b) A pair of consecutive negative entries +*> IPIV(k) < 0 and IPIV(k+1) < 0 means: +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> (NOTE: negative entries in IPIV appear ONLY in pairs). +*> 1) If -IPIV(k) != k, rows and columns +*> k and -IPIV(k) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k) = k, no interchange occurred. +*> 2) If -IPIV(k+1) != k+1, rows and columns +*> k-1 and -IPIV(k-1) were interchanged +*> in the matrix A(1:N,1:N). +*> If -IPIV(k+1) = k+1, no interchange occurred. +*> +*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k. +*> +*> d) NOTE: Any entry IPIV(k) is always NONZERO on output. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned +*> by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> +*> < 0: If INFO = -k, the k-th argument had an illegal value +*> +*> > 0: If INFO = k, the matrix A is singular, because: +*> If UPLO = 'U': column k in the upper +*> triangular part of A contains all zeros. +*> If UPLO = 'L': column k in the lower +*> triangular part of A contains all zeros. +*> +*> Therefore D(k,k) is exactly zero, and superdiagonal +*> elements of column k of U (or subdiagonal elements of +*> column k of L ) are all zeros. The factorization has +*> been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if +*> it is used to solve a system of equations. +*> +*> NOTE: INFO only stores the first occurrence of +*> a singularity, any subsequent occurrence of singularity +*> is not stored in INFO even though the factorization +*> always completes. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> TODO: put correct description +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT, + $ NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZLASYF_RK, ZSYTF2_RK, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'ZSYTRF_RK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRF_RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF_RK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by ZLASYF_RK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 15 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL ZLASYF_RK( UPLO, K, NB, KB, A, LDA, E, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL ZSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k-kb+1:k and apply row permutations to the +* last k+1 colunms k+1:N after that block +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.LT.N ) THEN + DO I = K, ( K - KB + 1 ), -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL ZSWAP( N-K, A( I, K+1 ), LDA, + $ A( IP, K+1 ), LDA ) + END IF + END DO + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* +* This label is the exit from main loop over K decreasing +* from N to 1 in steps of KB +* + 15 CONTINUE +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by ZLASYF_RK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 35 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL ZLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ), + $ IPIV( K ), WORK, LDWORK, IINFO ) + + + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL ZSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ), + $ IPIV( K ), IINFO ) + KB = N - K + 1 +* + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO I = K, K + KB - 1 + IF( IPIV( I ).GT.0 ) THEN + IPIV( I ) = IPIV( I ) + K - 1 + ELSE + IPIV( I ) = IPIV( I ) - K + 1 + END IF + END DO +* +* Apply permutations to the leading panel 1:k-1 +* +* Read IPIV from the last block factored, i.e. +* indices k:k+kb-1 and apply row permutations to the +* first k-1 colunms 1:k-1 before that block +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV( I ) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + IF( K.GT.1 ) THEN + DO I = K, ( K + KB - 1 ), 1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + CALL ZSWAP( K-1, A( I, 1 ), LDA, + $ A( IP, 1 ), LDA ) + END IF + END DO + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* +* This label is the exit from main loop over K increasing +* from 1 to N in steps of KB +* + 35 CONTINUE +* +* End Lower +* + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZSYTRF_RK +* + END diff --git a/lapack-netlib/SRC/zsytrf_rook.f b/lapack-netlib/SRC/zsytrf_rook.f index f5d3e51bf1..3fe69b334a 100644 --- a/lapack-netlib/SRC/zsytrf_rook.f +++ b/lapack-netlib/SRC/zsytrf_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRF_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16SYcomputational * @@ -195,7 +195,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> June 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -208,10 +208,10 @@ * ===================================================================== SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -261,7 +261,7 @@ SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Determine the block size * NB = ILAENV( 1, 'ZSYTRF_ROOK', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB + LWKOPT = MAX( 1, N*NB ) WORK( 1 ) = LWKOPT END IF * @@ -321,7 +321,7 @@ SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + $ INFO = IINFO * * No need to adjust IPIV * diff --git a/lapack-netlib/SRC/zsytri.f b/lapack-netlib/SRC/zsytri.f index 204ed047b1..233026a122 100644 --- a/lapack-netlib/SRC/zsytri.f +++ b/lapack-netlib/SRC/zsytri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsytri2.f b/lapack-netlib/SRC/zsytri2.f index 51abfc6371..69ae389301 100644 --- a/lapack-netlib/SRC/zsytri2.f +++ b/lapack-netlib/SRC/zsytri2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -192,7 +192,7 @@ SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) END IF IF( N.EQ.0 ) $ RETURN - + IF( NBMAX .GE. N ) THEN CALL ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE diff --git a/lapack-netlib/SRC/zsytri2x.f b/lapack-netlib/SRC/zsytri2x.f index 86e282dd4f..a8e068db02 100644 --- a/lapack-netlib/SRC/zsytri2x.f +++ b/lapack-netlib/SRC/zsytri2x.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRI2X + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( N+NB+1,* ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -213,7 +213,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) INFO = 0 * * Splitting Workspace -* U01 is a block (N,NB+1) +* U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) @@ -229,7 +229,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -246,8 +246,8 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K+1,INVD) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K+1,INVD) = -AKKP1 / D K=K+2 END IF END DO @@ -263,7 +263,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -273,7 +273,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CUT=CUT-NNB * -* U01 Block +* U01 Block * DO I=1,CUT DO J=1,NNB @@ -336,7 +336,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I+2 END IF END DO -* +* * U11**T*invD1*U11->U11 * CALL ZTRMM('L','U','T','U',NNB, NNB, @@ -346,7 +346,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) DO J=I,NNB A(CUT+I,CUT+J)=WORK(U11+I,J) END DO - END DO + END DO * * U01**T*invD*U01->A(CUT+I,CUT+J) * @@ -380,7 +380,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -390,9 +390,9 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) ELSE IP=-IPIV(I) I=I+1 - IF ( (I-1) .LT. IP) + IF ( (I-1) .LT. IP) $ CALL ZSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) - IF ( (I-1) .GT. IP) + IF ( (I-1) .GT. IP) $ CALL ZSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 @@ -406,7 +406,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) -* +* K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -423,8 +423,8 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D - WORK(K,INVD+1) = -AKKP1 / D - WORK(K-1,INVD+1) = -AKKP1 / D + WORK(K,INVD+1) = -AKKP1 / D + WORK(K-1,INVD+1) = -AKKP1 / D K=K-2 END IF END DO @@ -440,7 +440,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) NNB=N-CUT ELSE COUNT = 0 -* count negative elements, +* count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO @@ -507,7 +507,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) I=I-2 END IF END DO -* +* * L11**T*invD1*L11->L11 * CALL ZTRMM('L',UPLO,'T','U',NNB, NNB, @@ -526,7 +526,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * CALL ZGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) - + * * L11 = L11**T*invD1*L11 + U01**T*invD*U01 * @@ -564,7 +564,7 @@ SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/zsytri_3.f b/lapack-netlib/SRC/zsytri_3.f new file mode 100644 index 0000000000..99d771a836 --- /dev/null +++ b/lapack-netlib/SRC/zsytri_3.f @@ -0,0 +1,248 @@ +*> \brief \b ZSYTRI_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRI_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYTRI_3 computes the inverse of a complex symmetric indefinite +*> matrix A using the factorization computed by ZSYTRF_RK or ZSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZSYTRI_3 sets the leading dimension of the workspace before calling +*> ZSYTRI_3X that actually computes the inverse. This is the blocked +*> version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_RK or ZSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N+NB+1)*(NB+3). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= (N+NB+1)*(NB+3). +*> +*> If LDWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the optimal +*> size of the WORK array, returns this value as the first +*> entry of the WORK array, and no error message related to +*> LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZSYTRI_3X +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Determine the block size +* + NB = MAX( 1, ILAENV( 1, 'ZSYTRI_3', UPLO, N, -1, -1, -1 ) ) + LWKOPT = ( N+NB+1 ) * ( NB+3 ) +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRI_3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + CALL ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZSYTRI_3 +* + END diff --git a/lapack-netlib/SRC/zsytri_3x.f b/lapack-netlib/SRC/zsytri_3x.f new file mode 100644 index 0000000000..7f999e0612 --- /dev/null +++ b/lapack-netlib/SRC/zsytri_3x.f @@ -0,0 +1,647 @@ +*> \brief \b ZSYTRI_3X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRI_3X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYTRI_3X computes the inverse of a complex symmetric indefinite +*> matrix A using the factorization computed by ZSYTRF_RK or ZSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix. +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, diagonal of the block diagonal matrix D and +*> factors U or L as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> +*> On exit, if INFO = 0, the symmetric inverse of the original +*> matrix. +*> If UPLO = 'U': the upper triangular part of the inverse +*> is formed and the part of A below the diagonal is not +*> referenced; +*> If UPLO = 'L': the lower triangular part of the inverse +*> is formed and the part of A above the diagonal is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_RK or ZSYTRF_BK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N+NB+1,NB+3). +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11 + COMPLEX*16 AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J, + $ U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZSYSWAPR, ZTRTRI, ZTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +* +* Quick return if possible +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRI_3X', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN +* +* Workspace got Non-diag elements of D +* + DO K = 1, N + WORK( K, 1 ) = E( K ) + END DO +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + END DO + END IF +* + INFO = 0 +* +* Splitting Workspace +* U01 is a block ( N, NB+1 ) +* The first element of U01 is in WORK( 1, 1 ) +* U11 is a block ( NB+1, NB+1 ) +* The first element of U11 is in WORK( N+1, 1 ) +* + U11 = N +* +* INVD is a block ( N, 2 ) +* The first element of INVD is in WORK( 1, INVD ) +* + INVD = NB + 2 + + IF( UPPER ) THEN +* +* Begin Upper +* +* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. +* + CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(U) +* + K = 1 + DO WHILE( K.LE.N ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = CONE / A( K, K ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K+1, 1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = WORK( K+1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K, INVD ) = AKP1 / D + WORK( K+1, INVD+1 ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K+1, INVD ) = WORK( K, INVD+1 ) + K = K + 1 + END IF + K = K + 1 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T) * inv(D) * inv(U) +* + CUT = N + DO WHILE( CUT.GT.0 ) + NNB = NB + IF( CUT.LE.NNB ) THEN + NNB = CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT+1-NNB, CUT + IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF + + CUT = CUT - NNB +* +* U01 Block +* + DO I = 1, CUT + DO J = 1, NNB + WORK( I, J ) = A( I, CUT+J ) + END DO + END DO +* +* U11 Block +* + DO I = 1, NNB + WORK( U11+I, I ) = CONE + DO J = 1, I-1 + WORK( U11+I, J ) = CZERO + END DO + DO J = I+1, NNB + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD * U01 +* + I = 1 + DO WHILE( I.LE.CUT ) + IF( IPIV( I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( I, INVD ) * WORK( I, J ) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK( I, J ) + U01_IP1_J = WORK( I+1, J ) + WORK( I, J ) = WORK( I, INVD ) * U01_I_J + $ + WORK( I, INVD+1 ) * U01_IP1_J + WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J + $ + WORK( I+1, INVD+1 ) * U01_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* invD1 * U11 +* + I = 1 + DO WHILE ( I.LE.NNB ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = I, NNB + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + END DO + ELSE + DO J = I, NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J) + WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J + $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* U11**T * invD1 * U11 -> U11 +* + CALL ZTRMM( 'L', 'U', 'T', 'U', NNB, NNB, + $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* +* U01**T * invD * U01 -> A( CUT+I, CUT+J ) +* + CALL ZGEMM( 'T', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ), + $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1), + $ N+NB+1 ) + +* +* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = I, NNB + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T * invD0 * U01 +* + CALL ZTRMM( 'L', UPLO, 'T', 'U', CUT, NNB, + $ CONE, A, LDA, WORK, N+NB+1 ) + +* +* Update U01 +* + DO I = 1, CUT + DO J = 1, NNB + A( I, CUT+J ) = WORK( I, J ) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(U**T) * inv(D) * inv(U) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Upper case. +* +* ( We can use a loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = 1, N + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. +* + CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D) * inv(L) +* + K = N + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 1 x 1 diagonal NNB + WORK( K, INVD ) = CONE / A( K, K ) + WORK( K, INVD+1 ) = CZERO + ELSE +* 2 x 2 diagonal NNB + T = WORK( K-1, 1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = WORK( K-1, 1 ) / T + D = T*( AK*AKP1-CONE ) + WORK( K-1, INVD ) = AKP1 / D + WORK( K, INVD ) = AK / D + WORK( K, INVD+1 ) = -AKKP1 / D + WORK( K-1, INVD+1 ) = WORK( K, INVD+1 ) + K = K - 1 + END IF + K = K - 1 + END DO +* +* inv(L**T) = (inv(L))**T +* +* inv(L**T) * inv(D) * inv(L) +* + CUT = 0 + DO WHILE( CUT.LT.N ) + NNB = NB + IF( (CUT + NNB).GT.N ) THEN + NNB = N - CUT + ELSE + ICOUNT = 0 +* count negative elements, + DO I = CUT + 1, CUT+NNB + IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1 + END DO +* need a even number for a clear cut + IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1 + END IF +* +* L21 Block +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + WORK( I, J ) = A( CUT+NNB+I, CUT+J ) + END DO + END DO +* +* L11 Block +* + DO I = 1, NNB + WORK( U11+I, I) = CONE + DO J = I+1, NNB + WORK( U11+I, J ) = CZERO + END DO + DO J = 1, I-1 + WORK( U11+I, J ) = A( CUT+I, CUT+J ) + END DO + END DO +* +* invD*L21 +* + I = N-CUT-NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+NNB+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J) + END DO + ELSE + DO J = 1, NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* invD1*L11 +* + I = NNB + DO WHILE( I.GE.1 ) + IF( IPIV( CUT+I ).GT.0 ) THEN + DO J = 1, NNB + WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J) + END DO + + ELSE + DO J = 1, NNB + U11_I_J = WORK( U11+I, J ) + U11_IP1_J = WORK( U11+I-1, J ) + WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J) + $ + WORK(CUT+I,INVD+1) * U11_IP1_J + WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J + $ + WORK(CUT+I-1,INVD) * U11_IP1_J + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* L11**T * invD1 * L11 -> L11 +* + CALL ZTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, CONE, + $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ), + $ N+NB+1 ) + +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO +* + IF( (CUT+NNB).LT.N ) THEN +* +* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) +* + CALL ZGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, CONE, + $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1, + $ CZERO, WORK( U11+1, 1 ), N+NB+1 ) + +* +* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T * invD2 * L21 +* + CALL ZTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, CONE, + $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK, + $ N+NB+1 ) +* +* Update L21 +* + DO I = 1, N-CUT-NNB + DO J = 1, NNB + A( CUT+NNB+I, CUT+J ) = WORK( I, J ) + END DO + END DO +* + ELSE +* +* L11 = L11**T * invD1 * L11 +* + DO I = 1, NNB + DO J = 1, I + A( CUT+I, CUT+J ) = WORK( U11+I, J ) + END DO + END DO + END IF +* +* Next Block +* + CUT = CUT + NNB +* + END DO +* +* Apply PERMUTATIONS P and P**T: +* P * inv(L**T) * inv(D) * inv(L) * P**T. +* Interchange rows and columns I and IPIV(I) in reverse order +* from the formation order of IPIV vector for Lower case. +* +* ( We can use a loop over IPIV with increment -1, +* since the ABS value of IPIV(I) represents the row (column) +* index of the interchange with row (column) i in both 1x1 +* and 2x2 pivot cases, i.e. we don't need separate code branches +* for 1x1 and 2x2 pivot cases ) +* + DO I = N, 1, -1 + IP = ABS( IPIV( I ) ) + IF( IP.NE.I ) THEN + IF (I .LT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, I ,IP ) + IF (I .GT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, IP ,I ) + END IF + END DO +* + END IF +* + RETURN +* +* End of ZSYTRI_3X +* + END + diff --git a/lapack-netlib/SRC/zsytri_rook.f b/lapack-netlib/SRC/zsytri_rook.f index b6f15b6735..77aba25409 100644 --- a/lapack-netlib/SRC/zsytri_rook.f +++ b/lapack-netlib/SRC/zsytri_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRI_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,12 +102,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -116,7 +116,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -129,10 +129,10 @@ * ===================================================================== SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -301,7 +301,7 @@ SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) IF( KP.GT.1 ) $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) -* +* TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP @@ -392,7 +392,7 @@ SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) $ ZDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 - END IF + END IF * IF( KSTEP.EQ.1 ) THEN * diff --git a/lapack-netlib/SRC/zsytrs.f b/lapack-netlib/SRC/zsytrs.f index d873eed2e5..c9fcb4afca 100644 --- a/lapack-netlib/SRC/zsytrs.f +++ b/lapack-netlib/SRC/zsytrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,22 +108,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zsytrs2.f b/lapack-netlib/SRC/zsytrs2.f index 6321197f9f..c0ee206a58 100644 --- a/lapack-netlib/SRC/zsytrs2.f +++ b/lapack-netlib/SRC/zsytrs2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -29,7 +29,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,7 +106,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (N) +*> WORK is COMPLEX*16 array, dimension (N) *> \endverbatim *> *> \param[out] INFO @@ -119,23 +119,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16SYcomputational * * ===================================================================== - SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER UPLO @@ -200,7 +200,7 @@ SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = U*D*U**T. * -* P**T * B +* P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN @@ -225,7 +225,7 @@ SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL ZTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] -* +* I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN @@ -277,7 +277,7 @@ SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * * Solve A*X = B, where A = L*D*L**T. * -* P**T * B +* P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN @@ -302,7 +302,7 @@ SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, CALL ZTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] -* +* I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN @@ -324,7 +324,7 @@ SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, END DO * * Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] -* +* CALL ZTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] diff --git a/lapack-netlib/SRC/zsytrs_3.f b/lapack-netlib/SRC/zsytrs_3.f new file mode 100644 index 0000000000..dab361353f --- /dev/null +++ b/lapack-netlib/SRC/zsytrs_3.f @@ -0,0 +1,371 @@ +*> \brief \b ZSYTRS_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRS_3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> ZSYTRS_3 solves a system of linear equations A * X = B with a complex +*> symmetric matrix A using the factorization computed +*> by ZSYTRF_RK or ZSYTRF_BK: +*> +*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), +*> +*> where U (or L) is unit upper (or lower) triangular matrix, +*> U**T (or L**T) is the transpose of U (or L), P is a permutation +*> matrix, P**T is the transpose of P, and D is symmetric and block +*> diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This algorithm is using Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are +*> stored as an upper or lower triangular matrix: +*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); +*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> +*> NOTE: For 1-by-1 diagonal block D(k), where +*> 1 <= k <= N, the element E(k) is not referenced in both +*> UPLO = 'U' or UPLO = 'L' cases. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_RK or ZSYTRF_BK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> December 2016, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0,0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, J, K, KP + COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZSCAL, ZSWAP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRS_3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Begin Upper +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B +* +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL ZTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I = N + DO WHILE ( I.GE.1 ) + IF( IPIV( I ).GT.0 ) THEN + CALL ZSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF ( I.GT.1 ) THEN + AKM1K = E( I ) + AKM1 = A( I-1, I-1 ) / AKM1K + AK = A( I, I ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I-1, J ) / AKM1K + BK = B( I, J ) / AKM1K + B( I-1, J ) = ( AK*BKM1-BK ) / DENOM + B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I - 1 + END IF + I = I - 1 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Upper case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* + ELSE +* +* Begin Lower +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B +* Interchange rows K and IPIV(K) of matrix B in the same order +* that the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with increment 1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = 1, N, 1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I = 1 + DO WHILE ( I.LE.N ) + IF( IPIV( I ).GT.0 ) THEN + CALL ZSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) + ELSE IF( I.LT.N ) THEN + AKM1K = E( I ) + AKM1 = A( I, I ) / AKM1K + AK = A( I+1, I+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO J = 1, NRHS + BKM1 = B( I, J ) / AKM1K + BK = B( I+1, J ) / AKM1K + B( I, J ) = ( AK*BKM1-BK ) / DENOM + B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + END DO + I = I + 1 + END IF + I = I + 1 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL ZTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB ) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* +* Interchange rows K and IPIV(K) of matrix B in reverse order +* from the formation order of IPIV(I) vector for Lower case. +* +* (We can do the simple loop over IPIV with decrement -1, +* since the ABS value of IPIV(I) represents the row index +* of the interchange with row i in both 1x1 and 2x2 pivot cases) +* + DO K = N, 1, -1 + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN + CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + END DO +* +* END Lower +* + END IF +* + RETURN +* +* End of ZSYTRS_3 +* + END diff --git a/lapack-netlib/SRC/zsytrs_aa.f b/lapack-netlib/SRC/zsytrs_aa.f new file mode 100644 index 0000000000..b3c9b9ecdb --- /dev/null +++ b/lapack-netlib/SRC/zsytrs_aa.f @@ -0,0 +1,285 @@ +*> \brief \b ZSYTRS_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRS_AA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTRS_AA solves a system of linear equations A*X = B with a complex +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by ZSYTRF_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> Details of factors computed by ZSYTRF_AA. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges as computed by ZSYTRF_AA. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= MAX(1,3*N-2). +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16SYcomputational +* +* ===================================================================== + SUBROUTINE ZSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX*16 ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER K, KP, LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGTSV, ZSWAP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.MAX( 1, 3*N-2 ) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRS_AA', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + LWKOPT = (3*N-2) + WORK( 1 ) = LWKOPT + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL ZTRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A( 1, 1 ), LDA+1, WORK( N ), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1 ) + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL ZGTSV( N, NRHS, WORK( 1 ), WORK( N ), WORK( 2*N ), B, LDB, + $ INFO ) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1 ) + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL ZGTSV( N, NRHS, WORK( 1 ), WORK(N), WORK( 2*N ), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of ZSYTRS_AA +* + END diff --git a/lapack-netlib/SRC/zsytrs_rook.f b/lapack-netlib/SRC/zsytrs_rook.f index b745b23687..0934336361 100644 --- a/lapack-netlib/SRC/zsytrs_rook.f +++ b/lapack-netlib/SRC/zsytrs_rook.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZSYTRS_ROOK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -122,7 +122,7 @@ *> *> \verbatim *> -*> November 2015, Igor Kozachenko, +*> December 2016, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> @@ -136,10 +136,10 @@ SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ztbcon.f b/lapack-netlib/SRC/ztbcon.f index a34d1e8600..ceff2b9147 100644 --- a/lapack-netlib/SRC/ztbcon.f +++ b/lapack-netlib/SRC/ztbcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTBCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTBCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, KD, LDAB, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -143,10 +143,10 @@ SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ztbrfs.f b/lapack-netlib/SRC/ztbrfs.f index a09bc81e0c..50d9a57be2 100644 --- a/lapack-netlib/SRC/ztbrfs.f +++ b/lapack-netlib/SRC/ztbrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTBRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTBRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -175,12 +175,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -188,10 +188,10 @@ SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztbtrs.f b/lapack-netlib/SRC/ztbtrs.f index 940a4a8576..06de7d788a 100644 --- a/lapack-netlib/SRC/ztbtrs.f +++ b/lapack-netlib/SRC/ztbtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTBTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTBTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -146,10 +146,10 @@ SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztfsm.f b/lapack-netlib/SRC/ztfsm.f index b0807340ec..8d4af937a4 100644 --- a/lapack-netlib/SRC/ztfsm.f +++ b/lapack-netlib/SRC/ztfsm.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTFSM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTFSM + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, * B, LDB ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO * INTEGER LDB, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX*16 A( 0: * ), B( 0: LDB-1, 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -298,10 +298,10 @@ SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, $ B, LDB ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztftri.f b/lapack-netlib/SRC/ztftri.f index 377d9d0f8d..4bc5cfec1d 100644 --- a/lapack-netlib/SRC/ztftri.f +++ b/lapack-netlib/SRC/ztftri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTFTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTFTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO, DIAG * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -221,10 +221,10 @@ * ===================================================================== SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO, DIAG diff --git a/lapack-netlib/SRC/ztfttp.f b/lapack-netlib/SRC/ztfttp.f index 839a42569a..f402ca1659 100644 --- a/lapack-netlib/SRC/ztfttp.f +++ b/lapack-netlib/SRC/ztfttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTFTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTFTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -88,12 +88,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -208,10 +208,10 @@ * ===================================================================== SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ztfttr.f b/lapack-netlib/SRC/ztfttr.f index 7c38295c69..39c7e54c64 100644 --- a/lapack-netlib/SRC/ztfttr.f +++ b/lapack-netlib/SRC/ztfttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTFTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTFTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -216,10 +216,10 @@ * ===================================================================== SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ztgevc.f b/lapack-netlib/SRC/ztgevc.f index 86879640a3..447fc1aef3 100644 --- a/lapack-netlib/SRC/ztgevc.f +++ b/lapack-netlib/SRC/ztgevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGEVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGEVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, * LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N @@ -31,8 +31,8 @@ * COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* -* +* +* * *> \par Purpose: * ============= @@ -43,20 +43,20 @@ *> a pair of complex matrices (S,P), where S and P are upper triangular. *> Matrix pairs of this type are produced by the generalized Schur *> factorization of a complex matrix pair (A,B): -*> +*> *> A = Q*S*Z**H, B = Q*P*Z**H -*> +*> *> as computed by ZGGHRD + ZHGEQZ. -*> +*> *> The right eigenvector x and the left eigenvector y of (S,P) *> corresponding to an eigenvalue w are defined by: -*> +*> *> S*x = w*P*x, (y**H)*S = w*(y**H)*P, -*> +*> *> where y**H denotes the conjugate tranpose of y. *> The eigenvalues are not input to this routine, but are computed *> directly from the diagonal elements of S and P. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of (S,P), or the products Z*X and/or Q*Y, *> where Z and Q are input matrices. @@ -206,12 +206,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -219,10 +219,10 @@ SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/ztgex2.f b/lapack-netlib/SRC/ztgex2.f index c8ecff20ad..26b83dec3e 100644 --- a/lapack-netlib/SRC/ztgex2.f +++ b/lapack-netlib/SRC/ztgex2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGEX2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGEX2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, J1, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,18 +142,18 @@ *> =0: Successful exit. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- -*> conditioned. +*> conditioned. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16GEauxiliary * @@ -190,10 +190,10 @@ SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -266,7 +266,7 @@ SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM ) SA = SCALE*SQRT( SUM ) * -* THRES has been changed from +* THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) diff --git a/lapack-netlib/SRC/ztgexc.f b/lapack-netlib/SRC/ztgexc.f index d9c88bbf2a..cb7b5229a0 100644 --- a/lapack-netlib/SRC/ztgexc.f +++ b/lapack-netlib/SRC/ztgexc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGEXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, IFST, ILST, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N @@ -29,7 +29,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16GEcomputational * @@ -200,10 +200,10 @@ SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ diff --git a/lapack-netlib/SRC/ztgsen.f b/lapack-netlib/SRC/ztgsen.f index 4c991ec40a..8561f23aed 100644 --- a/lapack-netlib/SRC/ztgsen.f +++ b/lapack-netlib/SRC/ztgsen.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, * WORK, LWORK, IWORK, LIWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, @@ -35,7 +35,7 @@ * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -285,12 +285,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16OTHERcomputational * @@ -433,10 +433,10 @@ SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, $ WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ @@ -518,6 +518,7 @@ SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * subspaces. * M = 0 + IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) @@ -529,6 +530,7 @@ SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ M = M + 1 END IF 10 CONTINUE + END IF * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 2*M*( N-M ) ) diff --git a/lapack-netlib/SRC/ztgsja.f b/lapack-netlib/SRC/ztgsja.f index a21a2d6fb2..851f6504a0 100644 --- a/lapack-netlib/SRC/ztgsja.f +++ b/lapack-netlib/SRC/ztgsja.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGSJA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGSJA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, * LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, * Q, LDQ, WORK, NCYCLE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -346,12 +346,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -379,10 +379,10 @@ SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV diff --git a/lapack-netlib/SRC/ztgsna.f b/lapack-netlib/SRC/ztgsna.f index 95c90b9437..77cbdcda06 100644 --- a/lapack-netlib/SRC/ztgsna.f +++ b/lapack-netlib/SRC/ztgsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, * LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N @@ -33,7 +33,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -208,12 +208,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -311,10 +311,10 @@ SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/ztgsy2.f b/lapack-netlib/SRC/ztgsy2.f index cd2f3ef68a..f89effd6cd 100644 --- a/lapack-netlib/SRC/ztgsy2.f +++ b/lapack-netlib/SRC/ztgsy2.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGSY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGSY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N @@ -31,7 +31,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. -* +* * *> \par Purpose: * ============= @@ -239,12 +239,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16SYauxiliary * @@ -259,10 +259,10 @@ SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/ztgsyl.f b/lapack-netlib/SRC/ztgsyl.f index ab41c7e1ab..2122a09ca4 100644 --- a/lapack-netlib/SRC/ztgsyl.f +++ b/lapack-netlib/SRC/ztgsyl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTGSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTGSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, @@ -34,7 +34,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -255,12 +255,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -295,10 +295,10 @@ SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/SRC/ztpcon.f b/lapack-netlib/SRC/ztpcon.f index 21f100b47a..41f1ae42cd 100644 --- a/lapack-netlib/SRC/ztpcon.f +++ b/lapack-netlib/SRC/ztpcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -130,10 +130,10 @@ SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ztplqt.f b/lapack-netlib/SRC/ztplqt.f new file mode 100644 index 0000000000..28740208fe --- /dev/null +++ b/lapack-netlib/SRC/ztplqt.f @@ -0,0 +1,270 @@ +*> \brief \b ZTPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a complex +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL ZTPLQT2, ZTPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL ZTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL ZTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of ZTPLQT +* + END diff --git a/lapack-netlib/SRC/ztplqt2.f b/lapack-netlib/SRC/ztplqt2.f new file mode 100644 index 0000000000..733f9dcccd --- /dev/null +++ b/lapack-netlib/SRC/ztplqt2.f @@ -0,0 +1,333 @@ +*> \brief \b ZTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTPLQT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" +*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> using the compact WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The total number of rows of the matrix B. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B, and the order of +*> the triangular matrix A. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the lower triangular M-by-M matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,M) +*> The N-by-N upper triangular factor T of the block reflector. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ][ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L +*> upper trapezoidal matrix B2: +*> +*> B = [ B1 ][ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L lower trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> +*> C = [ A ][ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> +*> W = [ I ][ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> +*> W = [ V1 ][ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> The (M+N)-by-(M+N) block reflector H is then given by +*> +*> H = I - W**T * T * W +*> +*> where W^H is the conjugate transpose of W and T is the upper triangular +*> factor of the block reflector. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER( ZERO = ( 0.0D+0, 0.0D+0 ),ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, P, MP, NP + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL ZLARFG, ZGEMV, ZGERC, ZTRMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTPLQT2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) RETURN +* + DO I = 1, M +* +* Generate elementary reflector H(I) to annihilate B(I,:) +* + P = N-L+MIN( L, I ) + CALL ZLARFG( P+1, A( I, I ), B( I, 1 ), LDB, T( 1, I ) ) + T(1,I)=CONJG(T(1,I)) + IF( I.LT.M ) THEN + DO J = 1, P + B( I, J ) = CONJG(B(I,J)) + END DO +* +* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] +* + DO J = 1, M-I + T( M, J ) = (A( I+J, I )) + END DO + CALL ZGEMV( 'N', M-I, P, ONE, B( I+1, 1 ), LDB, + $ B( I, 1 ), LDB, ONE, T( M, 1 ), LDT ) +* +* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H +* + ALPHA = -(T( 1, I )) + DO J = 1, M-I + A( I+J, I ) = A( I+J, I ) + ALPHA*(T( M, J )) + END DO + CALL ZGERC( M-I, P, (ALPHA), T( M, 1 ), LDT, + $ B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + DO J = 1, P + B( I, J ) = CONJG(B(I,J)) + END DO + END IF + END DO +* + DO I = 2, M +* +* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N)) +* + ALPHA = -(T( 1, I )) + DO J = 1, I-1 + T( I, J ) = ZERO + END DO + P = MIN( I-1, L ) + NP = MIN( N-L+1, N ) + MP = MIN( P+1, M ) + DO J = 1, N-L+P + B(I,J)=CONJG(B(I,J)) + END DO +* +* Triangular part of B2 +* + DO J = 1, P + T( I, J ) = (ALPHA*B( I, N-L+J )) + END DO + CALL ZTRMV( 'L', 'N', 'N', P, B( 1, NP ), LDB, + $ T( I, 1 ), LDT ) +* +* Rectangular part of B2 +* + CALL ZGEMV( 'N', I-1-P, L, ALPHA, B( MP, NP ), LDB, + $ B( I, NP ), LDB, ZERO, T( I,MP ), LDT ) +* +* B1 + +* + CALL ZGEMV( 'N', I-1, N-L, ALPHA, B, LDB, B( I, 1 ), LDB, + $ ONE, T( I, 1 ), LDT ) +* + +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) +* + DO J = 1, I-1 + T(I,J)=CONJG(T(I,J)) + END DO + CALL ZTRMV( 'L', 'C', 'N', I-1, T, LDT, T( I, 1 ), LDT ) + DO J = 1, I-1 + T(I,J)=CONJG(T(I,J)) + END DO + DO J = 1, N-L+P + B(I,J)=CONJG(B(I,J)) + END DO +* +* T(I,I) = tau(I) +* + T( I, I ) = T( 1, I ) + T( 1, I ) = ZERO + END DO + DO I=1,M + DO J= I+1,M + T(I,J)=(T(J,I)) + T(J,I)=ZERO + END DO + END DO + +* +* End of ZTPLQT2 +* + END diff --git a/lapack-netlib/SRC/ztpmlqt.f b/lapack-netlib/SRC/ztpmlqt.f new file mode 100644 index 0000000000..f9540e1128 --- /dev/null +++ b/lapack-netlib/SRC/ztpmlqt.f @@ -0,0 +1,366 @@ +*> \brief \b ZTPMLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, +* A, LDA, B, LDB, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. +* COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), +* $ T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPMQRT applies a complex orthogonal matrix Q obtained from a +*> "triangular-pentagonal" real block reflector H to a general +*> real matrix C, which consists of two blocks A and B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**C from the Left; +*> = 'R': apply Q or Q**C from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Transpose, apply Q**C. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The order of the trapezoidal part of V. +*> K >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size used for the storage of T. K >= MB >= 1. +*> This must be the same value of MB used to generate T +*> in DTPLQT. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDA,K) +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DTPLQT in B. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If SIDE = 'L', LDV >= max(1,M); +*> if SIDE = 'R', LDV >= max(1,N). +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,K) +*> The upper triangular factors of the block reflectors +*> as returned by DTPLQT, stored as a MB-by-K matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA,N) if SIDE = 'L' or +*> (LDA,K) if SIDE = 'R' +*> On entry, the K-by-N or M-by-K matrix A. +*> On exit, A is overwritten by the corresponding block of +*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDC >= max(1,K); +*> If SIDE = 'R', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,N) +*> On entry, the M-by-N matrix B. +*> On exit, B is overwritten by the corresponding block of +*> Q*C or Q**C*C or C*Q or C*Q**C. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. +*> LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array. The dimension of WORK is +*> N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The columns of the pentagonal matrix V contain the elementary reflectors +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> trapezoidal block V2: +*> +*> V = [V1] [V2]. +*> +*> +*> The size of the trapezoidal block V2 is determined by the parameter L, +*> where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L +*> rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; +*> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. +*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. +*> [B] +*> +*> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. +*> +*> The real orthogonal matrix Q is formed from V and T. +*> +*> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. +*> +*> If TRANS='C' and SIDE='L', C is on exit replaced with Q**C * C. +*> +*> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. +*> +*> If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**C. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, + $ A, LDA, B, LDB, WORK, INFO ) +* +* -- LAPACK computational 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 .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT +* .. +* .. Array Arguments .. + COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), + $ T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LEFT, RIGHT, TRAN, NOTRAN + INTEGER I, IB, NB, LB, KF, LDAQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTPRFB +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* .. Test the input arguments .. +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + RIGHT = LSAME( SIDE, 'R' ) + TRAN = LSAME( TRANS, 'C' ) + NOTRAN = LSAME( TRANS, 'N' ) +* + IF ( LEFT ) THEN + LDAQ = MAX( 1, K ) + ELSE IF ( RIGHT ) THEN + LDAQ = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. L.GT.K ) THEN + INFO = -6 + ELSE IF( MB.LT.1 .OR. (MB.GT.K .AND. K.GT.0) ) THEN + INFO = -7 + ELSE IF( LDV.LT.K ) THEN + INFO = -9 + ELSE IF( LDT.LT.MB ) THEN + INFO = -11 + ELSE IF( LDA.LT.LDAQ ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTPMLQT', -INFO ) + RETURN + END IF +* +* .. Quick return if possible .. +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN +* + IF( LEFT .AND. NOTRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL ZTPRFB( 'L', 'C', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. TRAN ) THEN +* + DO I = 1, K, MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL ZTPRFB( 'R', 'N', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + ELSE IF( LEFT .AND. TRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( M-L+I+IB-1, M ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = 0 + END IF + CALL ZTPRFB( 'L', 'N', 'F', 'R', NB, N, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( I, 1 ), LDA, B, LDB, WORK, IB ) + END DO +* + ELSE IF( RIGHT .AND. NOTRAN ) THEN +* + KF = ((K-1)/MB)*MB+1 + DO I = KF, 1, -MB + IB = MIN( MB, K-I+1 ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF + CALL ZTPRFB( 'R', 'C', 'F', 'R', M, NB, IB, LB, + $ V( I, 1 ), LDV, T( 1, I ), LDT, + $ A( 1, I ), LDA, B, LDB, WORK, M ) + END DO +* + END IF +* + RETURN +* +* End of ZTPMLQT +* + END diff --git a/lapack-netlib/SRC/ztpmqrt.f b/lapack-netlib/SRC/ztpmqrt.f index 87ae54172f..a1b53a3c76 100644 --- a/lapack-netlib/SRC/ztpmqrt.f +++ b/lapack-netlib/SRC/ztpmqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPMQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPMQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * A, LDA, B, LDB, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. -* COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), +* COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZTPMQRT applies a complex orthogonal matrix Q obtained from a +*> ZTPMQRT applies a complex orthogonal matrix Q obtained from a *> "triangular-pentagonal" complex block reflector H to a general *> complex matrix C, which consists of two blocks A and B. *> \endverbatim @@ -69,7 +69,7 @@ *> N is INTEGER *> The number of columns of the matrix B. N >= 0. *> \endverbatim -*> +*> *> \param[in] K *> \verbatim *> K is INTEGER @@ -80,7 +80,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -124,19 +124,19 @@ *> \param[in,out] A *> \verbatim *> A is COMPLEX*16 array, dimension -*> (LDA,N) if SIDE = 'L' or +*> (LDA,N) if SIDE = 'L' or *> (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of +*> On exit, A is overwritten by the corresponding block of *> Q*C or Q**H*C or C*Q or C*Q**H. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -150,7 +150,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -185,20 +185,20 @@ *> \verbatim *> *> The columns of the pentagonal matrix V contain the elementary reflectors -*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a +*> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a *> trapezoidal block V2: *> *> V = [V1] *> [V2]. *> -*> The size of the trapezoidal block V2 is determined by the parameter L, +*> The size of the trapezoidal block V2 is determined by the parameter L, *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. *> -*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. -*> [B] -*> +*> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. +*> [B] +*> *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. *> *> The complex orthogonal matrix Q is formed from V and T. @@ -216,17 +216,17 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. - COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), + COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), $ WORK( * ) * .. * @@ -242,7 +242,7 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB + EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -256,7 +256,7 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) -* +* IF ( LEFT ) THEN LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) @@ -275,7 +275,7 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN - INFO = -6 + INFO = -6 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN @@ -307,11 +307,11 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-M+L-I+1 END IF - CALL ZTPRFB( 'L', 'C', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL ZTPRFB( 'L', 'C', 'F', 'C', MB, N, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO -* +* ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB @@ -322,8 +322,8 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, ELSE LB = MB-N+L-I+1 END IF - CALL ZTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + CALL ZTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * @@ -331,15 +331,15 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 - END IF + END IF CALL ZTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * @@ -347,7 +347,7 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB - IB = MIN( NB, K-I+1 ) + IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 @@ -355,7 +355,7 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, LB = MB-N+L-I+1 END IF CALL ZTPRFB( 'R', 'C', 'F', 'C', M, MB, IB, LB, - $ V( 1, I ), LDV, T( 1, I ), LDT, + $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * diff --git a/lapack-netlib/SRC/ztpqrt.f b/lapack-netlib/SRC/ztpqrt.f index 05fc88448a..c6f186bd02 100644 --- a/lapack-netlib/SRC/ztpqrt.f +++ b/lapack-netlib/SRC/ztpqrt.f @@ -2,41 +2,41 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPQRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZTPQRT computes a blocked QR factorization of a complex -*> "triangular-pentagonal" matrix C, which is composed of a -*> triangular block A and pentagonal block B, using the compact +*> ZTPQRT computes a blocked QR factorization of a complex +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact *> WY representation for Q. *> \endverbatim * @@ -46,7 +46,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -88,7 +88,7 @@ *> \param[in,out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -105,7 +105,7 @@ *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See Further Details. *> \endverbatim -*> +*> *> \param[in] LDT *> \verbatim *> LDT is INTEGER @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -141,10 +141,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -154,8 +154,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -169,17 +169,17 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> *> The number of blocks is B = ceiling(N/NB), where each -*> block is of order NB except for the last block, which is of order +*> block is of order NB except for the last block, which is of order *> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block -*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB +*> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. @@ -189,10 +189,10 @@ SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -240,7 +240,7 @@ SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, IF( M.EQ.0 .OR. N.EQ.0 ) RETURN * DO I = 1, N, NB -* +* * Compute the QR factorization of the current block * IB = MIN( N-I+1, NB ) @@ -251,20 +251,20 @@ SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, LB = MB-M+L-I+1 END IF * - CALL ZTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, + CALL ZTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, $ T(1, I ), LDT, IINFO ) * * Update by applying H**H to B(:,I+IB:N) from the left * IF( I+IB.LE.N ) THEN CALL ZTPRFB( 'L', 'C', 'F', 'C', MB, N-I-IB+1, IB, LB, - $ B( 1, I ), LDB, T( 1, I ), LDT, - $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, + $ B( 1, I ), LDB, T( 1, I ), LDT, + $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, $ WORK, IB ) END IF END DO RETURN -* +* * End of ZTPQRT * END diff --git a/lapack-netlib/SRC/ztpqrt2.f b/lapack-netlib/SRC/ztpqrt2.f index 01e744d8e4..2d9300b609 100644 --- a/lapack-netlib/SRC/ztpqrt2.f +++ b/lapack-netlib/SRC/ztpqrt2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPQRT2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPQRT2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -34,7 +34,7 @@ *> \verbatim *> *> ZTPQRT2 computes a QR factorization of a complex "triangular-pentagonal" -*> matrix C, which is composed of a triangular block A and pentagonal block B, +*> matrix C, which is composed of a triangular block A and pentagonal block B, *> using the compact WY representation for Q. *> \endverbatim * @@ -44,7 +44,7 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The total number of rows of the matrix B. +*> The total number of rows of the matrix B. *> M >= 0. *> \endverbatim *> @@ -59,7 +59,7 @@ *> \param[in] L *> \verbatim *> L is INTEGER -*> The number of rows of the upper trapezoidal part of B. +*> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> @@ -80,7 +80,7 @@ *> \param[in,out] B *> \verbatim *> B is COMPLEX*16 array, dimension (LDB,N) -*> On entry, the pentagonal M-by-N matrix B. The first M-L rows +*> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -128,10 +128,10 @@ *> *> \verbatim *> -*> The input matrix C is a (N+M)-by-N matrix +*> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] -*> [ B ] +*> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N @@ -141,8 +141,8 @@ *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a -*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, -*> B is rectangular M-by-N; if M=L=N, B is upper triangular. +*> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C @@ -156,12 +156,12 @@ *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which -*> we call V above. Note that V has the same form as B; that is, +*> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> -*> The columns of V represent the vectors which define the H(i)'s. +*> The columns of V represent the vectors which define the H(i)'s. *> The (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**H @@ -173,10 +173,10 @@ * ===================================================================== SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L @@ -227,7 +227,7 @@ SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) RETURN -* +* DO I = 1, N * * Generate elementary reflector H(I) to annihilate B(:,I) @@ -241,16 +241,16 @@ SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) DO J = 1, N-I T( J, N ) = CONJG(A( I, I+J )) END DO - CALL ZGEMV( 'C', P, N-I, ONE, B( 1, I+1 ), LDB, + CALL ZGEMV( 'C', P, N-I, ONE, B( 1, I+1 ), LDB, $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) * * C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)**H * - ALPHA = -CONJG(T( I, 1 )) + ALPHA = -CONJG(T( I, 1 )) DO J = 1, N-I A( I, I+J ) = A( I, I+J ) + ALPHA*CONJG(T( J, N )) END DO - CALL ZGERC( P, N-I, ALPHA, B( 1, I ), 1, + CALL ZGERC( P, N-I, ALPHA, B( 1, I ), 1, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO @@ -278,13 +278,13 @@ SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * Rectangular part of B2 * - CALL ZGEMV( 'C', L, I-1-P, ALPHA, B( MP, NP ), LDB, + CALL ZGEMV( 'C', L, I-1-P, ALPHA, B( MP, NP ), LDB, $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) * * B1 * - CALL ZGEMV( 'C', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, - $ ONE, T( 1, I ), 1 ) + CALL ZGEMV( 'C', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, + $ ONE, T( 1, I ), 1 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * @@ -295,7 +295,7 @@ SUBROUTINE ZTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO - + * * End of ZTPQRT2 * diff --git a/lapack-netlib/SRC/ztprfb.f b/lapack-netlib/SRC/ztprfb.f index 6e452bb693..1a62829d5b 100644 --- a/lapack-netlib/SRC/ztprfb.f +++ b/lapack-netlib/SRC/ztprfb.f @@ -2,44 +2,44 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPRFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPRFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * -* SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, +* SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), +* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ V( LDV, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZTPRFB applies a complex "triangular-pentagonal" block reflector H or its -*> conjugate transpose H**H to a complex matrix C, which is composed of two +*> ZTPRFB applies a complex "triangular-pentagonal" block reflector H or its +*> conjugate transpose H**H to a complex matrix C, which is composed of two *> blocks A and B, either from the left or right. -*> +*> *> \endverbatim * * Arguments: @@ -80,14 +80,14 @@ *> \param[in] M *> \verbatim *> M is INTEGER -*> The number of rows of the matrix B. +*> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER -*> The number of columns of the matrix B. +*> The number of columns of the matrix B. *> N >= 0. *> \endverbatim *> @@ -95,14 +95,14 @@ *> \verbatim *> K is INTEGER *> The order of the matrix T, i.e. the number of elementary -*> reflectors whose product defines the block reflector. +*> reflectors whose product defines the block reflector. *> K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER -*> The order of the trapezoidal part of V. +*> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> @@ -129,13 +129,13 @@ *> \verbatim *> T is COMPLEX*16 array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the -*> block reflector. +*> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER -*> The leading dimension of the array T. +*> The leading dimension of the array T. *> LDT >= K. *> \endverbatim *> @@ -144,16 +144,16 @@ *> A is COMPLEX*16 array, dimension *> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. -*> On exit, A is overwritten by the corresponding block of -*> H*C or H**H*C or C*H or C*H**H. See Futher Details. +*> On exit, A is overwritten by the corresponding block of +*> H*C or H**H*C or C*H or C*H**H. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER -*> The leading dimension of the array A. +*> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); -*> If SIDE = 'R', LDC >= max(1,M). +*> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B @@ -167,7 +167,7 @@ *> \param[in] LDB *> \verbatim *> LDB is INTEGER -*> The leading dimension of the array B. +*> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> @@ -182,19 +182,19 @@ *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= K; +*> If SIDE = 'L', LDWORK >= K; *> if SIDE = 'R', LDWORK >= M. *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -204,21 +204,21 @@ *> \verbatim *> *> The matrix C is a composite matrix formed from blocks A and B. -*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, +*> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, *> and if SIDE = 'L', A is of size K-by-N. *> *> If SIDE = 'R' and DIRECT = 'F', C = [A B]. *> -*> If SIDE = 'L' and DIRECT = 'F', C = [A] +*> If SIDE = 'L' and DIRECT = 'F', C = [A] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] -*> [A]. +*> [A]. *> -*> The pentagonal matrix V is composed of a rectangular block V1 and a -*> trapezoidal block V2. The size of the trapezoidal block is determined by +*> The pentagonal matrix V is composed of a rectangular block V1 and a +*> trapezoidal block V2. The size of the trapezoidal block is determined by *> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; *> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. *> @@ -235,7 +235,7 @@ *> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] -*> +*> *> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) *> *> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. @@ -248,20 +248,20 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, + SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), + COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * @@ -325,7 +325,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END IF * * --------------------------------------------------------------------------- -* +* IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -339,34 +339,34 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - T (A + V**H B) or A = A - T**H (A + V**H B) -* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) +* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) -* +* DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL ZTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( MP, 1 ), LDV, - $ WORK, LDWORK ) - CALL ZGEMM( 'C', 'N', L, N, M-L, ONE, V, LDV, B, LDB, + $ WORK, LDWORK ) + CALL ZGEMM( 'C', 'N', L, N, M-L, ONE, V, LDV, B, LDB, $ ONE, WORK, LDWORK ) - CALL ZGEMM( 'C', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, + CALL ZGEMM( 'C', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) -* +* DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL ZTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL ZTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) @@ -376,7 +376,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL ZGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL ZGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, - $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) + $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL ZTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N @@ -386,7 +386,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -405,7 +405,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) @@ -413,20 +413,20 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL ZTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) - CALL ZGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, + CALL ZGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, $ V, LDV, ONE, WORK, LDWORK ) - CALL ZGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL ZGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL ZTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL ZTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -446,7 +446,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -460,7 +460,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W T W**H or H**H = I - W T**H W**H * * A = A - T (A + V**H B) or A = A - T**H (A + V**H B) -* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) +* B = B - V T (A + V**H B) or B = B - V T**H (A + V**H B) * * --------------------------------------------------------------------------- * @@ -475,10 +475,10 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL ZTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) - CALL ZGEMM( 'C', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, + CALL ZGEMM( 'C', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL ZGEMM( 'C', 'N', K-L, N, M, ONE, V, LDV, - $ B, LDB, ZERO, WORK, LDWORK ) + $ B, LDB, ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K @@ -486,16 +486,16 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, + CALL ZTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * - CALL ZGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, + CALL ZGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL ZGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) @@ -508,7 +508,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -527,7 +527,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) -* +* DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) @@ -535,20 +535,20 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO CALL ZTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) - CALL ZGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, + CALL ZGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) - CALL ZGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, + CALL ZGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V, LDV, ZERO, WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * - CALL ZTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL ZTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) -* +* DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) @@ -568,7 +568,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -581,7 +581,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - T (A + V B) or A = A - T**H (A + V B) -* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) +* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) * * --------------------------------------------------------------------------- * @@ -592,12 +592,12 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO - END DO + END DO CALL ZTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDB ) - CALL ZGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, + CALL ZGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, $ ONE, WORK, LDWORK ) - CALL ZGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, + CALL ZGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N @@ -606,7 +606,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, + CALL ZTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N @@ -617,7 +617,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL ZGEMM( 'C', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) - CALL ZGEMM( 'C', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, + CALL ZGEMM( 'C', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL ZTRMM( 'L', 'L', 'C', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) @@ -628,7 +628,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -656,7 +656,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ WORK, LDWORK ) CALL ZGEMM( 'N', 'C', M, L, N-L, ONE, B, LDB, V, LDV, $ ONE, WORK, LDWORK ) - CALL ZGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, + CALL ZGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K @@ -665,7 +665,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, + CALL ZTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -674,10 +674,10 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL ZGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL ZGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, - $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) + $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL ZTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L @@ -687,7 +687,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- @@ -700,7 +700,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * H = I - W**H T W or H**H = I - W**H T**H W * * A = A - T (A + V B) or A = A - T**H (A + V B) -* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) +* B = B - V**H T (A + V B) or B = B - V**H T**H (A + V B) * * --------------------------------------------------------------------------- * @@ -736,10 +736,10 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * CALL ZGEMM( 'C', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) - CALL ZGEMM( 'C', 'N', L, N, K-L, -ONE, V, LDV, + CALL ZGEMM( 'C', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL ZTRMM( 'L', 'U', 'C', 'N', L, N, ONE, V( KP, 1 ), LDV, - $ WORK( KP, 1 ), LDWORK ) + $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) @@ -747,7 +747,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO * * --------------------------------------------------------------------------- -* +* ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- @@ -776,7 +776,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, CALL ZGEMM( 'N', 'C', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL ZGEMM( 'N', 'C', M, K-L, N, ONE, B, LDB, V, LDV, - $ ZERO, WORK, LDWORK ) + $ ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M @@ -784,7 +784,7 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, + CALL ZTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K @@ -793,9 +793,9 @@ SUBROUTINE ZTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, END DO END DO * - CALL ZGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, + CALL ZGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) - CALL ZGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, + CALL ZGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL ZTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) diff --git a/lapack-netlib/SRC/ztprfs.f b/lapack-netlib/SRC/ztprfs.f index 7db0cef885..d6a29d40c7 100644 --- a/lapack-netlib/SRC/ztprfs.f +++ b/lapack-netlib/SRC/ztprfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, LDX, N, NRHS @@ -29,7 +29,7 @@ * DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ) * COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -174,10 +174,10 @@ SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztptri.f b/lapack-netlib/SRC/ztptri.f index 187c9ccac1..35388194c3 100644 --- a/lapack-netlib/SRC/ztptri.f +++ b/lapack-netlib/SRC/ztptri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -117,10 +117,10 @@ * ===================================================================== SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ztptrs.f b/lapack-netlib/SRC/ztptrs.f index 8f0338a2c3..c1a852c7b7 100644 --- a/lapack-netlib/SRC/ztptrs.f +++ b/lapack-netlib/SRC/ztptrs.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,22 +118,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztpttf.f b/lapack-netlib/SRC/ztpttf.f index 35228135f3..9dfc795eea 100644 --- a/lapack-netlib/SRC/ztpttf.f +++ b/lapack-netlib/SRC/ztpttf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * COMPLEX*16 AP( 0: * ), ARF( 0: * ) -* +* * *> \par Purpose: * ============= @@ -87,12 +87,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -207,10 +207,10 @@ * ===================================================================== SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ztpttr.f b/lapack-netlib/SRC/ztpttr.f index 3009e10bbb..17ebc0a25e 100644 --- a/lapack-netlib/SRC/ztpttr.f +++ b/lapack-netlib/SRC/ztpttr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTPTTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTPTTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ztrcon.f b/lapack-netlib/SRC/ztrcon.f index bc6029bd97..e7cc1968d1 100644 --- a/lapack-netlib/SRC/ztrcon.f +++ b/lapack-netlib/SRC/ztrcon.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRCON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRCON + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, LDA, N @@ -30,7 +30,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -137,10 +137,10 @@ SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO diff --git a/lapack-netlib/SRC/ztrevc.f b/lapack-netlib/SRC/ztrevc.f index 630a551329..678cf94e74 100644 --- a/lapack-netlib/SRC/ztrevc.f +++ b/lapack-netlib/SRC/ztrevc.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTREVC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, MM, M, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, M, MM, N @@ -31,7 +31,7 @@ * COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -42,16 +42,16 @@ *> a complex upper triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. -*> +*> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: -*> +*> *> T*x = w*x, (y**H)*T = w*(y**H) -*> +*> *> where y**H denotes the conjugate transpose of the vector y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal of T. -*> +*> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the unitary factor that reduces a matrix A to @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -218,10 +218,10 @@ SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE diff --git a/lapack-netlib/SRC/ztrevc3.f b/lapack-netlib/SRC/ztrevc3.f new file mode 100644 index 0000000000..ef83311740 --- /dev/null +++ b/lapack-netlib/SRC/ztrevc3.f @@ -0,0 +1,631 @@ +*> \brief \b ZTREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTREVC3 computes some or all of the right and/or left eigenvectors of +*> a complex upper triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of the vector y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the unitary factor that reduces a matrix A to +*> Schur form T, then Q*X and Q*Y are the matrices of right and left +*> eigenvectors of A. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed using the matrices supplied in +*> VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> The eigenvector corresponding to the j-th eigenvalue is +*> computed if SELECT(j) = .TRUE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> The upper triangular matrix T. T is modified, but restored +*> on exit. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is COMPLEX*16 array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is COMPLEX*16 array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected eigenvector occupies one column. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,2*N). +*> For optimum performance, LWORK >= N + 2*N*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (LRWORK) +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of array RWORK. LRWORK >= max(1,N). +*> +*> If LRWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the RWORK array, returns +*> this value as the first entry of the RWORK array, and no error +*> message related to LRWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran z -> c +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) + IMPLICIT NONE +* +* -- LAPACK computational 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 .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER NBMIN, NBMAX + PARAMETER ( NBMIN = 8, NBMAX = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DZASUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS, + $ ZGEMM, DLABAD, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, CONJG, AIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( SOMEV ) THEN + M = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ M = M + 1 + 10 CONTINUE + ELSE + M = N + END IF +* + INFO = 0 + NB = ILAENV( 1, 'ZTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) + MAXWRK = N + 2*N*NB + WORK(1) = MAXWRK + RWORK(1) = N + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( MM.LT.M ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -14 + ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREVC3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN + NB = (LWORK - N) / (2*N) + NB = MIN( NB, NBMAX ) + CALL ZLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N ) + ELSE + NB = 1 + END IF +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 I = 1, N + WORK( I ) = T( I, I ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + RWORK( 1 ) = ZERO + DO 30 J = 2, N + RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) + 30 CONTINUE +* + IF( RIGHTV ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=NB=1; +* blocked version starts with IV=NB, goes down to 1. +* (Note the "0-th" column is used to store the original diagonal.) + IV = NB + IS = M + DO 80 KI = N, 1, -1 + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 80 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* +* -------------------------------------------------------- +* Complex right eigenvector +* + WORK( KI + IV*N ) = CONE +* +* Form right-hand side. +* + DO 40 K = 1, KI - 1 + WORK( K + IV*N ) = -T( K, KI ) + 40 CONTINUE +* +* Solve upper triangular system: +* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK. +* + DO 50 K = 1, KI - 1 + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 50 CONTINUE +* + IF( KI.GT.1 ) THEN + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ KI-1, T, LDT, WORK( 1 + IV*N ), SCALE, + $ RWORK, INFO ) + WORK( KI + IV*N ) = SCALE + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL ZCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) +* + II = IZAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / CABS1( VR( II, IS ) ) + CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 60 K = KI + 1, N + VR( K, IS ) = CZERO + 60 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.GT.1 ) + $ CALL ZGEMV( 'N', N, KI-1, CONE, VR, LDVR, + $ WORK( 1 + IV*N ), 1, DCMPLX( SCALE ), + $ VR( 1, KI ), 1 ) +* + II = IZAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / CABS1( VR( II, KI ) ) + CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO K = KI + 1, N + WORK( K + IV*N ) = CZERO + END DO +* +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN + CALL ZGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE, + $ VR, LDVR, + $ WORK( 1 + (IV)*N ), N, + $ CZERO, + $ WORK( 1 + (NB+IV)*N ), N ) +* normalize vectors + DO K = IV, NB + II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) + CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL ZLACPY( 'F', N, NB-IV+1, + $ WORK( 1 + (NB+IV)*N ), N, + $ VR( 1, KI ), LDVR ) + IV = NB + ELSE + IV = IV - 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 70 K = 1, KI - 1 + T( K, K ) = WORK( K ) + 70 CONTINUE +* + IS = IS - 1 + 80 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB. +* (Note the "0-th" column is used to store the original diagonal.) + IV = 1 + IS = 1 + DO 130 KI = 1, N +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* +* -------------------------------------------------------- +* Complex left eigenvector +* + WORK( KI + IV*N ) = CONE +* +* Form right-hand side. +* + DO 90 K = KI + 1, N + WORK( K + IV*N ) = -CONJG( T( KI, K ) ) + 90 CONTINUE +* +* Solve conjugate-transposed triangular system: +* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK. +* + DO 100 K = KI + 1, N + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 100 CONTINUE +* + IF( KI.LT.N ) THEN + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, + $ WORK( KI+1 + IV*N ), SCALE, RWORK, INFO ) + WORK( KI + IV*N ) = SCALE + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL ZCOPY( N-KI+1, WORK( KI + IV*N ), 1, VL(KI,IS), 1 ) +* + II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / CABS1( VL( II, IS ) ) + CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 110 K = 1, KI - 1 + VL( K, IS ) = CZERO + 110 CONTINUE +* + ELSE IF( NB.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( KI.LT.N ) + $ CALL ZGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 + IV*N ), 1, DCMPLX( SCALE ), + $ VL( 1, KI ), 1 ) +* + II = IZAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / CABS1( VL( II, KI ) ) + CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO K = 1, KI - 1 + WORK( K + IV*N ) = CZERO + END DO +* +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN + CALL ZGEMM( 'N', 'N', N, IV, N-KI+IV, CONE, + $ VL( 1, KI-IV+1 ), LDVL, + $ WORK( KI-IV+1 + (1)*N ), N, + $ CZERO, + $ WORK( 1 + (NB+1)*N ), N ) +* normalize vectors + DO K = 1, IV + II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) + REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) + CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) + END DO + CALL ZLACPY( 'F', N, IV, + $ WORK( 1 + (NB+1)*N ), N, + $ VL( 1, KI-IV+1 ), LDVL ) + IV = 1 + ELSE + IV = IV + 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 120 K = KI + 1, N + T( K, K ) = WORK( K ) + 120 CONTINUE +* + IS = IS + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC3 +* + END diff --git a/lapack-netlib/SRC/ztrexc.f b/lapack-netlib/SRC/ztrexc.f index 83bfb5271c..4cf352e647 100644 --- a/lapack-netlib/SRC/ztrexc.f +++ b/lapack-netlib/SRC/ztrexc.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTREXC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 Q( LDQ, * ), T( LDT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -57,6 +57,7 @@ *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. *> \endverbatim *> *> \param[in,out] T @@ -84,7 +85,8 @@ *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in] IFST @@ -112,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ @@ -169,9 +171,9 @@ SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -181,7 +183,7 @@ SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * Quick return if possible * - IF( N.EQ.1 .OR. IFST.EQ.ILST ) + IF( N.LE.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN diff --git a/lapack-netlib/SRC/ztrrfs.f b/lapack-netlib/SRC/ztrrfs.f index 7ab7ee5192..42c2592e44 100644 --- a/lapack-netlib/SRC/ztrrfs.f +++ b/lapack-netlib/SRC/ztrrfs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRRFS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRRFS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, FERR, BERR, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, LDX, N, NRHS @@ -30,7 +30,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -182,10 +182,10 @@ SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztrsen.f b/lapack-netlib/SRC/ztrsen.f index 9ad4aac6d0..e033ca5235 100644 --- a/lapack-netlib/SRC/ztrsen.f +++ b/lapack-netlib/SRC/ztrsen.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRSEN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRSEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, * SEP, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER COMPQ, JOB * INTEGER INFO, LDQ, LDT, LWORK, M, N @@ -30,7 +30,7 @@ * LOGICAL SELECT( * ) * COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -264,10 +264,10 @@ SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB diff --git a/lapack-netlib/SRC/ztrsna.f b/lapack-netlib/SRC/ztrsna.f index 634f6646e9..07a76c1387 100644 --- a/lapack-netlib/SRC/ztrsna.f +++ b/lapack-netlib/SRC/ztrsna.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRSNA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRSNA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N @@ -32,7 +32,7 @@ * COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -249,10 +249,10 @@ SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB diff --git a/lapack-netlib/SRC/ztrsyl.f b/lapack-netlib/SRC/ztrsyl.f index 6941ecfee3..6fd0354a81 100644 --- a/lapack-netlib/SRC/ztrsyl.f +++ b/lapack-netlib/SRC/ztrsyl.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRSYL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRSYL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, * LDC, SCALE, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANA, TRANB * INTEGER INFO, ISGN, LDA, LDB, LDC, M, N @@ -29,7 +29,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16SYcomputational * @@ -157,10 +157,10 @@ SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB diff --git a/lapack-netlib/SRC/ztrti2.f b/lapack-netlib/SRC/ztrti2.f index 3b617b6488..87b871793a 100644 --- a/lapack-netlib/SRC/ztrti2.f +++ b/lapack-netlib/SRC/ztrti2.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ztrtri.f b/lapack-netlib/SRC/ztrtri.f index 808fe78ac0..cb5bd450d7 100644 --- a/lapack-netlib/SRC/ztrtri.f +++ b/lapack-netlib/SRC/ztrtri.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/SRC/ztrtrs.f b/lapack-netlib/SRC/ztrtrs.f index 701d0ca3e0..a5c36bc64b 100644 --- a/lapack-netlib/SRC/ztrtrs.f +++ b/lapack-netlib/SRC/ztrtrs.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -140,10 +140,10 @@ SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/SRC/ztrttf.f b/lapack-netlib/SRC/ztrttf.f index be83bcc40a..f18312b081 100644 --- a/lapack-netlib/SRC/ztrttf.f +++ b/lapack-netlib/SRC/ztrttf.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRTTF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRTTF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -216,10 +216,10 @@ * ===================================================================== SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO diff --git a/lapack-netlib/SRC/ztrttp.f b/lapack-netlib/SRC/ztrttp.f index 9abd14b412..52663b5820 100644 --- a/lapack-netlib/SRC/ztrttp.f +++ b/lapack-netlib/SRC/ztrttp.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTRTTP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTRTTP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/ztzrzf.f b/lapack-netlib/SRC/ztzrzf.f index edc9f93d8b..d806dc073b 100644 --- a/lapack-netlib/SRC/ztzrzf.f +++ b/lapack-netlib/SRC/ztzrzf.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZTZRZF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZTZRZF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,10 +111,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -142,7 +142,7 @@ *> *> V = ( I A(:,M+1:N) ) *> -*> I is the M-by-M identity matrix, A(:,M+1:N) +*> I is the M-by-M identity matrix, A(:,M+1:N) *> is the output stored in A on exit from DTZRZF, *> and tau(k) is the kth element of the array TAU. *> @@ -151,7 +151,7 @@ * ===================================================================== SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 diff --git a/lapack-netlib/SRC/zunbdb.f b/lapack-netlib/SRC/zunbdb.f index 618c0a0d45..d06dacd861 100644 --- a/lapack-netlib/SRC/zunbdb.f +++ b/lapack-netlib/SRC/zunbdb.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNBDB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -21,7 +21,7 @@ * SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, * TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIGNS, TRANS * INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, @@ -33,7 +33,7 @@ * $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), * $ X21( LDX21, * ), X22( LDX22, * ) * .. -* +* * *> \par Purpose: * ============= @@ -250,12 +250,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -287,10 +287,10 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -314,7 +314,7 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY - INTEGER I, LWORKMIN, LWORKOPT, PI1, QI1 + INTEGER I, LWORKMIN, LWORKOPT DOUBLE PRECISION Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. @@ -396,7 +396,7 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * IF( COLMAJOR ) THEN * -* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 * DO I = 1, Q * @@ -427,7 +427,7 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, END IF X11(I,I) = ONE IF ( M-P .GT. I ) THEN - CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) ELSE IF ( M-P .EQ. I ) THEN CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, @@ -436,7 +436,7 @@ SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, + CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, $ DCONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) diff --git a/lapack-netlib/SRC/zunbdb1.f b/lapack-netlib/SRC/zunbdb1.f index 4125450c7a..9ec0977284 100644 --- a/lapack-netlib/SRC/zunbdb1.f +++ b/lapack-netlib/SRC/zunbdb1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB1 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -151,7 +151,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -169,10 +169,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -203,7 +203,7 @@ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -308,9 +308,8 @@ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL ZLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK(ILARF) ) CALL ZLACGV( Q-I, X21(I,I+1), LDX21 ) - C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), - $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), - $ 1 )**2 ) + C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, diff --git a/lapack-netlib/SRC/zunbdb2.f b/lapack-netlib/SRC/zunbdb2.f index 89104f650f..8fa7308298 100644 --- a/lapack-netlib/SRC/zunbdb2.f +++ b/lapack-netlib/SRC/zunbdb2.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB2 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -167,10 +167,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -201,7 +201,7 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -281,7 +281,7 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., P of X11 and X21 * DO I = 1, P -* +* IF( I .GT. 1 ) THEN CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, $ S ) @@ -295,8 +295,8 @@ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL ZLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), $ X21(I,I), LDX21, WORK(ILARF) ) CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) - S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + DZNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DZNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL ZUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, diff --git a/lapack-netlib/SRC/zunbdb3.f b/lapack-netlib/SRC/zunbdb3.f index 37a5c89f40..737c9a76e1 100644 --- a/lapack-netlib/SRC/zunbdb3.f +++ b/lapack-netlib/SRC/zunbdb3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB3 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -29,8 +29,8 @@ * COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), * $ X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -150,7 +150,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -167,10 +167,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -201,7 +201,7 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -280,7 +280,7 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * Reduce rows 1, ..., M-P of X11 and X21 * DO I = 1, M-P -* +* IF( I .GT. 1 ) THEN CALL ZDROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, $ S ) @@ -295,8 +295,8 @@ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) - C = SQRT( DZNRM2( P-I+1, X11(I,I), 1, X11(I,I), - $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + C = SQRT( DZNRM2( P-I+1, X11(I,I), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) * CALL ZUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, diff --git a/lapack-netlib/SRC/zunbdb4.f b/lapack-netlib/SRC/zunbdb4.f index 91ed9d052f..9bb0c9bd92 100644 --- a/lapack-netlib/SRC/zunbdb4.f +++ b/lapack-netlib/SRC/zunbdb4.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB4 + dependencies @@ -21,7 +21,7 @@ * SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 * .. @@ -30,8 +30,8 @@ * COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), * $ WORK(*), X11(LDX11,*), X21(LDX21,*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -161,7 +161,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. -*> +*> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error @@ -178,10 +178,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -213,7 +213,7 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -344,9 +344,8 @@ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) IF( I .LT. M-Q ) THEN - S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), - $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), - $ 1 )**2 ) + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I), 1 )**2 ) PHI(I) = ATAN2( S, C ) END IF * diff --git a/lapack-netlib/SRC/zunbdb5.f b/lapack-netlib/SRC/zunbdb5.f index f777324b74..0e2678bfc5 100644 --- a/lapack-netlib/SRC/zunbdb5.f +++ b/lapack-netlib/SRC/zunbdb5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB5 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -156,7 +156,7 @@ SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -269,6 +269,6 @@ SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, RETURN * * End of ZUNBDB5 -* +* END diff --git a/lapack-netlib/SRC/zunbdb6.f b/lapack-netlib/SRC/zunbdb6.f index 931710d06f..42a3cf8010 100644 --- a/lapack-netlib/SRC/zunbdb6.f +++ b/lapack-netlib/SRC/zunbdb6.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNBDB6 + dependencies @@ -20,7 +20,7 @@ * * SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, * LDQ2, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, * $ N @@ -28,8 +28,8 @@ * .. Array Arguments .. * COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -141,10 +141,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -154,7 +154,7 @@ SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, $ LDQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -261,7 +261,7 @@ SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, IF( NORMSQ2 .EQ. ZERO ) THEN RETURN END IF -* +* NORMSQ1 = NORMSQ2 * DO I = 1, N @@ -306,7 +306,7 @@ SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, END IF * RETURN -* +* * End of ZUNBDB6 * END diff --git a/lapack-netlib/SRC/zuncsd.f b/lapack-netlib/SRC/zuncsd.f index 18982f8ffd..77a83c095c 100644 --- a/lapack-netlib/SRC/zuncsd.f +++ b/lapack-netlib/SRC/zuncsd.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNCSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNCSD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== @@ -24,7 +24,7 @@ * U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, * LDV2T, WORK, LWORK, RWORK, LRWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, @@ -39,7 +39,7 @@ * $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, * $ * ) * .. -* +* * *> \par Purpose: * ============= @@ -303,12 +303,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -320,10 +320,10 @@ RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ LDV2T, WORK, LWORK, RWORK, LRWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK computational 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -363,8 +363,8 @@ RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, LOGICAL LRQUERY * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZBBCSD, ZLACPY, ZLAPMR, ZLAPMT, ZLASCL, - $ ZLASET, ZUNBDB, ZUNGLQ, ZUNGQR + EXTERNAL XERBLA, ZBBCSD, ZLACPY, ZLAPMR, ZLAPMT, + $ ZUNBDB, ZUNGLQ, ZUNGQR * .. * .. External Functions .. LOGICAL LSAME @@ -621,7 +621,7 @@ RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, * Permute rows and columns to place identity submatrices in top- * left corner of (1,1)-block and/or bottom-right corner of (1,2)- * block and/or bottom-right corner of (2,1)-block and/or top-left -* corner of (2,2)-block +* corner of (2,2)-block * IF( Q .GT. 0 .AND. WANTU2 ) THEN DO I = 1, Q diff --git a/lapack-netlib/SRC/zuncsd2by1.f b/lapack-netlib/SRC/zuncsd2by1.f index 432471fe22..630a59380e 100644 --- a/lapack-netlib/SRC/zuncsd2by1.f +++ b/lapack-netlib/SRC/zuncsd2by1.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZUNCSD2BY1 + dependencies @@ -22,7 +22,7 @@ * X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, * LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T * INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, @@ -36,8 +36,8 @@ * $ X11(LDX11,*), X21(LDX21,*) * INTEGER IWORK(*) * .. -* -* +* +* *> \par Purpose: *> ============= *> @@ -47,18 +47,19 @@ *> orthonormal columns that has been partitioned into a 2-by-1 block *> structure: *> -*> [ I 0 0 ] +*> [ I1 0 0 ] *> [ 0 C 0 ] *> [ X11 ] [ U1 | ] [ 0 0 0 ] *> X = [-----] = [---------] [----------] V1**T . *> [ X21 ] [ | U2 ] [ 0 0 0 ] *> [ 0 S 0 ] -*> [ 0 0 I ] -*> +*> [ 0 0 I2] +*> *> X11 is P-by-Q. The unitary matrices U1, U2, and V1 are P-by-P, *> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R *> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which -*> R = MIN(P,M-P,Q,M-Q). +*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a +*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). *> \endverbatim * * Arguments: @@ -208,7 +209,7 @@ *> \verbatim *> LRWORK is INTEGER *> The dimension of the array RWORK. -*> +*> *> If LRWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the RWORK array, returns *> this value as the first entry of the work array, and no error @@ -238,10 +239,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date July 2012 * @@ -253,7 +254,7 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, $ INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- * July 2012 @@ -271,7 +272,7 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ X11(LDX11,*), X21(LDX21,*) INTEGER IWORK(*) * .. -* +* * ===================================================================== * * .. Parameters .. @@ -287,6 +288,10 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, $ LWORKMIN, LWORKOPT, R LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T * .. +* .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) + COMPLEX*16 CDUM( 1, 1 ) +* .. * .. External Subroutines .. EXTERNAL ZBBCSD, ZCOPY, ZLACPY, ZLAPMR, ZLAPMT, ZUNBDB1, $ ZUNBDB2, ZUNBDB3, ZUNBDB4, ZUNGLQ, ZUNGQR, @@ -319,11 +324,11 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, INFO = -8 ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -10 - ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN INFO = -13 - ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN INFO = -15 - ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN INFO = -17 END IF * @@ -379,99 +384,118 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, IORBDB = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ1 + MAX( 1, Q ) IORGLQ = ITAUQ1 + MAX( 1, Q ) + LORGQRMIN = 1 + LORGQROPT = 1 + LORGLQMIN = 1 + LORGLQOPT = 1 IF( R .EQ. Q ) THEN - CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK, -1, CHILDINFO ) + CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, WORK, -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZUNGQR( P, P, Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + ENDIF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZUNGLQ( Q-1, Q-1, Q-1, V1T, LDV1T, + $ CDUM, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q-1 ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL ZUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, - $ 0, WORK(1), -1, CHILDINFO ) - LORGLQMIN = MAX( 1, Q-1 ) - LORGLQOPT = INT( WORK(1) ) CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, - $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + $ DUM, U1, LDU1, U2, LDU2, V1T, LDV1T, CDUM, 1, + $ DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE IF( R .EQ. P ) THEN - CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P-1 .GE. M-P ) THEN - CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, CDUM, WORK(1), $ -1, CHILDINFO ) - LORGQRMIN = MAX( 1, P-1 ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, - $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + $ DUM, V1T, LDV1T, CDUM, 1, U1, LDU1, U2, LDU2, + $ DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE IF( R .EQ. M-P ) THEN - CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, WORK(1), -1, CHILDINFO ) + CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO ) LORBDB = INT( WORK(1) ) - IF( P .GE. M-P-1 ) THEN - CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZUNGQR( P, P, Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, CDUM, $ WORK(1), -1, CHILDINFO ) - LORGQRMIN = MAX( 1, M-P-1 ) - LORGQROPT = INT( WORK(1) ) + LORGQRMIN = MAX( LORGQRMIN, M-P-1 ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, - $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM, CDUM, 1, V1T, LDV1T, U2, LDU2, U1, + $ LDU1, DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) ELSE - CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, - $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, DUM, + $ CDUM, CDUM, CDUM, CDUM, WORK(1), -1, CHILDINFO + $ ) LORBDB = M + INT( WORK(1) ) - IF( P .GE. M-P ) THEN - CALL ZUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZUNGQR( P, P, M-Q, U1, LDU1, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, P ) - LORGQROPT = INT( WORK(1) ) - ELSE - CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + LORGQRMIN = MAX( LORGQRMIN, P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, CDUM, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( LORGQRMIN, M-P ) + LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, CDUM, WORK(1), -1, $ CHILDINFO ) - LORGQRMIN = MAX( 1, M-P ) - LORGQROPT = INT( WORK(1) ) + LORGLQMIN = MAX( LORGLQMIN, Q ) + LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) ) END IF - CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, - $ CHILDINFO ) - LORGLQMIN = MAX( 1, Q ) - LORGLQOPT = INT( WORK(1) ) CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, - $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, - $ CHILDINFO ) + $ THETA, DUM, U2, LDU2, U1, LDU1, CDUM, 1, V1T, + $ LDV1T, DUM, DUM, DUM, DUM, DUM, DUM, DUM, DUM, + $ RWORK(1), -1, CHILDINFO ) LBBCSD = INT( RWORK(1) ) END IF LRWORKMIN = IBBCSD+LBBCSD-1 @@ -533,16 +557,16 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL ZUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, - $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, - $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, CDUM, + $ 1, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place zero submatrices in * preferred positions * @@ -587,16 +611,16 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, - $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, - $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IPHI), V1T, LDV1T, CDUM, 1, U1, LDU1, U2, + $ LDU2, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, $ CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -642,16 +666,16 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, - $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, + $ THETA, RWORK(IPHI), CDUM, 1, V1T, LDV1T, U2, LDU2, $ U1, LDU1, RWORK(IB11D), RWORK(IB11E), $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) -* +* * Permute rows and columns to place identity submatrices in * preferred positions * @@ -711,16 +735,16 @@ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQ, CHILDINFO ) END IF -* +* * Simultaneously diagonalize X11 and X21. -* +* CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, - $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, - $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), - $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), - $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, - $ CHILDINFO ) -* + $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, CDUM, 1, + $ V1T, LDV1T, RWORK(IB11D), RWORK(IB11E), + $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), + $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), + $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) +* * Permute rows and columns to place identity submatrices in * preferred positions * diff --git a/lapack-netlib/SRC/zung2l.f b/lapack-netlib/SRC/zung2l.f index f8fd3667d2..1a48c4d6bc 100644 --- a/lapack-netlib/SRC/zung2l.f +++ b/lapack-netlib/SRC/zung2l.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/zung2r.f b/lapack-netlib/SRC/zung2r.f index 63783ac01b..4a3fed0f0d 100644 --- a/lapack-netlib/SRC/zung2r.f +++ b/lapack-netlib/SRC/zung2r.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/zungbr.f b/lapack-netlib/SRC/zungbr.f index f09100bcb4..3cdb8127dd 100644 --- a/lapack-netlib/SRC/zungbr.f +++ b/lapack-netlib/SRC/zungbr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,10 +145,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ * ===================================================================== SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational 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..-- * April 2012 @@ -183,8 +183,7 @@ SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGLQ, ZUNGQR diff --git a/lapack-netlib/SRC/zunghr.f b/lapack-netlib/SRC/zunghr.f index b287fcd1b9..084ecebcd1 100644 --- a/lapack-netlib/SRC/zunghr.f +++ b/lapack-netlib/SRC/zunghr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N diff --git a/lapack-netlib/SRC/zungl2.f b/lapack-netlib/SRC/zungl2.f index 44acba12a6..0774cc4405 100644 --- a/lapack-netlib/SRC/zungl2.f +++ b/lapack-netlib/SRC/zungl2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/zunglq.f b/lapack-netlib/SRC/zunglq.f index 8c6128f706..b0e5028322 100644 --- a/lapack-netlib/SRC/zunglq.f +++ b/lapack-netlib/SRC/zunglq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -115,22 +115,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zungql.f b/lapack-netlib/SRC/zungql.f index 5c77abbd46..c63a47db56 100644 --- a/lapack-netlib/SRC/zungql.f +++ b/lapack-netlib/SRC/zungql.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zungqr.f b/lapack-netlib/SRC/zungqr.f index 6b3e9220cd..5f95b64e88 100644 --- a/lapack-netlib/SRC/zungqr.f +++ b/lapack-netlib/SRC/zungqr.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zungr2.f b/lapack-netlib/SRC/zungr2.f index 5e3afcf526..c65149dd6b 100644 --- a/lapack-netlib/SRC/zungr2.f +++ b/lapack-netlib/SRC/zungr2.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff --git a/lapack-netlib/SRC/zungrq.f b/lapack-netlib/SRC/zungrq.f index 0ad07de009..56cd3271fb 100644 --- a/lapack-netlib/SRC/zungrq.f +++ b/lapack-netlib/SRC/zungrq.f @@ -2,31 +2,31 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,22 +116,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N diff --git a/lapack-netlib/SRC/zungtr.f b/lapack-netlib/SRC/zungtr.f index 422a55a921..728854332f 100644 --- a/lapack-netlib/SRC/zungtr.f +++ b/lapack-netlib/SRC/zungtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,22 +111,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zunm2l.f b/lapack-netlib/SRC/zunm2l.f index 113887c2e4..7e9a5cb710 100644 --- a/lapack-netlib/SRC/zunm2l.f +++ b/lapack-netlib/SRC/zunm2l.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunm2r.f b/lapack-netlib/SRC/zunm2r.f index d1e2d7690a..e59caf9653 100644 --- a/lapack-netlib/SRC/zunm2r.f +++ b/lapack-netlib/SRC/zunm2r.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmbr.f b/lapack-netlib/SRC/zunmbr.f index fe6a12cd69..727aaeba17 100644 --- a/lapack-netlib/SRC/zunmbr.f +++ b/lapack-netlib/SRC/zunmbr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMBR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -183,12 +183,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -196,10 +196,10 @@ SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT diff --git a/lapack-netlib/SRC/zunmhr.f b/lapack-netlib/SRC/zunmhr.f index 7b7c690b0c..49b7943e84 100644 --- a/lapack-netlib/SRC/zunmhr.f +++ b/lapack-netlib/SRC/zunmhr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMHR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -165,12 +165,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunml2.f b/lapack-netlib/SRC/zunml2.f index 3860c3df23..cb1eaf229c 100644 --- a/lapack-netlib/SRC/zunml2.f +++ b/lapack-netlib/SRC/zunml2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmlq.f b/lapack-netlib/SRC/zunmlq.f index c5e6056387..c12c06312a 100644 --- a/lapack-netlib/SRC/zunmlq.f +++ b/lapack-netlib/SRC/zunmlq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMLQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmql.f b/lapack-netlib/SRC/zunmql.f index b6d4cca2d2..abdc0e5db4 100644 --- a/lapack-netlib/SRC/zunmql.f +++ b/lapack-netlib/SRC/zunmql.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMQL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmqr.f b/lapack-netlib/SRC/zunmqr.f index 7159b17a0a..e60f10a822 100644 --- a/lapack-netlib/SRC/zunmqr.f +++ b/lapack-netlib/SRC/zunmqr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmr2.f b/lapack-netlib/SRC/zunmr2.f index 46e5a26a80..0a77773e31 100644 --- a/lapack-netlib/SRC/zunmr2.f +++ b/lapack-netlib/SRC/zunmr2.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -159,10 +159,10 @@ SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmr3.f b/lapack-netlib/SRC/zunmr3.f index edc68ea7ec..138a3c0540 100644 --- a/lapack-netlib/SRC/zunmr3.f +++ b/lapack-netlib/SRC/zunmr3.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMR3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -178,10 +178,10 @@ SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmrq.f b/lapack-netlib/SRC/zunmrq.f index 2ac11a62de..0d246de214 100644 --- a/lapack-netlib/SRC/zunmrq.f +++ b/lapack-netlib/SRC/zunmrq.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMRQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMRQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -167,10 +167,10 @@ SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmrz.f b/lapack-netlib/SRC/zunmrz.f index 17fc559e15..71609f3e65 100644 --- a/lapack-netlib/SRC/zunmrz.f +++ b/lapack-netlib/SRC/zunmrz.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMRZ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMRZ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -187,10 +187,10 @@ SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK computational 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff --git a/lapack-netlib/SRC/zunmtr.f b/lapack-netlib/SRC/zunmtr.f index 1d0765b1b6..1c857030f1 100644 --- a/lapack-netlib/SRC/zunmtr.f +++ b/lapack-netlib/SRC/zunmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUNMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUNMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -171,10 +171,10 @@ SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/SRC/zupgtr.f b/lapack-netlib/SRC/zupgtr.f index 07f8231c72..eeff364180 100644 --- a/lapack-netlib/SRC/zupgtr.f +++ b/lapack-netlib/SRC/zupgtr.f @@ -2,24 +2,24 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUPGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUPGTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDQ, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/SRC/zupmtr.f b/lapack-netlib/SRC/zupmtr.f index 397d663069..a2efa6e66e 100644 --- a/lapack-netlib/SRC/zupmtr.f +++ b/lapack-netlib/SRC/zupmtr.f @@ -2,25 +2,25 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZUPMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZUPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDC, M, N @@ -28,7 +28,7 @@ * .. Array Arguments .. * COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERcomputational * @@ -150,10 +150,10 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO diff --git a/lapack-netlib/TESTING/CMakeLists.txt b/lapack-netlib/TESTING/CMakeLists.txt index 203ad517b6..ec3d85221c 100644 --- a/lapack-netlib/TESTING/CMakeLists.txt +++ b/lapack-netlib/TESTING/CMakeLists.txt @@ -4,7 +4,6 @@ if(MSVC_VERSION) string(REGEX REPLACE "(.*)/STACK:(.*) (.*)" "\\1/STACK:900000000000000000 \\3" CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}") endif() -add_subdirectory(MATGEN) add_subdirectory(LIN) add_subdirectory(EIG) macro(add_lapack_test output input target) @@ -15,14 +14,14 @@ macro(add_lapack_test output input target) if(EXISTS "${TEST_INPUT}") add_test(NAME LAPACK-${testName} COMMAND "${CMAKE_COMMAND}" -DTEST=$ - -DINPUT=${TEST_INPUT} - -DOUTPUT=${TEST_OUTPUT} + -DINPUT=${TEST_INPUT} + -DOUTPUT=${TEST_OUTPUT} -DINTDIR=${CMAKE_CFG_INTDIR} -P "${LAPACK_SOURCE_DIR}/TESTING/runtest.cmake") endif() -endmacro(add_lapack_test) +endmacro() -if (BUILD_SINGLE) +if(BUILD_SINGLE) add_lapack_test(stest.out stest.in xlintsts) # # ======== SINGLE RFP LIN TESTS ======================== @@ -31,65 +30,29 @@ add_lapack_test(stest_rfp.out stest_rfp.in xlintstrfs) # # ======== SINGLE EIG TESTS =========================== # - add_lapack_test(snep.out nep.in xeigtsts) - - add_lapack_test(ssep.out sep.in xeigtsts) - - +add_lapack_test(sse2.out se2.in xeigtsts) add_lapack_test(ssvd.out svd.in xeigtsts) - - add_lapack_test(sec.out sec.in xeigtsts) - - add_lapack_test(sed.out sed.in xeigtsts) - - add_lapack_test(sgg.out sgg.in xeigtsts) - - add_lapack_test(sgd.out sgd.in xeigtsts) - - add_lapack_test(ssb.out ssb.in xeigtsts) - - add_lapack_test(ssg.out ssg.in xeigtsts) - - add_lapack_test(sbal.out sbal.in xeigtsts) - - add_lapack_test(sbak.out sbak.in xeigtsts) - - add_lapack_test(sgbal.out sgbal.in xeigtsts) - - add_lapack_test(sgbak.out sgbak.in xeigtsts) - - add_lapack_test(sbb.out sbb.in xeigtsts) - - add_lapack_test(sglm.out glm.in xeigtsts) - - add_lapack_test(sgqr.out gqr.in xeigtsts) - - add_lapack_test(sgsv.out gsv.in xeigtsts) - - add_lapack_test(scsd.out csd.in xeigtsts) - - add_lapack_test(slse.out lse.in xeigtsts) endif() -if (BUILD_DOUBLE) +if(BUILD_DOUBLE) # # ======== DOUBLE LIN TESTS =========================== add_lapack_test(dtest.out dtest.in xlintstd) @@ -98,130 +61,58 @@ add_lapack_test(dtest.out dtest.in xlintstd) add_lapack_test(dtest_rfp.out dtest_rfp.in xlintstrfd) # # ======== DOUBLE EIG TESTS =========================== - add_lapack_test(dnep.out nep.in xeigtstd) - - add_lapack_test(dsep.out sep.in xeigtstd) - - +add_lapack_test(dse2.out se2.in xeigtstd) add_lapack_test(dsvd.out svd.in xeigtstd) - - add_lapack_test(dec.out dec.in xeigtstd) - - add_lapack_test(ded.out ded.in xeigtstd) - - add_lapack_test(dgg.out dgg.in xeigtstd) - - add_lapack_test(dgd.out dgd.in xeigtstd) - - add_lapack_test(dsb.out dsb.in xeigtstd) - - add_lapack_test(dsg.out dsg.in xeigtstd) - - add_lapack_test(dbal.out dbal.in xeigtstd) - - add_lapack_test(dbak.out dbak.in xeigtstd) - - add_lapack_test(dgbal.out dgbal.in xeigtstd) - - add_lapack_test(dgbak.out dgbak.in xeigtstd) - - add_lapack_test(dbb.out dbb.in xeigtstd) - - add_lapack_test(dglm.out glm.in xeigtstd) - - add_lapack_test(dgqr.out gqr.in xeigtstd) - - add_lapack_test(dgsv.out gsv.in xeigtstd) - - add_lapack_test(dcsd.out csd.in xeigtstd) - - add_lapack_test(dlse.out lse.in xeigtstd) endif() -if (BUILD_COMPLEX) +if(BUILD_COMPLEX) add_lapack_test(ctest.out ctest.in xlintstc) # # ======== COMPLEX RFP LIN TESTS ======================== add_lapack_test(ctest_rfp.out ctest_rfp.in xlintstrfc) # # ======== COMPLEX EIG TESTS =========================== - add_lapack_test(cnep.out nep.in xeigtstc) - - add_lapack_test(csep.out sep.in xeigtstc) - - +add_lapack_test(cse2.out se2.in xeigtstc) add_lapack_test(csvd.out svd.in xeigtstc) - - add_lapack_test(cec.out cec.in xeigtstc) - - add_lapack_test(ced.out ced.in xeigtstc) - - add_lapack_test(cgg.out cgg.in xeigtstc) - - add_lapack_test(cgd.out cgd.in xeigtstc) - - add_lapack_test(csb.out csb.in xeigtstc) - - add_lapack_test(csg.out csg.in xeigtstc) - - add_lapack_test(cbal.out cbal.in xeigtstc) - - add_lapack_test(cbak.out cbak.in xeigtstc) - - add_lapack_test(cgbal.out cgbal.in xeigtstc) - - add_lapack_test(cgbak.out cgbak.in xeigtstc) - - add_lapack_test(cbb.out cbb.in xeigtstc) - - add_lapack_test(cglm.out glm.in xeigtstc) - - add_lapack_test(cgqr.out gqr.in xeigtstc) - - add_lapack_test(cgsv.out gsv.in xeigtstc) - - add_lapack_test(ccsd.out csd.in xeigtstc) - - add_lapack_test(clse.out lse.in xeigtstc) endif() -if (BUILD_COMPLEX16) +if(BUILD_COMPLEX16) # # ======== COMPLEX16 LIN TESTS ======================== add_lapack_test(ztest.out ztest.in xlintstz) @@ -230,87 +121,50 @@ add_lapack_test(ztest.out ztest.in xlintstz) add_lapack_test(ztest_rfp.out ztest_rfp.in xlintstrfz) # # ======== COMPLEX16 EIG TESTS =========================== - add_lapack_test(znep.out nep.in xeigtstz) - - add_lapack_test(zsep.out sep.in xeigtstz) - - +add_lapack_test(zse2.out se2.in xeigtstz) add_lapack_test(zsvd.out svd.in xeigtstz) - - add_lapack_test(zec.out zec.in xeigtstz) - - add_lapack_test(zed.out zed.in xeigtstz) - - add_lapack_test(zgg.out zgg.in xeigtstz) - - add_lapack_test(zgd.out zgd.in xeigtstz) - - add_lapack_test(zsb.out zsb.in xeigtstz) - - add_lapack_test(zsg.out zsg.in xeigtstz) - - add_lapack_test(zbal.out zbal.in xeigtstz) - - add_lapack_test(zbak.out zbak.in xeigtstz) - - add_lapack_test(zgbal.out zgbal.in xeigtstz) - - add_lapack_test(zgbak.out zgbak.in xeigtstz) - - add_lapack_test(zbb.out zbb.in xeigtstz) - - add_lapack_test(zglm.out glm.in xeigtstz) - - add_lapack_test(zgqr.out gqr.in xeigtstz) - - add_lapack_test(zgsv.out gsv.in xeigtstz) - - add_lapack_test(zcsd.out csd.in xeigtstz) - - add_lapack_test(zlse.out lse.in xeigtstz) endif() -if (BUILD_SIMPLE) - if (BUILD_DOUBLE) +if(BUILD_SINGLE AND BUILD_DOUBLE) # # ======== SINGLE-DOUBLE PROTO LIN TESTS ============== - add_lapack_test(dstest.out dstest.in xlintstds) - endif() + add_lapack_test(dstest.out dstest.in xlintstds) endif() -if (BUILD_COMPLEX) - if (BUILD_COMPLEX16) +if(BUILD_COMPLEX AND BUILD_COMPLEX16) # # ======== COMPLEX-COMPLEX16 LIN TESTS ======================== - add_lapack_test(zctest.out zctest.in xlintstzc) - endif() + add_lapack_test(zctest.out zctest.in xlintstzc) endif() # ============================================================================== - -execute_process(COMMAND ${CMAKE_COMMAND} -E copy ${LAPACK_SOURCE_DIR}/lapack_testing.py ${LAPACK_BINARY_DIR}) - add_test( - NAME LAPACK_Test_Summary - WORKING_DIRECTORY ${LAPACK_BINARY_DIR} - COMMAND ${PYTHON_EXECUTABLE} "lapack_testing.py" - ) +# Only run this test if python 2.7 or greater is found +if(PYTHONINTERP_FOUND) + message(STATUS "Running Summary") + execute_process(COMMAND ${CMAKE_COMMAND} -E copy ${LAPACK_SOURCE_DIR}/lapack_testing.py ${LAPACK_BINARY_DIR}) + add_test( + NAME LAPACK_Test_Summary + WORKING_DIRECTORY ${LAPACK_BINARY_DIR} + COMMAND ${PYTHON_EXECUTABLE} "lapack_testing.py" + ) +endif() diff --git a/lapack-netlib/TESTING/EIG/CMakeLists.txt b/lapack-netlib/TESTING/EIG/CMakeLists.txt index 3e93990c58..19fffcd449 100644 --- a/lapack-netlib/TESTING/EIG/CMakeLists.txt +++ b/lapack-netlib/TESTING/EIG/CMakeLists.txt @@ -33,27 +33,27 @@ # ######################################################################## -set(AEIGTST - alahdg.f - alasum.f - alasvm.f - alareq.f - ilaenv.f - xerbla.f - xlaenv.f +set(AEIGTST + alahdg.f + alasum.f + alasvm.f + alareq.f + ilaenv.f + xerbla.f + xlaenv.f chkxer.f) -set(SCIGTST slafts.f slahd2.f slasum.f slatb9.f sstech.f sstect.f +set(SCIGTST slafts.f slahd2.f slasum.f slatb9.f sstech.f sstect.f ssvdch.f ssvdct.f ssxt1.f) -set(SEIGTST schkee.f +set(SEIGTST schkee.f sbdt01.f sbdt02.f sbdt03.f sbdt04.f sbdt05.f - schkbb.f schkbd.f schkbk.f schkbl.f schkec.f - schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f + schkbb.f schkbd.f schkbk.f schkbl.f schkec.f + schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f schkst2stg.f schksb2stg.f sckcsd.f sckglm.f sckgqr.f sckgsv.f scklse.f scsdts.f sdrges.f sdrgev.f sdrges3.f sdrgev3.f sdrgsx.f sdrgvx.f - sdrvbd.f sdrves.f sdrvev.f sdrvsg.f - sdrvst.f sdrvsx.f sdrvvx.f + sdrvbd.f sdrves.f sdrvev.f sdrvsg.f sdrvsg2stg.f + sdrvst.f sdrvst2stg.f sdrvsx.f sdrvvx.f serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f sget02.f sget10.f sget22.f sget23.f sget24.f sget31.f sget32.f sget33.f sget34.f sget35.f sget36.f @@ -63,14 +63,14 @@ set(SEIGTST schkee.f sort03.f ssbt21.f ssgt01.f sslect.f sspt21.f sstt21.f sstt22.f ssyt21.f ssyt22.f) -set(CEIGTST cchkee.f +set(CEIGTST cchkee.f cbdt01.f cbdt02.f cbdt03.f cbdt05.f - cchkbb.f cchkbd.f cchkbk.f cchkbl.f cchkec.f - cchkgg.f cchkgk.f cchkgl.f cchkhb.f cchkhs.f cchkst.f + cchkbb.f cchkbd.f cchkbk.f cchkbl.f cchkec.f + cchkgg.f cchkgk.f cchkgl.f cchkhb.f cchkhs.f cchkst.f cchkst2stg.f cchkhb2stg.f cckcsd.f cckglm.f cckgqr.f cckgsv.f ccklse.f ccsdts.f cdrges.f cdrgev.f cdrges3.f cdrgev3.f cdrgsx.f cdrgvx.f - cdrvbd.f cdrves.f cdrvev.f cdrvsg.f - cdrvst.f cdrvsx.f cdrvvx.f + cdrvbd.f cdrves.f cdrvev.f cdrvsg.f cdrvsg2stg.f + cdrvst.f cdrvst2stg.f cdrvsx.f cdrvvx.f cerrbd.f cerrec.f cerred.f cerrgg.f cerrhs.f cerrst.f cget02.f cget10.f cget22.f cget23.f cget24.f cget35.f cget36.f cget37.f cget38.f cget51.f cget52.f @@ -80,17 +80,17 @@ set(CEIGTST cchkee.f csgt01.f cslect.f cstt21.f cstt22.f cunt01.f cunt03.f) -set(DZIGTST dlafts.f dlahd2.f dlasum.f dlatb9.f dstech.f dstect.f +set(DZIGTST dlafts.f dlahd2.f dlasum.f dlatb9.f dstech.f dstect.f dsvdch.f dsvdct.f dsxt1.f) -set(DEIGTST dchkee.f - dbdt01.f dbdt02.f dbdt03.f dbdt04.f dbdt05.f - dchkbb.f dchkbd.f dchkbk.f dchkbl.f dchkec.f - dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f +set(DEIGTST dchkee.f + dbdt01.f dbdt02.f dbdt03.f dbdt04.f dbdt05.f + dchkbb.f dchkbd.f dchkbk.f dchkbl.f dchkec.f + dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f dchkst2stg.f dchksb2stg.f dckcsd.f dckglm.f dckgqr.f dckgsv.f dcklse.f dcsdts.f ddrges.f ddrgev.f ddrges3.f ddrgev3.f ddrgsx.f ddrgvx.f - ddrvbd.f ddrves.f ddrvev.f ddrvsg.f - ddrvst.f ddrvsx.f ddrvvx.f + ddrvbd.f ddrves.f ddrvev.f ddrvsg.f ddrvsg2stg.f + ddrvst.f ddrvst2stg.f ddrvsx.f ddrvvx.f derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f dget02.f dget10.f dget22.f dget23.f dget24.f dget31.f dget32.f dget33.f dget34.f dget35.f dget36.f @@ -100,14 +100,14 @@ set(DEIGTST dchkee.f dort03.f dsbt21.f dsgt01.f dslect.f dspt21.f dstt21.f dstt22.f dsyt21.f dsyt22.f) -set(ZEIGTST zchkee.f - zbdt01.f zbdt02.f zbdt03.f zbdt05.f - zchkbb.f zchkbd.f zchkbk.f zchkbl.f zchkec.f - zchkgg.f zchkgk.f zchkgl.f zchkhb.f zchkhs.f zchkst.f +set(ZEIGTST zchkee.f + zbdt01.f zbdt02.f zbdt03.f zbdt05.f + zchkbb.f zchkbd.f zchkbk.f zchkbl.f zchkec.f + zchkgg.f zchkgk.f zchkgl.f zchkhb.f zchkhs.f zchkst.f zchkst2stg.f zchkhb2stg.f zckcsd.f zckglm.f zckgqr.f zckgsv.f zcklse.f zcsdts.f zdrges.f zdrgev.f zdrges3.f zdrgev3.f zdrgsx.f zdrgvx.f - zdrvbd.f zdrves.f zdrvev.f zdrvsg.f - zdrvst.f zdrvsx.f zdrvvx.f + zdrvbd.f zdrves.f zdrvev.f zdrvsg.f zdrvsg2stg.f + zdrvst.f zdrvst2stg.f zdrvsx.f zdrvvx.f zerrbd.f zerrec.f zerred.f zerrgg.f zerrhs.f zerrst.f zget02.f zget10.f zget22.f zget23.f zget24.f zget35.f zget36.f zget37.f zget38.f zget51.f zget52.f @@ -117,27 +117,27 @@ set(ZEIGTST zchkee.f zsgt01.f zslect.f zstt21.f zstt22.f zunt01.f zunt03.f) -macro(add_eig_executable name ) +macro(add_eig_executable name) add_executable(${name} ${ARGN}) target_link_libraries(${name} tmglib ${LAPACK_LIBRARIES}) -endmacro(add_eig_executable) +endmacro() -if (BUILD_SINGLE) -add_eig_executable(xeigtsts ${SEIGTST} ${SCIGTST} ${AEIGTST} - ${SECOND_SRC} ) +if(BUILD_SINGLE) +add_eig_executable(xeigtsts ${SEIGTST} ${SCIGTST} ${AEIGTST} + ${SECOND_SRC}) endif() -if (BUILD_COMPLEX) +if(BUILD_COMPLEX) add_eig_executable(xeigtstc ${CEIGTST} ${SCIGTST} ${AEIGTST} - ${SECOND_SRC} ) + ${SECOND_SRC}) endif() -if (BUILD_DOUBLE) -add_eig_executable(xeigtstd ${DEIGTST} ${DZIGTST} ${AEIGTST} - ${DSECOND_SRC} ) +if(BUILD_DOUBLE) +add_eig_executable(xeigtstd ${DEIGTST} ${DZIGTST} ${AEIGTST} + ${DSECOND_SRC}) endif() -if (BUILD_COMPLEX16) +if(BUILD_COMPLEX16) add_eig_executable(xeigtstz ${ZEIGTST} ${DZIGTST} ${AEIGTST} - ${DSECOND_SRC} ) + ${DSECOND_SRC}) endif() diff --git a/lapack-netlib/TESTING/EIG/Makefile b/lapack-netlib/TESTING/EIG/Makefile index 6811cc2c13..eef087d9c5 100644 --- a/lapack-netlib/TESTING/EIG/Makefile +++ b/lapack-netlib/TESTING/EIG/Makefile @@ -49,13 +49,13 @@ SCIGTST = slafts.o slahd2.o slasum.o slatb9.o sstech.o sstect.o \ ssvdch.o ssvdct.o ssxt1.o SEIGTST = schkee.o \ - sbdt01.o sbdt02.o sbdt03.o sbdt04.o sbdt05.o\ + sbdt01.o sbdt02.o sbdt03.o sbdt04.o sbdt05.o \ schkbb.o schkbd.o schkbk.o schkbl.o schkec.o \ - schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o \ + schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o schkst2stg.o schksb2stg.o \ sckcsd.o sckglm.o sckgqr.o sckgsv.o scklse.o scsdts.o \ sdrges.o sdrgev.o sdrges3.o sdrgev3.o sdrgsx.o sdrgvx.o \ - sdrvbd.o sdrves.o sdrvev.o sdrvsg.o \ - sdrvst.o sdrvsx.o sdrvvx.o \ + sdrvbd.o sdrves.o sdrvev.o sdrvsg.o sdrvsg2stg.o \ + sdrvst.o sdrvst2stg.o sdrvsx.o sdrvvx.o \ serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o \ sget02.o sget10.o sget22.o sget23.o sget24.o sget31.o \ sget32.o sget33.o sget34.o sget35.o sget36.o \ @@ -66,13 +66,13 @@ SEIGTST = schkee.o \ sstt22.o ssyt21.o ssyt22.o CEIGTST = cchkee.o \ - cbdt01.o cbdt02.o cbdt03.o cbdt05.o\ + cbdt01.o cbdt02.o cbdt03.o cbdt05.o \ cchkbb.o cchkbd.o cchkbk.o cchkbl.o cchkec.o \ - cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o \ + cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o cchkst2stg.o cchkhb2stg.o \ cckcsd.o cckglm.o cckgqr.o cckgsv.o ccklse.o ccsdts.o \ cdrges.o cdrgev.o cdrges3.o cdrgev3.o cdrgsx.o cdrgvx.o \ - cdrvbd.o cdrves.o cdrvev.o cdrvsg.o \ - cdrvst.o cdrvsx.o cdrvvx.o \ + cdrvbd.o cdrves.o cdrvev.o cdrvsg.o cdrvsg2stg.o \ + cdrvst.o cdrvst2stg.o cdrvsx.o cdrvvx.o \ cerrbd.o cerrec.o cerred.o cerrgg.o cerrhs.o cerrst.o \ cget02.o cget10.o cget22.o cget23.o cget24.o \ cget35.o cget36.o cget37.o cget38.o cget51.o cget52.o \ @@ -86,13 +86,13 @@ DZIGTST = dlafts.o dlahd2.o dlasum.o dlatb9.o dstech.o dstect.o \ dsvdch.o dsvdct.o dsxt1.o DEIGTST = dchkee.o \ - dbdt01.o dbdt02.o dbdt03.o dbdt04.o dbdt05.o\ + dbdt01.o dbdt02.o dbdt03.o dbdt04.o dbdt05.o \ dchkbb.o dchkbd.o dchkbk.o dchkbl.o dchkec.o \ - dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o \ + dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o dchkst2stg.o dchksb2stg.o \ dckcsd.o dckglm.o dckgqr.o dckgsv.o dcklse.o dcsdts.o \ ddrges.o ddrgev.o ddrges3.o ddrgev3.o ddrgsx.o ddrgvx.o \ - ddrvbd.o ddrves.o ddrvev.o ddrvsg.o \ - ddrvst.o ddrvsx.o ddrvvx.o \ + ddrvbd.o ddrves.o ddrvev.o ddrvsg.o ddrvsg2stg.o \ + ddrvst.o ddrvst2stg.o ddrvsx.o ddrvvx.o \ derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o \ dget02.o dget10.o dget22.o dget23.o dget24.o dget31.o \ dget32.o dget33.o dget34.o dget35.o dget36.o \ @@ -103,13 +103,13 @@ DEIGTST = dchkee.o \ dstt22.o dsyt21.o dsyt22.o ZEIGTST = zchkee.o \ - zbdt01.o zbdt02.o zbdt03.o zbdt05.o\ + zbdt01.o zbdt02.o zbdt03.o zbdt05.o \ zchkbb.o zchkbd.o zchkbk.o zchkbl.o zchkec.o \ - zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o \ + zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o zchkst2stg.o zchkhb2stg.o \ zckcsd.o zckglm.o zckgqr.o zckgsv.o zcklse.o zcsdts.o \ zdrges.o zdrgev.o zdrges3.o zdrgev3.o zdrgsx.o zdrgvx.o \ - zdrvbd.o zdrves.o zdrvev.o zdrvsg.o \ - zdrvst.o zdrvsx.o zdrvvx.o \ + zdrvbd.o zdrves.o zdrvev.o zdrvsg.o zdrvsg2stg.o \ + zdrvst.o zdrvst2stg.o zdrvsx.o zdrvvx.o \ zerrbd.o zerrec.o zerred.o zerrgg.o zerrhs.o zerrst.o \ zget02.o zget10.o zget22.o zget23.o zget24.o \ zget35.o zget36.o zget37.o zget38.o zget51.o zget52.o \ @@ -126,25 +126,25 @@ complex: ../xeigtstc double: ../xeigtstd complex16: ../xeigtstz -../xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) ../../$(LAPACKLIB); \ - $(LOADER) $(LOADOPTS) -o xeigtsts \ - $(SEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \ - ../../$(LAPACKLIB) $(BLASLIB) && mv xeigtsts $@ +../xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ \ + $(SEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \ + ../../$(LAPACKLIB) $(BLASLIB) -../xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) ../../$(LAPACKLIB); \ - $(LOADER) $(LOADOPTS) -o xeigtstc \ - $(CEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \ - ../../$(LAPACKLIB) $(BLASLIB) && mv xeigtstc $@ +../xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ \ + $(CEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \ + ../../$(LAPACKLIB) $(BLASLIB) -../xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) ../../$(LAPACKLIB); \ - $(LOADER) $(LOADOPTS) -o xeigtstd \ - $(DEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \ - ../../$(LAPACKLIB) $(BLASLIB) && mv xeigtstd $@ +../xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ \ + $(DEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \ + ../../$(LAPACKLIB) $(BLASLIB) -../xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) ../../$(LAPACKLIB); \ - $(LOADER) $(LOADOPTS) -o xeigtstz \ - $(ZEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \ - ../../$(LAPACKLIB) $(BLASLIB) && mv xeigtstz $@ +../xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ \ + $(ZEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \ + ../../$(LAPACKLIB) $(BLASLIB) $(AEIGTST): $(FRC) $(SCIGTST): $(FRC) @@ -161,12 +161,13 @@ clean: rm -f *.o schkee.o: schkee.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< dchkee.o: dchkee.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< cchkee.o: cchkee.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< zchkee.o: zchkee.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< -.f.o : ; $(FORTRAN) $(OPTS) -c $< -o $@ +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< diff --git a/lapack-netlib/TESTING/EIG/alahdg.f b/lapack-netlib/TESTING/EIG/alahdg.f index 51959416c6..aec76fd91a 100644 --- a/lapack-netlib/TESTING/EIG/alahdg.f +++ b/lapack-netlib/TESTING/EIG/alahdg.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAHDG( IOUNIT, PATH ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER IOUNIT * .. -* +* * *> \par Purpose: * ============= @@ -50,22 +50,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALAHDG( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/alareq.f b/lapack-netlib/TESTING/EIG/alareq.f index 2da40772de..a65e4d05e5 100644 --- a/lapack-netlib/TESTING/EIG/alareq.f +++ b/lapack-netlib/TESTING/EIG/alareq.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NIN, NMATS, NOUT, NTYPES @@ -17,7 +17,7 @@ * .. Array Arguments .. * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/alarqg.f b/lapack-netlib/TESTING/EIG/alarqg.f index 3dbb7fd1b2..e9f9e832d3 100644 --- a/lapack-netlib/TESTING/EIG/alarqg.f +++ b/lapack-netlib/TESTING/EIG/alarqg.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALARQG( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NIN, NMATS, NOUT, NTYPES @@ -17,7 +17,7 @@ * .. Array Arguments .. * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALARQG( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/alasmg.f b/lapack-netlib/TESTING/EIG/alasmg.f index 13c6aaebfd..d01f326bac 100644 --- a/lapack-netlib/TESTING/EIG/alasmg.f +++ b/lapack-netlib/TESTING/EIG/alasmg.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALASMG( TYPE, NOUT, NFAIL, NRUN, NERRS ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER NFAIL, NOUT, NRUN, NERRS * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALASMG( TYPE, NOUT, NFAIL, NRUN, NERRS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/alasum.f b/lapack-netlib/TESTING/EIG/alasum.f index e94604c9a6..d527082c50 100644 --- a/lapack-netlib/TESTING/EIG/alasum.f +++ b/lapack-netlib/TESTING/EIG/alasum.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER NFAIL, NOUT, NRUN, NERRS * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/alasvm.f b/lapack-netlib/TESTING/EIG/alasvm.f index 78b967c4f4..54d67e4cc0 100644 --- a/lapack-netlib/TESTING/EIG/alasvm.f +++ b/lapack-netlib/TESTING/EIG/alasvm.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER NFAIL, NOUT, NRUN, NERRS * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/cbdt01.f b/lapack-netlib/TESTING/EIG/cbdt01.f index 39d7f694b3..e7d08d8744 100644 --- a/lapack-netlib/TESTING/EIG/cbdt01.f +++ b/lapack-netlib/TESTING/EIG/cbdt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER KD, LDA, LDPT, LDQ, M, N * REAL RESID @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -146,10 +146,10 @@ SUBROUTINE CBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KD, LDA, LDPT, LDQ, M, N diff --git a/lapack-netlib/TESTING/EIG/cbdt02.f b/lapack-netlib/TESTING/EIG/cbdt02.f index fcad0e93e4..c2d6bd7d7f 100644 --- a/lapack-netlib/TESTING/EIG/cbdt02.f +++ b/lapack-netlib/TESTING/EIG/cbdt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDC, LDU, M, N * REAL RESID @@ -20,7 +20,7 @@ * COMPLEX B( LDB, * ), C( LDC, * ), U( LDU, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -119,10 +119,10 @@ SUBROUTINE CBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDC, LDU, M, N diff --git a/lapack-netlib/TESTING/EIG/cbdt03.f b/lapack-netlib/TESTING/EIG/cbdt03.f index 589ab8a8a5..d4f7d7a5d6 100644 --- a/lapack-netlib/TESTING/EIG/cbdt03.f +++ b/lapack-netlib/TESTING/EIG/cbdt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDU, LDVT, N @@ -20,7 +20,7 @@ * REAL D( * ), E( * ), S( * ) * COMPLEX U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -135,10 +135,10 @@ SUBROUTINE CBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/cbdt05.f b/lapack-netlib/TESTING/EIG/cbdt05.f index c01c986981..192a8d0b6a 100644 --- a/lapack-netlib/TESTING/EIG/cbdt05.f +++ b/lapack-netlib/TESTING/EIG/cbdt05.f @@ -1,14 +1,15 @@ +*> \brief \b CBDT05 * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE CBDT05( M, N, A, LDA, S, NS, U, LDU, -* VT, LDVT, WORK, RESID ) -* +* SUBROUTINE CBDT05( M, N, A, LDA, S, NS, U, LDU, +* VT, LDVT, WORK, RESID ) +* * .. Scalar Arguments .. * INTEGER LDA, LDU, LDVT, N, NS * REAL RESID @@ -61,14 +62,14 @@ *> \param[in] S *> \verbatim *> S is REAL array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -110,26 +111,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== - SUBROUTINE CBDT05( M, N, A, LDA, S, NS, U, LDU, + SUBROUTINE CBDT05( M, N, A, LDA, S, NS, U, LDU, $ VT, LDVT, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. - CHARACTER UPLO INTEGER LDA, LDU, LDVT, M, N, NS REAL RESID * .. diff --git a/lapack-netlib/TESTING/EIG/cchkbb.f b/lapack-netlib/TESTING/EIG/cchkbb.f index 158b470ecc..f4a95fa65c 100644 --- a/lapack-netlib/TESTING/EIG/cchkbb.f +++ b/lapack-netlib/TESTING/EIG/cchkbb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB, * BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK, * LWORK, RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, * $ NRHS, NSIZES, NTYPES, NWDTHS @@ -26,7 +26,7 @@ * $ CC( LDC, * ), P( LDP, * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -346,12 +346,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -364,7 +364,7 @@ SUBROUTINE CCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE, * -- LAPACK test routine (input) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/cchkbd.f b/lapack-netlib/TESTING/EIG/cchkbd.f index f5d9982183..a3c5b60275 100644 --- a/lapack-netlib/TESTING/EIG/cchkbd.f +++ b/lapack-netlib/TESTING/EIG/cchkbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX, * Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, * RWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * $ U( LDPT, * ), VT( LDPT, * ), WORK( * ), * $ X( LDX, * ), Y( LDX, * ), Z( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -400,12 +400,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -415,10 +415,10 @@ SUBROUTINE CCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, $ RWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, @@ -466,9 +466,10 @@ SUBROUTINE CCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, EXTERNAL SLAMCH, SLARND * .. * .. External Subroutines .. - EXTERNAL ALASUM, CBDSQR, CBDT01, CBDT02, CBDT03, CGEBRD, - $ CGEMM, CLACPY, CLASET, CLATMR, CLATMS, CUNGBR, - $ CUNT01, SCOPY, SLABAD, SLAHD2, SSVDCH, XERBLA + EXTERNAL ALASUM, CBDSQR, CBDT01, CBDT02, CBDT03, + $ CGEBRD, CGEMM, CLACPY, CLASET, CLATMR, + $ CLATMS, CUNGBR, CUNT01, SCOPY, SLABAD, + $ SLAHD2, SSVDCH, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT @@ -483,9 +484,9 @@ SUBROUTINE CCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / - DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / - DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / + DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, $ 0, 0, 0 / * .. * .. Executable Statements .. diff --git a/lapack-netlib/TESTING/EIG/cchkbk.f b/lapack-netlib/TESTING/EIG/cchkbk.f index e04ef1e748..58e1209423 100644 --- a/lapack-netlib/TESTING/EIG/cchkbk.f +++ b/lapack-netlib/TESTING/EIG/cchkbk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKBK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -21,7 +21,7 @@ *> \verbatim *> *> CCHKBK tests CGEBAK, a routine for backward transformation of -*> the computed right or left eigenvectors if the orginal matrix +*> the computed right or left eigenvectors if the original matrix *> was preprocessed by balance subroutine CGEBAL. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CCHKBK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/cchkbl.f b/lapack-netlib/TESTING/EIG/cchkbl.f index 9c6cb07000..02671ffe4c 100644 --- a/lapack-netlib/TESTING/EIG/cchkbl.f +++ b/lapack-netlib/TESTING/EIG/cchkbl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKBL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CCHKBL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/cchkec.f b/lapack-netlib/TESTING/EIG/cchkec.f index b0b044b973..4f6fbc3cdd 100644 --- a/lapack-netlib/TESTING/EIG/cchkec.f +++ b/lapack-netlib/TESTING/EIG/cchkec.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKEC( THRESH, TSTERR, NIN, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NIN, NOUT * REAL THRESH * .. -* +* * *> \par Purpose: * ============= @@ -63,22 +63,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CCHKEC( THRESH, TSTERR, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/EIG/cchkee.f b/lapack-netlib/TESTING/EIG/cchkee.f index 91214b0cfb..f2a5f8d410 100644 --- a/lapack-netlib/TESTING/EIG/cchkee.f +++ b/lapack-netlib/TESTING/EIG/cchkee.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CCHKEE -* +* * *> \par Purpose: * ============= @@ -1022,22 +1022,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex_eig * * ===================================================================== PROGRAM CCHKEE * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * ===================================================================== * @@ -1071,7 +1071,7 @@ PROGRAM CCHKEE CHARACTER*80 LINE INTEGER I, I1, IC, INFO, ITMP, K, LENP, MAXTYP, NEWSD, $ NK, NN, NPARMS, NRHS, NTYPES, - $ VERS_MAJOR, VERS_MINOR, VERS_PATCH + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH REAL EPS, S1, S2, THRESH, THRSHN * .. * .. Local Arrays .. @@ -1102,7 +1102,8 @@ PROGRAM CCHKEE $ CDRGEV, CDRGSX, CDRGVX, CDRVBD, CDRVES, CDRVEV, $ CDRVSG, CDRVST, CDRVSX, CDRVVX, CERRBD, $ CERRED, CERRGG, CERRHS, CERRST, ILAVER, XLAENV, - $ CDRGES3, CDRGEV3 + $ CDRGES3, CDRGEV3, + $ CCHKST2STG, CDRVST2STG, CCHKHB2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1149,7 +1150,7 @@ PROGRAM CCHKEE PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'CHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'CST' ) .OR. - $ LSAMEN( 3, PATH, 'CSG' ) + $ LSAMEN( 3, PATH, 'CSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'CBD' ) CEV = LSAMEN( 3, PATH, 'CEV' ) CES = LSAMEN( 3, PATH, 'CES' ) @@ -1252,7 +1253,7 @@ PROGRAM CCHKEE WRITE( NOUT, FMT = 9992 )PATH GO TO 380 END IF - CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) WRITE( NOUT, FMT = 9972 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH WRITE( NOUT, FMT = 9984 ) * @@ -1829,7 +1830,8 @@ PROGRAM CCHKEE $ WRITE( NOUT, FMT = 9980 )'CCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'CST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'CST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1859,6 +1861,17 @@ PROGRAM CCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL CCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), + $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), + $ DR( 1, 4 ), DR( 1, 5 ), DR( 1, 6 ), + $ DR( 1, 7 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), DR( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), + $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + ELSE CALL CCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), @@ -1866,18 +1879,28 @@ PROGRAM CCHKEE $ DR( 1, 7 ), DR( 1, 8 ), DR( 1, 9 ), $ DR( 1, 10 ), DR( 1, 11 ), A( 1, 3 ), NMAX, $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), - $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, + $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, $ RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL CDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL CDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, - $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), - $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), - $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), - $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) + $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRVST', INFO END IF @@ -1910,12 +1933,18 @@ PROGRAM CCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL CDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, - $ INFO ) +* CALL CDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, +* $ INFO ) + CALL CDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ DR( 1, 3 ), DR( 1, 4 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, RWORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRVSG', INFO END IF @@ -2098,6 +2127,7 @@ PROGRAM CCHKEE MAXTYP = 26 NTYPES = MIN( MAXTYP, NTYPES ) CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV(1,1) IF( TSTCHK .AND. TSTERR ) $ CALL CERRGG( C3, NOUT ) DO 350 I = 1, NPARMS @@ -2154,9 +2184,10 @@ PROGRAM CCHKEE * IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRGES', INFO -* +* * Blocked version -* +* + CALL XLAENV(16,2) CALL CDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2220,9 +2251,10 @@ PROGRAM CCHKEE $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRGEV', INFO -* +* * Blocked version -* +* + CALL XLAENV(16,2) CALL CDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2275,10 +2307,15 @@ PROGRAM CCHKEE CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL CERRST( 'CHB', NOUT ) - CALL CCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, - $ INFO ) +* CALL CCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, +* $ INFO ) + CALL CCHKHB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), + $ DR( 1, 2 ), DR( 1, 3 ), DR( 1, 4 ), DR( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, + $ INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CCHKHB', INFO * @@ -2348,6 +2385,7 @@ PROGRAM CCHKEE * GSV: Generalized Singular Value Decomposition * ---------------------------------------------- * + CALL XLAENV(1,1) IF( TSTERR ) $ CALL CERRGG( 'GSV', NOUT ) CALL CCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, @@ -2459,7 +2497,7 @@ PROGRAM CCHKEE 9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ', $ 'Problem Expert Driver CGGEVX' ) 9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, - $ ', INMIN=', I4, + $ ', INMIN=', I4, $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) diff --git a/lapack-netlib/TESTING/EIG/cchkgg.f b/lapack-netlib/TESTING/EIG/cchkgg.f index e1daf47893..fb9c2bcdf2 100644 --- a/lapack-netlib/TESTING/EIG/cchkgg.f +++ b/lapack-netlib/TESTING/EIG/cchkgg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * S2, P1, P2, U, LDU, V, Q, Z, ALPHA1, BETA1, * ALPHA3, BETA3, EVECTL, EVECTR, WORK, LWORK, * RWORK, LLWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL TSTDIF * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES @@ -31,7 +31,7 @@ * $ T( LDA, * ), U( LDU, * ), V( LDU, * ), * $ WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -68,7 +68,7 @@ *> and each type of matrix, one matrix will be generated and used *> to test the nonsymmetric eigenroutines. For each matrix, 13 *> tests will be performed. The first twelve "test ratios" should be -*> small -- O(1). They will be compared with the threshhold THRESH: +*> small -- O(1). They will be compared with the threshold THRESH: *> *> H *> (1) | A - U H V | / ( |A| n ulp ) @@ -128,7 +128,7 @@ *> |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp *> *> In addition, the normalization of L and R are checked, and compared -*> with the threshhold THRSHN. +*> with the threshold THRSHN. *> *> Test Matrices *> ---- -------- @@ -298,7 +298,7 @@ *> \param[in] THRSHN *> \verbatim *> THRSHN is REAL -*> Threshhold for reporting eigenvector normalization error. +*> Threshold for reporting eigenvector normalization error. *> If the normalization of any eigenvector differs from 1 by *> more than THRSHN*ulp, then a special error message will be *> printed. (This is handled separately from the other tests, @@ -487,12 +487,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -503,10 +503,10 @@ SUBROUTINE CCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA3, BETA3, EVECTL, EVECTR, WORK, LWORK, $ RWORK, LLWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL TSTDIF diff --git a/lapack-netlib/TESTING/EIG/cchkgk.f b/lapack-netlib/TESTING/EIG/cchkgk.f index cb8ca7dc31..34035e1847 100644 --- a/lapack-netlib/TESTING/EIG/cchkgk.f +++ b/lapack-netlib/TESTING/EIG/cchkgk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKGK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CCHKGK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/cchkgl.f b/lapack-netlib/TESTING/EIG/cchkgl.f index 95cb9433a5..73aceed271 100644 --- a/lapack-netlib/TESTING/EIG/cchkgl.f +++ b/lapack-netlib/TESTING/EIG/cchkgl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKGL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -41,22 +41,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CCHKGL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/cchkhb.f b/lapack-netlib/TESTING/EIG/cchkhb.f index a05d4344af..eb6cb7da56 100644 --- a/lapack-netlib/TESTING/EIG/cchkhb.f +++ b/lapack-netlib/TESTING/EIG/cchkhb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, * LWORK, RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, * $ NWDTHS @@ -23,7 +23,7 @@ * REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ) * COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -284,12 +284,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -298,10 +298,10 @@ SUBROUTINE CCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, $ LWORK, RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, diff --git a/lapack-netlib/TESTING/EIG/cchkhb2stg.f b/lapack-netlib/TESTING/EIG/cchkhb2stg.f new file mode 100644 index 0000000000..975217fa58 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/cchkhb2stg.f @@ -0,0 +1,878 @@ +*> \brief \b CCHKHBSTG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHBSTG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RWORK RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ) +* COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHBSTG tests the reduction of a Hermitian band matrix to tridiagonal +*> from, used with the Hermitian eigenvalue problem. +*> +*> CHBTRD factors a Hermitian band matrix A as U S U* , where * means +*> conjugate transpose, S is symmetric tridiagonal, and U is unitary. +*> CHBTRD can use either just the lower or just the upper triangle +*> of A; CCHKHBSTG checks both cases. +*> +*> CHETRD_HB2ST factors a Hermitian band matrix A as U S U* , +*> where * means conjugate transpose, S is symmetric tridiagonal, and U is +*> unitary. CHETRD_HB2ST can use either just the lower or just +*> the upper triangle of A; CCHKHBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When CCHKHBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the hermitian banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with +*> UPLO='U' +*> +*> (2) | I - UU* | / ( n ulp ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with +*> UPLO='L' +*> +*> (4) | I - UU* | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> CHETRD_HB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> CHETRD_HB2ST with UPLO='L' +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> CCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. The values must be at least zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, CCHKHBSTG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to CCHKHBSTG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension +*> (LDA, max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by CHBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by CHBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX array, dimension (LDU, max(NN)) +*> Used to hold the unitary matrix computed by CHBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (4) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CCHKHB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, WORK, LWORK, RWORK, RESULT, + $ INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ) + COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, + $ TEN = 10.0E+0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N, + $ NERRS, NMATS, NMAX, NTEST, NTESTT + REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLASUM, XERBLA, CHBT21, CHBTRD, CLACPY, CLASET, + $ CLATMR, CLATMS, CHBTRD_HB2ST, CSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CCHKHBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, WORK, + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call CHBTRD to compute S and U from upper triangle. +* + CALL CLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL CHBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL CHBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D1, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_HB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = CONJG( A( K+1-JR, JC+JR ) ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call CHBTRD to compute S and U from lower triangle +* + CALL CLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL CHBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL CHBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_HB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D3, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 )'unitary', '*', + $ 'conjugate transpose', ( '*', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL SLASUM( 'CHB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' CCHKHBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( / 1X, A3, + $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines' + $ ) + 9997 FORMAT( ' Matrix types (see SCHK23 for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of CCHKHBSTG +* + END diff --git a/lapack-netlib/TESTING/EIG/cchkhs.f b/lapack-netlib/TESTING/EIG/cchkhs.f index 2f9f634b5a..4469389934 100644 --- a/lapack-netlib/TESTING/EIG/cchkhs.f +++ b/lapack-netlib/TESTING/EIG/cchkhs.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * W3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, * WORK, NWORK, RWORK, IWORK, SELECT, RESULT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK * REAL THRESH @@ -29,7 +29,7 @@ * $ UU( LDU, * ), UZ( LDU, * ), W1( * ), W3( * ), * $ WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -396,12 +396,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -412,10 +412,10 @@ SUBROUTINE CCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WORK, NWORK, RWORK, IWORK, SELECT, RESULT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK diff --git a/lapack-netlib/TESTING/EIG/cchkst.f b/lapack-netlib/TESTING/EIG/cchkst.f index b34b1271ca..471fe9c928 100644 --- a/lapack-netlib/TESTING/EIG/cchkst.f +++ b/lapack-netlib/TESTING/EIG/cchkst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, * $ NSIZES, NTYPES @@ -28,7 +28,7 @@ * COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), * $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -519,7 +519,7 @@ *> \verbatim *> LIWORK is INTEGER *> The number of entries in IWORK. This must be at least -*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax *> where Nmax = max( NN(j), 2 ) and lg = log base 2. *> \endverbatim *> @@ -588,12 +588,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -604,10 +604,10 @@ SUBROUTINE CCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/cchkst2stg.f b/lapack-netlib/TESTING/EIG/cchkst2stg.f new file mode 100644 index 0000000000..df610c2079 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/cchkst2stg.f @@ -0,0 +1,2093 @@ +*> \brief \b CCHKST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), +* $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), +* $ WA1( * ), WA2( * ), WA3( * ), WR( * ) +* COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKST2STG checks the Hermitian eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> CHETRD. For that, we call the standard CHETRD and compute D1 using +*> DSTEQR, then we call the 2-stage CHETRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the CCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> CHETRD factors A as U S U* , where * means conjugate transpose, +*> S is real symmetric tridiagonal, and U is unitary. +*> CHETRD can use either just the lower or just the upper triangle +*> of A; CCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> CHPTRD does the same as CHETRD, except that A and V are stored +*> in "packed" format. +*> +*> CUNGTR constructs the matrix U from the contents of V and TAU. +*> +*> CUPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> CSTEQR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> SSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> CPTEQR factors S as Z4 D4 Z4* , for a +*> Hermitian positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> SSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> CSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> CSTEDC factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input unitary matrix, usually the output +*> from CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> CSTEMR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). CSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When CCHKST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the Hermitian eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='U', ... ) +*> +*> (2) | I - UV* | / ( n ulp ) CUNGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> CHETRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV* | / ( n ulp ) CUNGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> CHETRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for CHPTRD and CUPGTR. +*> +*> (9) | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...) +*> +*> (10) | I - ZZ* | / ( n ulp ) CSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) CSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...) +*> +*> (15) | I - Z4 Z4* | / ( n ulp ) CPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) CPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y* | / ( |S| n ulp ) SSTEBZ, CSTEIN +*> +*> (21) | I - Y Y* | / ( n ulp ) SSTEBZ, CSTEIN +*> +*> (22) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('I') +*> +*> (23) | I - ZZ* | / ( n ulp ) CSTEDC('I') +*> +*> (24) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('V') +*> +*> (25) | I - ZZ* | / ( n ulp ) CSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) CSTEDC('V') and +*> CSTEDC('N') +*> +*> Test 27 is disabled at the moment because CSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> CSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> CSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because CSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'I') +*> +*> (30) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'I') vs. CSTEMR('V', 'I') +*> +*> (32) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'V') +*> +*> (33) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'V') vs. CSTEMR('V', 'V') +*> +*> (35) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'A') +*> +*> (36) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'A') vs. CSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CCHKST2STG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, CCHKST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to CCHKST2STG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is COMPLEX array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by CHETRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> CHETRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CPTEQR(V). +*> CPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix computed by CHETRD + CUNGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by CHETRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in CHETRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as CUNGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is COMPLEX array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array of +*> dimension( max(NN) ) +*> The Householder factors computed by CHETRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix of eigenvectors computed by CSTEQR, +*> CPTEQR, and CSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The number of entries in LRWORK (dimension( ??? ) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF, +*> or CUNMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, + $ INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), + $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ WA1( * ), WA2( * ), WA3( * ), WR( * ) + COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL CRANGE + PARAMETER ( CRANGE = .FALSE. ) + LOGICAL CREL + PARAMETER ( CREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP, + $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN, + $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3, + $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX, + $ NSPLIT, NTEST, NTESTT, LH, LW + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + REAL DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLABAD, SLASUM, SSTEBZ, SSTECH, SSTERF, + $ XERBLA, CCOPY, CHET21, CHETRD, CHPT21, CHPTRD, + $ CLACPY, CLASET, CLATMR, CLATMS, CPTEQR, CSTEDC, + $ CSTEMR, CSTEIN, CSTEQR, CSTT21, CSTT22, CUNGTR, + $ CUPGTR, CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'CHETRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LRWEDC = 1 + 3*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LRWEDC = 7 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) + TEMP2 = SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF*TEMP2 ) THEN + A( I-1, I ) = A( I-1, I )* + $ ( HALF*TEMP2 / ( UNFL+TEMP1 ) ) + A( I, I-1 ) = CONJG( A( I-1, I ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call CHETRD and CUNGTR to compute S and U from +* upper triangle. +* + CALL CLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL CHETRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHETRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL CUNGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUNGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL CHET21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 1 ) ) + CALL CHET21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D1, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( 'U', N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 3 + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( 'L', N, N, A, LDA, V, LDU ) + CALL CHETRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 4 + CALL CSTEQR( 'N', N, D3, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call CHPTRD and CUPGTR to compute S and U from AP +* + CALL CCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL CHPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL CUPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL CHPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 5 ) ) + CALL CHPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call CHPTRD and CUPGTR to compute S and U from AP +* + CALL CCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL CHPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL CUPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CHPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 7 ) ) + CALL CHPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 8 ) ) +* +* Call CSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 9 + CALL CSTEQR( 'V', N, D1, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 11 + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 12 + CALL SSTERF( N, D3, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL SSTECH( N, SD, SE, D1, TEMP1, RWORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call CPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL SCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 14 + CALL CPTEQR( 'V', N, D4, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL CSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RWORK, RESULT( 14 ) ) +* +* Compute D5 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 16 + CALL CPTEQR( 'N', N, D5, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call SSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call CSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call SSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL CSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 20 ) ) +* +* Call CSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + INDE = 1 + INDRWK = INDE + N + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 22 + CALL CSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 22 ) ) +* +* Call CSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 24 + CALL CSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 24 ) ) +* +* Call CSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 26 + CALL CSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test CSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call CSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. CREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL CSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( CRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL CSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call CSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + IF( CRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL CSTEMR( 'V', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 31 + CALL CSTEMR( 'N', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call CSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL CSTEMR( 'V', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, M, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RWORK, RESULT( 32 ) ) +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 34 + CALL CSTEMR( 'N', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call CSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 35 +* + CALL CSTEMR( 'V', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RWORK, RESULT( 35 ) ) +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 37 + CALL CSTEMR( 'N', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9987 ) + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0E0 ) THEN + WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9988 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL SLASUM( 'CST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' CCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see CCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 ) + 9988 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 ) +* + 9987 FORMAT( / 'Test performed: see CCHKST2STG for details.', / ) +* End of CCHKST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/cckcsd.f b/lapack-netlib/TESTING/EIG/cckcsd.f index a4146c7435..9783f0361b 100644 --- a/lapack-netlib/TESTING/EIG/cckcsd.f +++ b/lapack-netlib/TESTING/EIG/cckcsd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, * MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, * WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * COMPLEX U1( * ), U2( * ), V1T( * ), V2T( * ), * $ WORK( * ), X( * ), XF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -184,10 +184,10 @@ SUBROUTINE CCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, $ MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, $ WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/cckglm.f b/lapack-netlib/TESTING/EIG/cckglm.f index 24db1f875c..33d55123a6 100644 --- a/lapack-netlib/TESTING/EIG/cckglm.f +++ b/lapack-netlib/TESTING/EIG/cckglm.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCKGLM( NN, NVAL, MVAL, PVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * REAL THRESH @@ -22,7 +22,7 @@ * COMPLEX A( * ), AF( * ), B( * ), BF( * ), WORK( * ), * $ X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -168,10 +168,10 @@ SUBROUTINE CCKGLM( NN, NVAL, MVAL, PVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/cckgqr.f b/lapack-netlib/TESTING/EIG/cckgqr.f index b2d2e3fe99..05b5f4a603 100644 --- a/lapack-netlib/TESTING/EIG/cckgqr.f +++ b/lapack-netlib/TESTING/EIG/cckgqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, * THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, * BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP * REAL THRESH @@ -23,7 +23,7 @@ * $ BF( * ), BT( * ), BWK( * ), BZ( * ), TAUA( * ), * $ TAUB( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -197,12 +197,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -211,10 +211,10 @@ SUBROUTINE CCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, $ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, $ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP diff --git a/lapack-netlib/TESTING/EIG/cckgsv.f b/lapack-netlib/TESTING/EIG/cckgsv.f index 48e36ebd15..93e11ecaa8 100644 --- a/lapack-netlib/TESTING/EIG/cckgsv.f +++ b/lapack-netlib/TESTING/EIG/cckgsv.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, * IWORK, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * COMPLEX A( * ), AF( * ), B( * ), BF( * ), Q( * ), * $ R( * ), U( * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_eig * @@ -198,10 +198,10 @@ SUBROUTINE CCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, $ IWORK, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/ccklse.f b/lapack-netlib/TESTING/EIG/ccklse.f index 7196b31dd3..13e85e1174 100644 --- a/lapack-netlib/TESTING/EIG/ccklse.f +++ b/lapack-netlib/TESTING/EIG/ccklse.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * REAL THRESH @@ -22,7 +22,7 @@ * COMPLEX A( * ), AF( * ), B( * ), BF( * ), WORK( * ), * $ X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -168,10 +168,10 @@ SUBROUTINE CCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/ccsdts.f b/lapack-netlib/TESTING/EIG/ccsdts.f index b47097bd35..e2dd218120 100644 --- a/lapack-netlib/TESTING/EIG/ccsdts.f +++ b/lapack-netlib/TESTING/EIG/ccsdts.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, * LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. @@ -22,7 +22,7 @@ * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_eig * @@ -229,10 +229,10 @@ SUBROUTINE CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -280,7 +280,7 @@ SUBROUTINE CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ CLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) ELSE EPS2 = ULP @@ -446,7 +446,7 @@ SUBROUTINE CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL CHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ CLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) ) ELSE EPS2 = ULP @@ -553,7 +553,7 @@ SUBROUTINE CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, END DO * RETURN -* +* * End of CCSDTS * END diff --git a/lapack-netlib/TESTING/EIG/cdrges.f b/lapack-netlib/TESTING/EIG/cdrges.f index 14af10397b..d6e28f2840 100644 --- a/lapack-netlib/TESTING/EIG/cdrges.f +++ b/lapack-netlib/TESTING/EIG/cdrges.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, * BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES * REAL THRESH @@ -24,7 +24,7 @@ * $ BETA( * ), Q( LDQ, * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -367,12 +367,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -381,10 +381,10 @@ SUBROUTINE CDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES diff --git a/lapack-netlib/TESTING/EIG/cdrges3.f b/lapack-netlib/TESTING/EIG/cdrges3.f index 0ef33dfd9a..cea7f8b755 100644 --- a/lapack-netlib/TESTING/EIG/cdrges3.f +++ b/lapack-netlib/TESTING/EIG/cdrges3.f @@ -50,7 +50,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -382,7 +382,7 @@ SUBROUTINE CDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/cdrgev.f b/lapack-netlib/TESTING/EIG/cdrgev.f index 1e0eca55f5..2a8ce8f708 100644 --- a/lapack-netlib/TESTING/EIG/cdrgev.f +++ b/lapack-netlib/TESTING/EIG/cdrgev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, * ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from CGGEV: *> @@ -384,12 +384,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex_eig * @@ -399,10 +399,10 @@ SUBROUTINE CDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/cdrgev3.f b/lapack-netlib/TESTING/EIG/cdrgev3.f index 6531752b14..13fb366e49 100644 --- a/lapack-netlib/TESTING/EIG/cdrgev3.f +++ b/lapack-netlib/TESTING/EIG/cdrgev3.f @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from CGGEV3: *> @@ -399,7 +399,7 @@ SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, $ RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2015 diff --git a/lapack-netlib/TESTING/EIG/cdrgsx.f b/lapack-netlib/TESTING/EIG/cdrgsx.f index d0129ea556..4e0f8b4687 100644 --- a/lapack-netlib/TESTING/EIG/cdrgsx.f +++ b/lapack-netlib/TESTING/EIG/cdrgsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, * AI, BI, Z, Q, ALPHA, BETA, C, LDC, S, WORK, * LWORK, RWORK, IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, * $ NOUT, NSIZE @@ -26,7 +26,7 @@ * $ C( LDC, * ), Q( LDA, * ), WORK( * ), * $ Z( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> (need more details on what kind of read-in data are needed). *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH except for the tests (7) and (9): +*> compared with the threshold THRESH except for the tests (7) and (9): *> *> (1) | A - Q S Z' | / ( |A| n ulp ) *> @@ -335,12 +335,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -349,10 +349,10 @@ SUBROUTINE CDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, $ AI, BI, Z, Q, ALPHA, BETA, C, LDC, S, WORK, $ LWORK, RWORK, IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, diff --git a/lapack-netlib/TESTING/EIG/cdrgvx.f b/lapack-netlib/TESTING/EIG/cdrgvx.f index 9c0a807fbb..bed8e472f3 100644 --- a/lapack-netlib/TESTING/EIG/cdrgvx.f +++ b/lapack-netlib/TESTING/EIG/cdrgvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ALPHA, BETA, VL, VR, ILO, IHI, LSCALE, RSCALE, * S, STRU, DIF, DIFTRU, WORK, LWORK, RWORK, * IWORK, LIWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, * $ NSIZE @@ -28,7 +28,7 @@ * $ B( LDA, * ), BETA( * ), BI( LDA, * ), * $ VL( LDA, * ), VR( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> corresponding the first and last eigenvalues are also know *> ``exactly'' (see CLATM6). *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH. +*> compared with the threshold THRESH. *> *> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of *> @@ -205,32 +205,32 @@ *> IHI is INTEGER *> \endverbatim *> -*> \param[out] LSCALE +*> \param[out] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] RSCALE +*> \param[out] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] S +*> \param[out] S *> \verbatim *> S is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] STRU +*> \param[out] STRU *> \verbatim *> STRU is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] DIF +*> \param[out] DIF *> \verbatim *> DIF is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] DIFTRU +*> \param[out] DIFTRU *> \verbatim *> DIFTRU is REAL array, dimension (N) *> \endverbatim @@ -283,12 +283,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -298,10 +298,10 @@ SUBROUTINE CDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI, $ S, STRU, DIF, DIFTRU, WORK, LWORK, RWORK, $ IWORK, LIWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, diff --git a/lapack-netlib/TESTING/EIG/cdrvbd.f b/lapack-netlib/TESTING/EIG/cdrvbd.f index 28d863de17..64bed3b134 100644 --- a/lapack-netlib/TESTING/EIG/cdrvbd.f +++ b/lapack-netlib/TESTING/EIG/cdrvbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, * SSAV, E, WORK, LWORK, RWORK, IWORK, NOUNIT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ USAV( LDU, * ), VT( LDVT, * ), * $ VTSAV( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,7 +132,7 @@ *> *> (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the *> vector of singular values from the partial SVD -*> +*> *> Test for CGESVDX( 'V', 'V', 'I' ) *> *> (8) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -140,7 +140,7 @@ *> (9) | I - U'U | / ( M ulp ) *> *> (10) | I - VT VT' | / ( N ulp ) -*> +*> *> Test for CGESVDX( 'V', 'V', 'V' ) *> *> (11) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -374,12 +374,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex_eig * @@ -389,10 +389,10 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ SSAV, E, WORK, LWORK, RWORK, IWORK, NOUNIT, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES, @@ -423,12 +423,12 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Scalars .. LOGICAL BADMM, BADNN CHARACTER JOBQ, JOBU, JOBVT, RANGE - INTEGER I, IINFO, IJQ, IJU, IJVT, IL, IU, ITEMP, IWSPC, - $ IWTMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, - $ MMAX, MNMAX, MNMIN, MTYPES, N, NERRS, NFAIL, - $ NMAX, NS, NSI, NSV, NTEST, NTESTF, NTESTT, - $ LRWORK - REAL ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV, + INTEGER I, IINFO, IJQ, IJU, IJVT, IL, IU, ITEMP, + $ IWSPC, IWTMP, J, JSIZE, JTYPE, LSWORK, M, + $ MINWRK, MMAX, MNMAX, MNMIN, MTYPES, N, + $ NERRS, NFAIL, NMAX, NS, NSI, NSV, NTEST, + $ NTESTF, NTESTT, LRWORK + REAL ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV, $ UNFL, VL, VU * .. * .. Local Arrays .. @@ -441,9 +441,9 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL SLAMCH, SLARND * .. * .. External Subroutines .. - EXTERNAL ALASVM, XERBLA, CBDT01, CBDT05, CGESDD, CGESVD, - $ CGESVJ, CGEJSV, CGESVDX, CLACPY, CLASET, CLATMS, - $ CUNT01, CUNT03 + EXTERNAL ALASVM, XERBLA, CBDT01, CBDT05, CGESDD, + $ CGESVD, CGESVJ, CGEJSV, CGESVDX, CLACPY, + $ CLASET, CLATMS, CUNT01, CUNT03 * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, MAX, MIN @@ -858,7 +858,7 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, CALL CLACPY( 'F', M, N, ASAV, LDA, USAV, LDA ) SRNAMT = 'CGESVJ' CALL CGESVJ( 'G', 'U', 'V', M, N, USAV, LDA, SSAV, - & 0, A, LDVT, WORK, LWORK, RWORK, + & 0, A, LDVT, WORK, LWORK, RWORK, & LRWORK, IINFO ) * * CGESVJ retuns V not VT, so we transpose to use the same @@ -920,7 +920,7 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, SRNAMT = 'CGEJSV' CALL CGEJSV( 'G', 'U', 'V', 'R', 'N', 'N', & M, N, VTSAV, LDA, SSAV, USAV, LDU, A, LDVT, - & WORK, LWORK, RWORK, + & WORK, LWORK, RWORK, & LRWORK, IWORK, IINFO ) * * CGEJSV retuns V not VT, so we transpose to use the same @@ -968,8 +968,8 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'CGESVDX' - CALL CGESVDX( 'V', 'V', 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, + CALL CGESVDX( 'V', 'V', 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, $ VTSAV, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN @@ -1018,8 +1018,8 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, RANGE = CJOBR( 1 ) CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'CGESVDX' - CALL CGESVDX( JOBU, JOBVT, 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, U, LDU, + CALL CGESVDX( JOBU, JOBVT, 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) * @@ -1079,15 +1079,15 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IU = IL IL = ITEMP END IF - END IF + END IF CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'CGESVDX' - CALL CGESVDX( 'V', 'V', 'I', M, N, A, LDA, - $ VL, VU, IL, IU, NSI, S, U, LDU, + CALL CGESVDX( 'V', 'V', 'I', M, N, A, LDA, + $ VL, VU, IL, IU, NSI, S, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1109,11 +1109,11 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( MNMIN.GT.0 .AND. NSI.GT.1 ) THEN IF( IL.NE.1 ) THEN - VU = SSAV( IL ) + + VU = SSAV( IL ) + $ MAX( HALF*ABS( SSAV( IL )-SSAV( IL-1 ) ), $ ULP*ANORM, TWO*RTUNFL ) ELSE - VU = SSAV( 1 ) + + VU = SSAV( 1 ) + $ MAX( HALF*ABS( SSAV( NS )-SSAV( 1 ) ), $ ULP*ANORM, TWO*RTUNFL ) END IF @@ -1130,15 +1130,15 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, ELSE VL = ZERO VU = ONE - END IF + END IF CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'CGESVDX' - CALL CGESVDX( 'V', 'V', 'V', M, N, A, LDA, - $ VL, VU, IL, IU, NSV, S, U, LDU, + CALL CGESVDX( 'V', 'V', 'V', M, N, A, LDA, + $ VL, VU, IL, IU, NSV, S, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1221,7 +1221,7 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' decreasing order, else 1/ulp', $ / '12 = | U - Upartial | / ( M ulp )', $ / '13 = | VT - VTpartial | / ( N ulp )', - $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', + $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', $ / ' CGESVJ: ', / $ / '15 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ', $ / '16 = | I - U**T U | / ( M ulp ) ', @@ -1231,7 +1231,7 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / ' CGESJV: ', / $ / '19 = | A - U diag(S) VT | / ( |A| max(M,N) ulp )', $ / '20 = | I - U**T U | / ( M ulp ) ', - $ / '21 = | I - VT VT**T | / ( N ulp ) ', + $ / '21 = | I - VT VT**T | / ( N ulp ) ', $ / '22 = 0 if S contains min(M,N) nonnegative values in', $ ' decreasing order, else 1/ulp', $ / ' CGESVDX(V,V,A): ', / @@ -1250,7 +1250,7 @@ SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / ' CGESVDX(V,V,V) ', $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )', $ / '34 = | I - U**T U | / ( M ulp ) ', - $ / '35 = | I - VT VT**T | / ( N ulp ) ', + $ / '35 = | I - VT VT**T | / ( N ulp ) ', $ / / ) 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1, $ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 ) diff --git a/lapack-netlib/TESTING/EIG/cdrves.f b/lapack-netlib/TESTING/EIG/cdrves.f index 782cae7c0a..3e4a7ff3f5 100644 --- a/lapack-netlib/TESTING/EIG/cdrves.f +++ b/lapack-netlib/TESTING/EIG/cdrves.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, * WORK, NWORK, RWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK * REAL THRESH @@ -23,7 +23,7 @@ * COMPLEX A( LDA, * ), H( LDA, * ), HT( LDA, * ), * $ VS( LDVS, * ), W( * ), WORK( * ), WT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -364,12 +364,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -378,10 +378,10 @@ SUBROUTINE CDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, $ WORK, NWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK @@ -901,7 +901,7 @@ SUBROUTINE CDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if W same no matter if VS computed (sort),', $ ' 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / ) + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', / ) 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ), $ ' type ', I2, ', test(', I2, ')=', G10.3 ) 9992 FORMAT( ' CDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', diff --git a/lapack-netlib/TESTING/EIG/cdrvev.f b/lapack-netlib/TESTING/EIG/cdrvev.f index 92aaf35f13..d1e289bf40 100644 --- a/lapack-netlib/TESTING/EIG/cdrvev.f +++ b/lapack-netlib/TESTING/EIG/cdrvev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, * LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -26,7 +26,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -376,12 +376,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -391,10 +391,10 @@ SUBROUTINE CDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/cdrvsg.f b/lapack-netlib/TESTING/EIG/cdrvsg.f index 74ff1f8281..7e34ad0db0 100644 --- a/lapack-netlib/TESTING/EIG/cdrvsg.f +++ b/lapack-netlib/TESTING/EIG/cdrvsg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, * BP, WORK, NWORK, RWORK, LRWORK, IWORK, LIWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -26,7 +26,7 @@ * $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -355,12 +355,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -370,10 +370,10 @@ SUBROUTINE CDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BP, WORK, NWORK, RWORK, LRWORK, IWORK, LIWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/cdrvsg2stg.f b/lapack-netlib/TESTING/EIG/cdrvsg2stg.f new file mode 100644 index 0000000000..3b7156b424 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/cdrvsg2stg.f @@ -0,0 +1,1382 @@ +*> \brief \b CDRVSG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, +* $ NSIZES, NTYPES, NWORK +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D( * ), RESULT( * ), RWORK( * ) +* COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSG2STG checks the complex Hermitian generalized eigenproblem +*> drivers. +*> +*> CHEGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> CHEGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> CHEGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> CHPGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> CHPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> CHPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> CHBGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> CHBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> CHBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> When CDRVSG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) CHEGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> CHEGV and D2 is computed by +*> CHEGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling CHPGV +*> (3) as (1) but calling CHBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling CHPGV +*> (6) as (4) but calling CHBGV +*> +*> (7) CHEGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling CHPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling CHPGV +*> +*> (11) CHEGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling CHPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling CHPGV +*> +*> CHEGVD, CHPGVD and CHBGVD performed the same 14 tests. +*> +*> CHEGVX, CHPGVX and CHBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, CDRVSG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to CDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B COMPLEX array, dimension (LDB , max(NN)) +*> Used to hold the Hermitian positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D REAL array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z COMPLEX array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of ZZ. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB COMPLEX array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB COMPLEX array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP COMPLEX array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP COMPLEX array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK COMPLEX array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 2*N + N**2 where N = max( NN(j), 2 ). +*> Not modified. +*> +*> RWORK REAL array, dimension (LRWORK) +*> Workspace. +*> Modified. +*> +*> LRWORK INTEGER +*> The number of entries in RWORK. This must be at least +*> max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where +*> N = max( NN(j) ) and lg( N ) = smallest integer k such +*> that 2**k >= N . +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK)) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in IWORK. This must be at least +*> 2 + 5*max( NN(j) ). +*> Not modified. +*> +*> RESULT REAL array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LRWORK too small. +*> -25: LIWORK too small. +*> If CLATMR, CLATMS, CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, +*> CHPGVD, CHEGVX, CHPGVX, CHBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* + 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 .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, + $ NSIZES, NTYPES, NWORK + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D( * ), D2( * ), RESULT( * ), RWORK( * ) + COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 10.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLARND + EXTERNAL LSAME, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL SLABAD, SLAFTS, SLASUM, XERBLA, CHBGV, CHBGVD, + $ CHBGVX, CHEGV, CHEGVD, CHEGVX, CHPGV, CHPGVD, + $ CHPGVX, CLACPY, CLASET, CLATMR, CLATMS, CSGT01, + $ CHEGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LRWORK ) THEN + INFO = -23 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LIWORK ) THEN + INFO = -25 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK, IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, CHBGVD, +* CHEGVX, CHPGVX and CHBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL CLATMS( N, N, 'U', ISEED, 'P', RWORK, 5, TEN, + $ ONE, KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test CHEGV +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHEGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test CHEGVD +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHEGVX +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL CHEGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test CHPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL CHPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL CHPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL CHPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL CHPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL CHPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST CHBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL CHBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* TEST CHBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL CHBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, RWORK, + $ LRWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL CHBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL CHBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL CHBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'CSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL SLASUM( 'CSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* + 9999 FORMAT( ' CDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* +* End of CDRVSG2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/cdrvst.f b/lapack-netlib/TESTING/EIG/cdrvst.f index 6ee38e0b23..dbf1e011a2 100644 --- a/lapack-netlib/TESTING/EIG/cdrvst.f +++ b/lapack-netlib/TESTING/EIG/cdrvst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, * LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, * IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDU, * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -323,12 +323,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -338,10 +338,10 @@ SUBROUTINE CDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, $ IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/cdrvst2stg.f b/lapack-netlib/TESTING/EIG/cdrvst2stg.f new file mode 100644 index 0000000000..12a27e5d92 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/cdrvst2stg.f @@ -0,0 +1,2116 @@ +*> \brief \b CDRVST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, +* LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D1( * ), D2( * ), D3( * ), RESULT( * ), +* $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) +* COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVST2STG checks the Hermitian eigenvalue problem drivers. +*> +*> CHEEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix, +*> using a divide-and-conquer algorithm. +*> +*> CHEEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> CHEEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix +*> using the Relatively Robust Representation where it can. +*> +*> CHPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage, using a divide-and-conquer algorithm. +*> +*> CHPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> CHBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix, +*> using a divide-and-conquer algorithm. +*> +*> CHBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> CHEEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> CHPEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> CHBEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> When CDRVST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, CDRVST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to CDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by CSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by CSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> WA1 REAL array, dimension +*> +*> WA2 REAL array, dimension +*> +*> WA3 REAL array, dimension +*> +*> U COMPLEX array, dimension (LDU, max(NN)) +*> The unitary matrix computed by CHETRD + CUNGC3. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V COMPLEX array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by CHETRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU COMPLEX array, dimension (max(NN)) +*> The Householder factors computed by CHETRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z COMPLEX array, dimension (LDU, max(NN)) +*> The unitary matrix of eigenvectors computed by CHEEVD, +*> CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX. +*> Modified. +*> +*> WORK - COMPLEX array of dimension ( LWORK ) +*> Workspace. +*> Modified. +*> +*> LWORK - INTEGER +*> The number of entries in WORK. This must be at least +*> 2*max( NN(j), 2 )**2. +*> Not modified. +*> +*> RWORK REAL array, dimension (3*max(NN)) +*> Workspace. +*> Modified. +*> +*> LRWORK - INTEGER +*> The number of entries in RWORK. +*> +*> IWORK INTEGER array, dimension (6*max(NN)) +*> Workspace. +*> Modified. +*> +*> LIWORK - INTEGER +*> The number of entries in IWORK. +*> +*> RESULT REAL array, dimension (??) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF, +*> or SORMC2 returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, + $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D1( * ), D2( * ), D3( * ), RESULT( * ), + $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) + COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, + $ TEN = 10.0E+0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX, + $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC, + $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX, + $ NTEST, NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SLABAD, SLAFTS, XERBLA, CHBEV, CHBEVD, + $ CHBEVX, CHEEV, CHEEVD, CHEEVR, CHEEVX, CHET21, + $ CHET22, CHPEV, CHPEVD, CHPEVX, CLACPY, CLASET, + $ CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, + $ CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, + $ CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, + $ CHETRD_SB2ST, CLATMR, CLATMS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -22 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* + DO 1220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = MAX( 2*N+N*N, 2*N*N ) + LRWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 + LIWEDC = 3 + 5*N + ELSE + LWEDC = 2 + LRWEDC = 8 + LIWEDC = 8 + END IF + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1210 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 band Hermitian, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK, + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* Perform tests storing upper or lower triangular +* part of matrix. +* + DO 1200 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* Call CHEEVD and CHEEVX. +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL CHEEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do tests 1 and 2. +* + CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL CHEEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 120 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 120 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 130 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL CHEEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 4 and 5. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CHEEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 140 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 140 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 150 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL CHEEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do tests 7 and 8. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL CHEEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do test 9. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 160 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL CHEEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* +* Do tests 10 and 11. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL CHEEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF +* +* Do test 12. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 170 CONTINUE +* +* Call CHPEVD and CHPEVX. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 190 J = 1, N + DO 180 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 180 CONTINUE + 190 CONTINUE + ELSE + INDX = 1 + DO 210 J = 1, N + DO 200 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 200 CONTINUE + 210 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do tests 13 and 14. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 230 J = 1, N + DO 220 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 220 CONTINUE + 230 CONTINUE + ELSE + INDX = 1 + DO 250 J = 1, N + DO 240 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 240 CONTINUE + 250 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 15. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 260 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 270 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 290 J = 1, N + DO 280 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 280 CONTINUE + 290 CONTINUE + ELSE + INDX = 1 + DO 310 J = 1, N + DO 300 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 300 CONTINUE + 310 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL CHPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do tests 16 and 17. +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 330 J = 1, N + DO 320 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 320 CONTINUE + 330 CONTINUE + ELSE + INDX = 1 + DO 350 J = 1, N + DO 340 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 340 CONTINUE + 350 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 360 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 360 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 390 J = 1, N + DO 380 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 380 CONTINUE + 390 CONTINUE + ELSE + INDX = 1 + DO 410 J = 1, N + DO 400 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 400 CONTINUE + 410 CONTINUE + END IF +* + CALL CHPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do tests 19 and 20. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 430 J = 1, N + DO 420 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 420 CONTINUE + 430 CONTINUE + ELSE + INDX = 1 + DO 450 J = 1, N + DO 440 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 440 CONTINUE + 450 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do test 21. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 460 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 480 J = 1, N + DO 470 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 470 CONTINUE + 480 CONTINUE + ELSE + INDX = 1 + DO 500 J = 1, N + DO 490 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 490 CONTINUE + 500 CONTINUE + END IF +* + CALL CHPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 550 + END IF + END IF +* +* Do tests 22 and 23. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 520 J = 1, N + DO 510 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 510 CONTINUE + 520 CONTINUE + ELSE + INDX = 1 + DO 540 J = 1, N + DO 530 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 530 CONTINUE + 540 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF +* +* Do test 24. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 550 CONTINUE +* +* Call CHBEVD and CHBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 570 J = 1, N + DO 560 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 560 CONTINUE + 570 CONTINUE + ELSE + DO 590 J = 1, N + DO 580 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 580 CONTINUE + 590 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVD(V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do tests 25 and 26. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 610 J = 1, N + DO 600 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 600 CONTINUE + 610 CONTINUE + ELSE + DO 630 J = 1, N + DO 620 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 620 CONTINUE + 630 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL CHBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, + $ Z, LDU, WORK, LWORK, RWORK, + $ LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do test 27. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 640 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 640 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 650 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 670 J = 1, N + DO 660 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 660 CONTINUE + 670 CONTINUE + ELSE + DO 690 J = 1, N + DO 680 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 680 CONTINUE + 690 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA1, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBEVX(V,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do tests 28 and 29. +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 710 J = 1, N + DO 700 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 700 CONTINUE + 710 CONTINUE + ELSE + DO 730 J = 1, N + DO 720 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 720 CONTINUE + 730 CONTINUE + END IF +* + CALL CHBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do test 30. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 740 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 740 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 750 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 770 J = 1, N + DO 760 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 760 CONTINUE + 770 CONTINUE + ELSE + DO 790 J = 1, N + DO 780 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 780 CONTINUE + 790 CONTINUE + END IF +* + CALL CHBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do tests 31 and 32. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 810 J = 1, N + DO 800 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 800 CONTINUE + 810 CONTINUE + ELSE + DO 830 J = 1, N + DO 820 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 820 CONTINUE + 830 CONTINUE + END IF + CALL CHBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do test 33. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 840 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 860 J = 1, N + DO 850 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 850 CONTINUE + 860 CONTINUE + ELSE + DO 880 J = 1, N + DO 870 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 870 CONTINUE + 880 CONTINUE + END IF + CALL CHBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 930 + END IF + END IF +* +* Do tests 34 and 35. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 900 J = 1, N + DO 890 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 890 CONTINUE + 900 CONTINUE + ELSE + DO 920 J = 1, N + DO 910 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 910 CONTINUE + 920 CONTINUE + END IF + CALL CHBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF +* +* Do test 36. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 930 CONTINUE +* +* Call CHEEV +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL CHEEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do tests 37 and 38 +* + CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL CHEEV_2STAGE( 'N', UPLO, N, A, LDU, D3, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do test 39 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 940 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 940 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 950 CONTINUE +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Call CHPEV +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 970 J = 1, N + DO 960 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 960 CONTINUE + 970 CONTINUE + ELSE + INDX = 1 + DO 990 J = 1, N + DO 980 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 980 CONTINUE + 990 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEV( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do tests 40 and 41. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEV( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do test 42 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1040 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1040 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1050 CONTINUE +* +* Call CHBEV +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1070 J = 1, N + DO 1060 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1060 CONTINUE + 1070 CONTINUE + ELSE + DO 1090 J = 1, N + DO 1080 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1080 CONTINUE + 1090 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEV(V,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1140 + END IF + END IF +* +* Do tests 43 and 44. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1110 J = 1, N + DO 1100 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1100 CONTINUE + 1110 CONTINUE + ELSE + DO 1130 J = 1, N + DO 1120 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1120 CONTINUE + 1130 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL CHBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1140 + END IF + END IF +* + 1140 CONTINUE +* +* Do test 45. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1150 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + CALL CHEEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do tests 45 and 46 (or ... ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CHEEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do test 47 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1160 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1160 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1170 CONTINUE +* + NTEST = NTEST + 1 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 48 and 49 (or +??) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 50 (or +??) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1180 CONTINUE +* + NTEST = NTEST + 1 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1190 + END IF + END IF +* +* Do tests 51 and 52 (or +??) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF +* +* Do test 52 (or +??) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* +* +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1190 CONTINUE +* + 1200 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'CST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1210 CONTINUE + 1220 CONTINUE +* +* Summary +* + CALL ALASVM( 'CST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' CDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( ' CDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', KD=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, + $ ')' ) +* + RETURN +* +* End of CDRVST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/cdrvsx.f b/lapack-netlib/TESTING/EIG/cdrvsx.f index 8bac9cc2fc..9def66306b 100644 --- a/lapack-netlib/TESTING/EIG/cdrvsx.f +++ b/lapack-netlib/TESTING/EIG/cdrvsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NIUNIT, NOUNIT, A, LDA, H, HT, W, WT, WTMP, VS, * LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ VS( LDVS, * ), VS1( LDVS, * ), W( * ), * $ WORK( * ), WT( * ), WTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -420,12 +420,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -435,10 +435,10 @@ SUBROUTINE CDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, @@ -914,7 +914,7 @@ SUBROUTINE CDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if W same no matter what else computed ', $ '(sort), 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', $ / ' 14 = 0 if RCONDE same no matter what else computed,', $ ' 1/ulp otherwise', / $ ' 15 = 0 if RCONDv same no matter what else computed,', diff --git a/lapack-netlib/TESTING/EIG/cdrvvx.f b/lapack-netlib/TESTING/EIG/cdrvvx.f index 629e78cf30..37a29ec4ee 100644 --- a/lapack-netlib/TESTING/EIG/cdrvvx.f +++ b/lapack-netlib/TESTING/EIG/cdrvvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, NWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -30,7 +30,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -446,7 +446,7 @@ *> \verbatim *> INFO is INTEGER *> If 0, then successful exit. -*> If <0, then input paramter -INFO is incorrect. +*> If <0, then input parameter -INFO is incorrect. *> If >0, CLATMR, CLATMS, CLATME or CGET23 returned an error *> code, and INFO is its absolute value. *> @@ -480,12 +480,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * @@ -496,10 +496,10 @@ SUBROUTINE CDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, NWORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/cerrbd.f b/lapack-netlib/TESTING/EIG/cerrbd.f index 35b389f1c4..6cb7f65529 100644 --- a/lapack-netlib/TESTING/EIG/cerrbd.f +++ b/lapack-netlib/TESTING/EIG/cerrbd.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRBD( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERRBD( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/cerrec.f b/lapack-netlib/TESTING/EIG/cerrec.f index e50484a215..13176fecfa 100644 --- a/lapack-netlib/TESTING/EIG/cerrec.f +++ b/lapack-netlib/TESTING/EIG/cerrec.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERREC( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERREC( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -152,8 +152,8 @@ SUBROUTINE CERREC( PATH, NUNIT ) INFOT = 1 CALL CTREXC( 'X', 1, A, 1, B, 1, IFST, ILST, INFO ) CALL CHKXER( 'CTREXC', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL CTREXC( 'N', 0, A, 1, B, 1, IFST, ILST, INFO ) + INFOT = 2 + CALL CTREXC( 'N', -1, A, 1, B, 1, IFST, ILST, INFO ) CALL CHKXER( 'CTREXC', INFOT, NOUT, LERR, OK ) INFOT = 4 ILST = 2 diff --git a/lapack-netlib/TESTING/EIG/cerred.f b/lapack-netlib/TESTING/EIG/cerred.f index e1b04be7ab..f1670e9831 100644 --- a/lapack-netlib/TESTING/EIG/cerred.f +++ b/lapack-netlib/TESTING/EIG/cerred.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRED( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERRED( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -100,7 +100,7 @@ SUBROUTINE CERRED( PATH, NUNIT ) $ VT( NMAX, NMAX ), W( 10*NMAX ), X( NMAX ) * .. * .. External Subroutines .. - EXTERNAL CHKXER, CGEES, CGEESX, CGEEV, CGEEVX, CGEJSV + EXTERNAL CHKXER, CGEES, CGEESX, CGEEV, CGEEVX, CGEJSV, $ CGESDD, CGESVD * .. * .. External Functions .. @@ -441,51 +441,51 @@ SUBROUTINE CERRED( PATH, NUNIT ) * SRNAMT = 'CGESVDX' INFOT = 1 - CALL CGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL CGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL CGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL CGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, + CALL CGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, + CALL CGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, + CALL CGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL CGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, + CALL CGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, + CALL CGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL CGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, + CALL CGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL CGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 0, 1, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL CGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL CGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 1, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL CGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, + CALL CGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) - INFOT = 16 - CALL CGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, + INFOT = 17 + CALL CGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'CGESVDX', INFOT, NOUT, LERR, OK ) NT = 12 diff --git a/lapack-netlib/TESTING/EIG/cerrgg.f b/lapack-netlib/TESTING/EIG/cerrgg.f index a60c4eb278..5a53d23431 100644 --- a/lapack-netlib/TESTING/EIG/cerrgg.f +++ b/lapack-netlib/TESTING/EIG/cerrgg.f @@ -22,7 +22,7 @@ *> \verbatim *> *> CERRGG tests the error exits for CGGES, CGGESX, CGGEV, CGGEVX, -*> CGGES3, CGGEV3, CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF, +*> CGGES3, CGGEV3, CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF, *> CGGSVD3, CGGSVP3, CHGEQZ, CTGEVC, CTGEXC, CTGSEN, CTGSJA, *> CTGSNA, CTGSYL, and CUNCSD. *> \endverbatim @@ -50,17 +50,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERRGG( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,7 +83,7 @@ SUBROUTINE CERRGG( PATH, NUNIT ) * .. * .. Local Arrays .. LOGICAL BW( NMAX ), SEL( NMAX ) - INTEGER IW( LW ) + INTEGER IW( LW ), IDUM(NMAX) REAL LS( NMAX ), R1( NMAX ), R2( NMAX ), $ RCE( NMAX ), RCV( NMAX ), RS( NMAX ), RW( LW ) COMPLEX A( NMAX, NMAX ), ALPHA( NMAX ), @@ -306,57 +306,57 @@ SUBROUTINE CERRGG( PATH, NUNIT ) SRNAMT = 'CGGSVD3' INFOT = 1 CALL CGGSVD3( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGGSVD3( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGGSVD3( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGGSVD3( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGGSVD3( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CGGSVD3( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGGSVD3( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CGGSVD3( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 16 CALL CGGSVD3( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 18 CALL CGGSVD3( 'N', 'V', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 2, V, 1, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 2, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL CGGSVD3( 'N', 'N', 'Q', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 2, V, 2, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 2, V, 2, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'CGGSVD3', INFOT, NOUT, LERR, OK ) NT = NT + 11 @@ -573,56 +573,56 @@ SUBROUTINE CERRGG( PATH, NUNIT ) INFOT = 7 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ -1, 0, 0, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, -1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, -1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, -1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ -1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) diff --git a/lapack-netlib/TESTING/EIG/cerrhs.f b/lapack-netlib/TESTING/EIG/cerrhs.f index 5203ba0175..ccd47a3bfb 100644 --- a/lapack-netlib/TESTING/EIG/cerrhs.f +++ b/lapack-netlib/TESTING/EIG/cerrhs.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRHS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERRHS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/cerrst.f b/lapack-netlib/TESTING/EIG/cerrst.f index 99b7ef3144..10b2de432a 100644 --- a/lapack-netlib/TESTING/EIG/cerrst.f +++ b/lapack-netlib/TESTING/EIG/cerrst.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRST( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -25,6 +25,10 @@ *> CUNGTR, CUPMTR, CSTEQR, CSTEIN, CPTEQR, CHBTRD, *> CHEEV, CHEEVX, CHEEVD, CHBEV, CHBEVX, CHBEVD, *> CHPEV, CHPEVX, CHPEVD, and CSTEDC. +*> CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, +*> CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, +*> CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, +*> CHETRD_SB2ST *> \endverbatim * * Arguments: @@ -45,22 +49,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CERRST( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -93,7 +97,11 @@ SUBROUTINE CERRST( PATH, NUNIT ) EXTERNAL CHBEV, CHBEVD, CHBEVX, CHBTRD, CHEEV, CHEEVD, $ CHEEVR, CHEEVX, CHETRD, CHKXER, CHPEV, CHPEVD, $ CHPEVX, CHPTRD, CPTEQR, CSTEDC, CSTEIN, CSTEQR, - $ CUNGTR, CUNMTR, CUPGTR, CUPMTR + $ CUNGTR, CUNMTR, CUPGTR, CUPMTR, + $ CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, + $ CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, + $ CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, + $ CHETRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -151,6 +159,103 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHETRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* CHETRD_2STAGE +* + SRNAMT = 'CHETRD_2STAGE' + INFOT = 1 + CALL CHETRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHETRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* CHETRD_HE2HB +* + SRNAMT = 'CHETRD_HE2HB' + INFOT = 1 + CALL CHETRD_HE2HB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HE2HB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HE2HB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HE2HB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HE2HB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRD_HE2HB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* CHETRD_HB2ST +* + SRNAMT = 'CHETRD_HB2ST' + INFOT = 1 + CALL CHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * CUNGTR * SRNAMT = 'CUNGTR' @@ -377,6 +482,63 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHEEVD', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* CHEEVD_2STAGE +* + SRNAMT = 'CHEEVD_2STAGE' + INFOT = 1 + CALL CHEEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3, +* $ RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 0, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 18, IW, 12, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 1, IW, 0, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 25, IW, 11, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * CHEEV * SRNAMT = 'CHEEV ' @@ -397,6 +559,29 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHEEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* CHEEV_2STAGE +* + SRNAMT = 'CHEEV_2STAGE ' + INFOT = 1 + CALL CHEEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHEEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEV_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * CHEEVX * SRNAMT = 'CHEEVX' @@ -441,6 +626,65 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHEEVX', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* CHEEVX_2STAGE +* + SRNAMT = 'CHEEVX_2STAGE' + INFOT = 1 + CALL CHEEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + INFOT = 4 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHEEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I1, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * CHEEVR * SRNAMT = 'CHEEVR' @@ -508,6 +752,90 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHEEVR', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* CHEEVR_2STAGE +* + SRNAMT = 'CHEEVR_2STAGE' + N = 1 + INFOT = 1 + CALL CHEEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHEEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHEEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N-1, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N-1, IW( 2*N-1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 22 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N, IW, 10*N-1, + $ INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * CHPEVD * SRNAMT = 'CHPEVD' @@ -646,6 +974,47 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* CHETRD_HB2ST +* + SRNAMT = 'CHETRD_HB2ST' + INFOT = 1 + CALL CHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRD_HB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * CHBEVD * SRNAMT = 'CHBEVD' @@ -711,6 +1080,75 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 15 * +* CHBEVD_2STAGE +* + SRNAMT = 'CHBEVD_2STAGE' + INFOT = 1 + CALL CHBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, + $ W, 2, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 0, + $ W, 8, RW, 25, IW, 12, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 1, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 2, RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 2, IW, 12, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 2, IW, 0, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 15 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 25, IW, 2, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * CHBEV * SRNAMT = 'CHBEV ' @@ -734,6 +1172,43 @@ SUBROUTINE CERRST( PATH, NUNIT ) CALL CHKXER( 'CHBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* CHBEV_2STAGE +* + SRNAMT = 'CHBEV_2STAGE ' + INFOT = 1 + CALL CHBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 0, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * CHBEVX * SRNAMT = 'CHBEVX' @@ -781,6 +1256,74 @@ SUBROUTINE CERRST( PATH, NUNIT ) $ 0.0, M, X, Z, 1, W, RW, IW, I3, INFO ) CALL CHKXER( 'CHBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 11 +* +* CHBEVX_2STAGE +* + SRNAMT = 'CHBEVX_2STAGE' + INFOT = 1 + CALL CHBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 1 + CALL CHBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 4 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL CHBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, +* $ 0.0D0, 0.0D0, 0, 0, 0.0D0, +* $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) +* CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/EIG/cget02.f b/lapack-netlib/TESTING/EIG/cget02.f index 0e0541df65..f79585db44 100644 --- a/lapack-netlib/TESTING/EIG/cget02.f +++ b/lapack-netlib/TESTING/EIG/cget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -133,10 +133,10 @@ SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/EIG/cget10.f b/lapack-netlib/TESTING/EIG/cget10.f index 0f86aefeb0..0b8186454b 100644 --- a/lapack-netlib/TESTING/EIG/cget10.f +++ b/lapack-netlib/TESTING/EIG/cget10.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET10( M, N, A, LDA, B, LDB, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, M, N * REAL RESULT @@ -18,7 +18,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CGET10( M, N, A, LDA, B, LDB, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, M, N diff --git a/lapack-netlib/TESTING/EIG/cget22.f b/lapack-netlib/TESTING/EIG/cget22.f index c34c2fe27f..91aec3a3f1 100644 --- a/lapack-netlib/TESTING/EIG/cget22.f +++ b/lapack-netlib/TESTING/EIG/cget22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSA, TRANSE, TRANSW * INTEGER LDA, LDE, N @@ -19,7 +19,7 @@ * REAL RESULT( 2 ), RWORK( * ) * COMPLEX A( LDA, * ), E( LDE, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -143,10 +143,10 @@ SUBROUTINE CGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSA, TRANSE, TRANSW diff --git a/lapack-netlib/TESTING/EIG/cget23.f b/lapack-netlib/TESTING/EIG/cget23.f index b295acbaad..1a2d4fb486 100644 --- a/lapack-netlib/TESTING/EIG/cget23.f +++ b/lapack-netlib/TESTING/EIG/cget23.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * CHARACTER BALANC @@ -31,7 +31,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -352,12 +352,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -368,10 +368,10 @@ SUBROUTINE CGET23( COMP, ISRT, BALANC, JTYPE, THRESH, ISEED, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/cget24.f b/lapack-netlib/TESTING/EIG/cget24.f index ddb3d92181..e97003a2f5 100644 --- a/lapack-netlib/TESTING/EIG/cget24.f +++ b/lapack-netlib/TESTING/EIG/cget24.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * H, HT, W, WT, WTMP, VS, LDVS, VS1, RCDEIN, * RCDVIN, NSLCT, ISLCT, ISRT, RESULT, WORK, * LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * INTEGER INFO, ISRT, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, @@ -27,7 +27,7 @@ * $ VS( LDVS, * ), VS1( LDVS, * ), W( * ), * $ WORK( * ), WT( * ), WTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -320,12 +320,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -335,10 +335,10 @@ SUBROUTINE CGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, $ RCDVIN, NSLCT, ISLCT, ISRT, RESULT, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/cget35.f b/lapack-netlib/TESTING/EIG/cget35.f index fe24b8c10a..241f3ea302 100644 --- a/lapack-netlib/TESTING/EIG/cget35.f +++ b/lapack-netlib/TESTING/EIG/cget35.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET35( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CGET35( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN, NINFO diff --git a/lapack-netlib/TESTING/EIG/cget36.f b/lapack-netlib/TESTING/EIG/cget36.f index 8e8dcf5534..4b46f3bc3b 100644 --- a/lapack-netlib/TESTING/EIG/cget36.f +++ b/lapack-netlib/TESTING/EIG/cget36.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET36( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -73,22 +73,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CGET36( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN, NINFO diff --git a/lapack-netlib/TESTING/EIG/cget37.f b/lapack-netlib/TESTING/EIG/cget37.f index 71467bf4b8..536e4ca3e3 100644 --- a/lapack-netlib/TESTING/EIG/cget37.f +++ b/lapack-netlib/TESTING/EIG/cget37.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET37( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * REAL RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CGET37( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/cget38.f b/lapack-netlib/TESTING/EIG/cget38.f index be94c1d869..bbf9209346 100644 --- a/lapack-netlib/TESTING/EIG/cget38.f +++ b/lapack-netlib/TESTING/EIG/cget38.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET38( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * REAL RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CGET38( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/cget51.f b/lapack-netlib/TESTING/EIG/cget51.f index 216894730e..ce1108aa44 100644 --- a/lapack-netlib/TESTING/EIG/cget51.f +++ b/lapack-netlib/TESTING/EIG/cget51.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER ITYPE, LDA, LDB, LDU, LDV, N * REAL RESULT @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -154,10 +154,10 @@ SUBROUTINE CGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ITYPE, LDA, LDB, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/cget52.f b/lapack-netlib/TESTING/EIG/cget52.f index fd558cd616..d0debc5351 100644 --- a/lapack-netlib/TESTING/EIG/cget52.f +++ b/lapack-netlib/TESTING/EIG/cget52.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * LOGICAL LEFT * INTEGER LDA, LDB, LDE, N @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), E( LDE, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -47,7 +47,7 @@ *> supposed to be normalized so that the maximum "absolute value" *> of its elements is 1, where in this case, "absolute value" *> of a complex value x is |Re(x)| + |Im(x)| ; let us call this -*> maximum "absolute value" norm of a vector v M(v). +*> maximum "absolute value" norm of a vector v M(v). *> if a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate *> vector. The normalization test is: *> @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -161,10 +161,10 @@ SUBROUTINE CGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LEFT diff --git a/lapack-netlib/TESTING/EIG/cget54.f b/lapack-netlib/TESTING/EIG/cget54.f index a16848fc99..955a234004 100644 --- a/lapack-netlib/TESTING/EIG/cget54.f +++ b/lapack-netlib/TESTING/EIG/cget54.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, * LDV, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N * REAL RESULT @@ -20,7 +20,7 @@ * $ T( LDT, * ), U( LDU, * ), V( LDV, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -156,10 +156,10 @@ SUBROUTINE CGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, $ LDV, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/cglmts.f b/lapack-netlib/TESTING/EIG/cglmts.f index dc5759413c..101c07601f 100644 --- a/lapack-netlib/TESTING/EIG/cglmts.f +++ b/lapack-netlib/TESTING/EIG/cglmts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, * X, U, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * REAL RESULT @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), B( LDB, * ), * $ BF( LDB, * ), D( * ), DF( * ), U( * ), * $ WORK( LWORK ), X( * ) -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -150,10 +150,10 @@ SUBROUTINE CGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, $ X, U, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/cgqrts.f b/lapack-netlib/TESTING/EIG/cgqrts.f index db23db75c6..a1d8b807c7 100644 --- a/lapack-netlib/TESTING/EIG/cgqrts.f +++ b/lapack-netlib/TESTING/EIG/cgqrts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -21,7 +21,7 @@ * $ T( LDB, * ), Z( LDB, * ), BWK( LDB, * ), * $ TAUA( * ), TAUB( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -176,10 +176,10 @@ SUBROUTINE CGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/cgrqts.f b/lapack-netlib/TESTING/EIG/cgrqts.f index 7c56c6e33c..e024c78a0a 100644 --- a/lapack-netlib/TESTING/EIG/cgrqts.f +++ b/lapack-netlib/TESTING/EIG/cgrqts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -21,7 +21,7 @@ * $ T( LDB, * ), Z( LDB, * ), BWK( LDB, * ), * $ TAUA( * ), TAUB( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -176,10 +176,10 @@ SUBROUTINE CGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/cgsvts3.f b/lapack-netlib/TESTING/EIG/cgsvts3.f index db57a0bcca..7e6e4352a2 100644 --- a/lapack-netlib/TESTING/EIG/cgsvts3.f +++ b/lapack-netlib/TESTING/EIG/cgsvts3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, * LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P * .. @@ -22,7 +22,7 @@ * $ BF( LDB, * ), Q( LDQ, * ), R( LDR, * ), * $ U( LDU, * ), V( LDV, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -195,10 +195,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -209,7 +209,7 @@ SUBROUTINE CGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * August 2015 diff --git a/lapack-netlib/TESTING/EIG/chbt21.f b/lapack-netlib/TESTING/EIG/chbt21.f index badb6052d3..90ec74c233 100644 --- a/lapack-netlib/TESTING/EIG/chbt21.f +++ b/lapack-netlib/TESTING/EIG/chbt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KA, KS, LDA, LDU, N @@ -19,7 +19,7 @@ * REAL D( * ), E( * ), RESULT( 2 ), RWORK( * ) * COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -150,10 +150,10 @@ SUBROUTINE CHBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/chet21.f b/lapack-netlib/TESTING/EIG/chet21.f index 976f19ffec..8dbdb521ed 100644 --- a/lapack-netlib/TESTING/EIG/chet21.f +++ b/lapack-netlib/TESTING/EIG/chet21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHET21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, * LDV, TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, N @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -211,10 +211,10 @@ SUBROUTINE CHET21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, $ LDV, TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/chet22.f b/lapack-netlib/TESTING/EIG/chet22.f index 7b67169457..5087ecbcab 100644 --- a/lapack-netlib/TESTING/EIG/chet22.f +++ b/lapack-netlib/TESTING/EIG/chet22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHET22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, * V, LDV, TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -159,10 +159,10 @@ SUBROUTINE CHET22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, $ V, LDV, TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/chkxer.f b/lapack-netlib/TESTING/EIG/chkxer.f index eb187defe0..26d6e46886 100644 --- a/lapack-netlib/TESTING/EIG/chkxer.f +++ b/lapack-netlib/TESTING/EIG/chkxer.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* +* * .. Scalar Arguments .. * LOGICAL LERR, OK * CHARACTER*(*) SRNAMT @@ -29,22 +29,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/EIG/chpt21.f b/lapack-netlib/TESTING/EIG/chpt21.f index 00456e02a4..4b92794702 100644 --- a/lapack-netlib/TESTING/EIG/chpt21.f +++ b/lapack-netlib/TESTING/EIG/chpt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, * TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDU, N @@ -20,7 +20,7 @@ * COMPLEX AP( * ), TAU( * ), U( LDU, * ), VP( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -210,12 +210,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -223,10 +223,10 @@ SUBROUTINE CHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, $ TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/chst01.f b/lapack-netlib/TESTING/EIG/chst01.f index 0f5f8702e8..f0c428c88c 100644 --- a/lapack-netlib/TESTING/EIG/chst01.f +++ b/lapack-netlib/TESTING/EIG/chst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), H( LDH, * ), Q( LDQ, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -140,10 +140,10 @@ SUBROUTINE CHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N diff --git a/lapack-netlib/TESTING/EIG/clarfy.f b/lapack-netlib/TESTING/EIG/clarfy.f index da74f56978..a5743858c4 100644 --- a/lapack-netlib/TESTING/EIG/clarfy.f +++ b/lapack-netlib/TESTING/EIG/clarfy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCV, LDC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== SUBROUTINE CLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/clarhs.f b/lapack-netlib/TESTING/EIG/clarhs.f index 3bcba27239..6cb6547138 100644 --- a/lapack-netlib/TESTING/EIG/clarhs.f +++ b/lapack-netlib/TESTING/EIG/clarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -209,10 +209,10 @@ SUBROUTINE CLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/EIG/clatm4.f b/lapack-netlib/TESTING/EIG/clatm4.f index 56378ef497..833234f99c 100644 --- a/lapack-netlib/TESTING/EIG/clatm4.f +++ b/lapack-netlib/TESTING/EIG/clatm4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATM4( ITYPE, N, NZ1, NZ2, RSIGN, AMAGN, RCOND, * TRIANG, IDIST, ISEED, A, LDA ) -* +* * .. Scalar Arguments .. * LOGICAL RSIGN * INTEGER IDIST, ITYPE, LDA, N, NZ1, NZ2 @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -171,10 +171,10 @@ SUBROUTINE CLATM4( ITYPE, N, NZ1, NZ2, RSIGN, AMAGN, RCOND, $ TRIANG, IDIST, ISEED, A, LDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL RSIGN diff --git a/lapack-netlib/TESTING/EIG/clctes.f b/lapack-netlib/TESTING/EIG/clctes.f index 82499faee6..6a7e71c4d4 100644 --- a/lapack-netlib/TESTING/EIG/clctes.f +++ b/lapack-netlib/TESTING/EIG/clctes.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION CLCTES( Z, D ) -* +* * .. Scalar Arguments .. * COMPLEX D, Z * .. -* +* * *> \par Purpose: * ============= @@ -25,7 +25,7 @@ *> eigenvalue is negative), and otherwise it returns .FALSE.. *> *> It is used by the test routine CDRGES to test whether the driver -*> routine CGGES succesfully sorts eigenvalues. +*> routine CGGES successfully sorts eigenvalues. *> \endverbatim * * Arguments: @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * * ===================================================================== LOGICAL FUNCTION CLCTES( Z, D ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. COMPLEX D, Z diff --git a/lapack-netlib/TESTING/EIG/clctsx.f b/lapack-netlib/TESTING/EIG/clctsx.f index 047b46de12..fbf19e40b5 100644 --- a/lapack-netlib/TESTING/EIG/clctsx.f +++ b/lapack-netlib/TESTING/EIG/clctsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION CLCTSX( ALPHA, BETA ) -* +* * .. Scalar Arguments .. * COMPLEX ALPHA, BETA * .. -* +* * *> \par Purpose: * ============= @@ -45,22 +45,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * * ===================================================================== LOGICAL FUNCTION CLCTSX( ALPHA, BETA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX ALPHA, BETA diff --git a/lapack-netlib/TESTING/EIG/clsets.f b/lapack-netlib/TESTING/EIG/clsets.f index 91fc485073..13e037df6d 100644 --- a/lapack-netlib/TESTING/EIG/clsets.f +++ b/lapack-netlib/TESTING/EIG/clsets.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, * D, DF, X, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), B( LDB, * ), * $ BF( LDB, * ), C( * ), D( * ), CF( * ), * $ DF( * ), WORK( LWORK ), X( * ) -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -155,10 +155,10 @@ SUBROUTINE CLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, $ D, DF, X, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/csbmv.f b/lapack-netlib/TESTING/EIG/csbmv.f index 7a9033e695..dc1b2330d3 100644 --- a/lapack-netlib/TESTING/EIG/csbmv.f +++ b/lapack-netlib/TESTING/EIG/csbmv.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, K, LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -152,10 +152,10 @@ SUBROUTINE CSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/csgt01.f b/lapack-netlib/TESTING/EIG/csgt01.f index 0dd0ad6920..e6d6bb3e22 100644 --- a/lapack-netlib/TESTING/EIG/csgt01.f +++ b/lapack-netlib/TESTING/EIG/csgt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, LDA, LDB, LDZ, M, N @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -152,10 +152,10 @@ SUBROUTINE CSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/cslect.f b/lapack-netlib/TESTING/EIG/cslect.f index ea244d892c..1092b630ad 100644 --- a/lapack-netlib/TESTING/EIG/cslect.f +++ b/lapack-netlib/TESTING/EIG/cslect.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION CSLECT( Z ) -* +* * .. Scalar Arguments .. * COMPLEX Z * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,8 @@ *> *> CSLECT returns .TRUE. if the eigenvalue Z is to be selected, *> otherwise it returns .FALSE. -*> It is used by CCHK41 to test if CGEES succesfully sorts eigenvalues, -*> and by CCHK43 to test if CGEESX succesfully sorts eigenvalues. +*> It is used by CCHK41 to test if CGEES successfully sorts eigenvalues, +*> and by CCHK43 to test if CGEESX successfully sorts eigenvalues. *> *> The common block /SSLCT/ controls how eigenvalues are selected. *> If SELOPT = 0, then CSLECT return .TRUE. when real(Z) is less than @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_eig * * ===================================================================== LOGICAL FUNCTION CSLECT( Z ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. COMPLEX Z diff --git a/lapack-netlib/TESTING/EIG/cstt21.f b/lapack-netlib/TESTING/EIG/cstt21.f index c1320fed13..47d99ac498 100644 --- a/lapack-netlib/TESTING/EIG/cstt21.f +++ b/lapack-netlib/TESTING/EIG/cstt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, N * .. @@ -19,7 +19,7 @@ * $ SD( * ), SE( * ) * COMPLEX U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -132,10 +132,10 @@ SUBROUTINE CSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, N diff --git a/lapack-netlib/TESTING/EIG/cstt22.f b/lapack-netlib/TESTING/EIG/cstt22.f index dca37f6468..2db3736e81 100644 --- a/lapack-netlib/TESTING/EIG/cstt22.f +++ b/lapack-netlib/TESTING/EIG/cstt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, * LDWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, LDWORK, M, N * .. @@ -19,7 +19,7 @@ * $ SD( * ), SE( * ) * COMPLEX U( LDU, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -145,10 +145,10 @@ SUBROUTINE CSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ LDWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, LDWORK, M, N diff --git a/lapack-netlib/TESTING/EIG/cunt01.f b/lapack-netlib/TESTING/EIG/cunt01.f index 7c6d56ab97..20c5682184 100644 --- a/lapack-netlib/TESTING/EIG/cunt01.f +++ b/lapack-netlib/TESTING/EIG/cunt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CUNT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER ROWCOL * INTEGER LDU, LWORK, M, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -126,10 +126,10 @@ SUBROUTINE CUNT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER ROWCOL diff --git a/lapack-netlib/TESTING/EIG/cunt03.f b/lapack-netlib/TESTING/EIG/cunt03.f index a0dc7e4c76..8e1fd207fa 100644 --- a/lapack-netlib/TESTING/EIG/cunt03.f +++ b/lapack-netlib/TESTING/EIG/cunt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CUNT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, * RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) RC * INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_eig * @@ -162,10 +162,10 @@ SUBROUTINE CUNT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, $ RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) RC diff --git a/lapack-netlib/TESTING/EIG/dbdt01.f b/lapack-netlib/TESTING/EIG/dbdt01.f index c9d23a021e..4b2219e5d7 100644 --- a/lapack-netlib/TESTING/EIG/dbdt01.f +++ b/lapack-netlib/TESTING/EIG/dbdt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KD, LDA, LDPT, LDQ, M, N * DOUBLE PRECISION RESID @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), PT( LDPT, * ), * $ Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -140,10 +140,10 @@ SUBROUTINE DBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KD, LDA, LDPT, LDQ, M, N diff --git a/lapack-netlib/TESTING/EIG/dbdt02.f b/lapack-netlib/TESTING/EIG/dbdt02.f index 3c3ad98ceb..2f7c8c1f91 100644 --- a/lapack-netlib/TESTING/EIG/dbdt02.f +++ b/lapack-netlib/TESTING/EIG/dbdt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDC, LDU, M, N * DOUBLE PRECISION RESID @@ -18,7 +18,7 @@ * DOUBLE PRECISION B( LDB, * ), C( LDC, * ), U( LDU, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDC, LDU, M, N diff --git a/lapack-netlib/TESTING/EIG/dbdt03.f b/lapack-netlib/TESTING/EIG/dbdt03.f index 7ad2ac4327..80c0473311 100644 --- a/lapack-netlib/TESTING/EIG/dbdt03.f +++ b/lapack-netlib/TESTING/EIG/dbdt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDU, LDVT, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -135,10 +135,10 @@ SUBROUTINE DBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dbdt04.f b/lapack-netlib/TESTING/EIG/dbdt04.f index f90e121d63..494442cc9a 100644 --- a/lapack-netlib/TESTING/EIG/dbdt04.f +++ b/lapack-netlib/TESTING/EIG/dbdt04.f @@ -1,14 +1,15 @@ +*> \brief \b DBDT04 * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE DBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, +* SUBROUTINE DBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDU, LDVT, N, NS @@ -18,7 +19,7 @@ * DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -68,14 +69,14 @@ *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -117,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -130,10 +131,10 @@ SUBROUTINE DBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dbdt05.f b/lapack-netlib/TESTING/EIG/dbdt05.f index ef5a2cbc08..3580aec81f 100644 --- a/lapack-netlib/TESTING/EIG/dbdt05.f +++ b/lapack-netlib/TESTING/EIG/dbdt05.f @@ -1,14 +1,14 @@ * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE DBDT05( M, N, A, LDA, S, NS, U, LDU, -* VT, LDVT, WORK, RESID ) -* +* SUBROUTINE DBDT05( M, N, A, LDA, S, NS, U, LDU, +* VT, LDVT, WORK, RESID ) +* * .. Scalar Arguments .. * INTEGER LDA, LDU, LDVT, N, NS * DOUBLE PRECISION RESID @@ -17,7 +17,7 @@ * DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,14 +62,14 @@ *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -111,26 +111,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== - SUBROUTINE DBDT05( M, N, A, LDA, S, NS, U, LDU, + SUBROUTINE DBDT05( M, N, A, LDA, S, NS, U, LDU, $ VT, LDVT, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. - CHARACTER UPLO INTEGER LDA, LDU, LDVT, M, N, NS DOUBLE PRECISION RESID * .. diff --git a/lapack-netlib/TESTING/EIG/dchkbb.f b/lapack-netlib/TESTING/EIG/dchkbb.f index 47cdc57042..51a29585bd 100644 --- a/lapack-netlib/TESTING/EIG/dchkbb.f +++ b/lapack-netlib/TESTING/EIG/dchkbb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB, * BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK, * LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, * $ NRHS, NSIZES, NTYPES, NWDTHS @@ -25,7 +25,7 @@ * $ C( LDC, * ), CC( LDC, * ), P( LDP, * ), * $ Q( LDQ, * ), RESULT( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -340,12 +340,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -358,7 +358,7 @@ SUBROUTINE DCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE, * -- LAPACK test routine (input) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/dchkbd.f b/lapack-netlib/TESTING/EIG/dchkbd.f index f9790692ef..0557574d35 100644 --- a/lapack-netlib/TESTING/EIG/dchkbd.f +++ b/lapack-netlib/TESTING/EIG/dchkbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX, * Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, * IWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * $ VT( LDPT, * ), WORK( * ), X( LDX, * ), * $ Y( LDX, * ), Z( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,7 +64,7 @@ *> singular vectors are not computed. *> *> DBDSVDX computes the singular value decomposition of the bidiagonal -*> matrix B as B = U S V' using bisection and inverse iteration. It is +*> matrix B as B = U S V' using bisection and inverse iteration. It is *> called six times to compute *> 1) B = U S1 V', RANGE='A', where S1 is the diagonal matrix of singular *> values and the columns of the matrices U and V are the left @@ -147,43 +147,43 @@ *> (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. *> Test DBDSVDX on bidiagonal matrix B -*> +*> *> (20) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' -*> +*> *> (21) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (22) | I - VT VT' | / ( min(M,N) ulp ) -*> +*> *> (23) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (24) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> (25) | S1 - U' B VT' | / ( |S| n ulp ) DBDSVDX('V', 'I') -*> +*> *> (26) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (27) | I - VT VT' | / ( min(M,N) ulp ) *> *> (28) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (29) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> (30) | S1 - U' B VT' | / ( |S1| n ulp ) DBDSVDX('V', 'V') -*> +*> *> (31) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (32) | I - VT VT' | / ( min(M,N) ulp ) *> *> (33) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (34) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> The possible matrix types are *> *> (1) The zero matrix. @@ -478,12 +478,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * @@ -493,10 +493,10 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, $ IWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, @@ -525,18 +525,18 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, LOGICAL BADMM, BADNN, BIDIAG CHARACTER UPLO CHARACTER*3 PATH - INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, IWBD, + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, IWBD, $ IWBE, IWBS, IWBZ, IWWORK, J, JCOL, JSIZE, - $ JTYPE, LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, - $ MNMIN2, MQ, MTYPES, N, NFAIL, NMAX, + $ JTYPE, LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, + $ MNMIN2, MQ, MTYPES, N, NFAIL, NMAX, $ NS1, NS2, NTEST - DOUBLE PRECISION ABSTOL, AMNINV, ANORM, COND, OVFL, RTOVFL, - $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, - $ UNFL, VL, VU + DOUBLE PRECISION ABSTOL, AMNINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL, + $ VL, VU * .. * .. Local Arrays .. - INTEGER IDUM( 1 ), IOLDSD( 4 ), ISEED2( 4 ), - $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + INTEGER IDUM( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), $ KTYPE( MAXTYP ) DOUBLE PRECISION DUM( 1 ), DUMMA( 1 ), RESULT( 40 ) * .. @@ -545,10 +545,10 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, EXTERNAL DLAMCH, DLARND, DSXT1 * .. * .. External Subroutines .. - EXTERNAL ALASUM, DBDSDC, DBDSQR, DBDSVDX, DBDT01, DBDT02, - $ DBDT03, DBDT04, DCOPY, DGEBRD, DGEMM, DLABAD, - $ DLACPY, DLAHD2, DLASET, DLATMR, DLATMS, - $ DORGBR, DORT01, XERBLA + EXTERNAL ALASUM, DBDSDC, DBDSQR, DBDSVDX, DBDT01, + $ DBDT02, DBDT03, DBDT04, DCOPY, DGEBRD, + $ DGEMM, DLABAD, DLACPY, DLAHD2, DLASET, + $ DLATMR, DLATMS, DORGBR, DORT01, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT @@ -563,10 +563,10 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / - DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / - DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, - $ 0, 0, 0 / + DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / + DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 0 / * .. * .. Executable Statements .. * @@ -1143,7 +1143,7 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, IWBD = IWBS + MNMIN IWBE = IWBD + MNMIN IWBZ = IWBE + MNMIN - IWWORK = IWBZ + MNMIN*(MNMIN*2+1) + IWWORK = IWBZ + 2*MNMIN*(MNMIN+1) MNMIN2 = MAX( 1,MNMIN*2 ) * CALL DCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) @@ -1151,10 +1151,10 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ CALL DCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL DBDSVDX( UPLO, 'V', 'A', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO) -* +* * Check error code from DBDSVDX. * IF( IINFO.NE.0 ) THEN @@ -1190,17 +1190,17 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL DCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) - $ CALL DCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) -* + $ CALL DCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) +* CALL DBDSVDX( UPLO, 'N', 'A', MNMIN, WORK( IWBD ), $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from DBDSVDX. * IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9998 )'DBDSVDX(values,A)', IINFO, + WRITE( NOUT, FMT = 9998 )'DBDSVDX(values,A)', IINFO, $ M, N, JTYPE, IOLDSD INFO = ABS( IINFO ) IF( IINFO.LT.0 ) THEN @@ -1224,11 +1224,11 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, $ LDPT, WORK( IWBS+MNMIN ), RESULT( 20 ) ) - CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 21 ) ) - CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 22) ) * RESULT( 23 ) = ZERO @@ -1272,14 +1272,14 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, IL = ITEMP END IF END IF -* +* CALL DCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) $ CALL DCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL DBDSVDX( UPLO, 'V', 'I', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO) * * Check error code from DBDSVDX. @@ -1313,7 +1313,7 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL DBDSVDX( UPLO, 'N', 'I', MNMIN, WORK( IWBD ), $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from DBDSVDX. @@ -1337,13 +1337,13 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * non-increasing order and are non-negative * 29: Compare DBDSVDX with and without singular vectors * - CALL DBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, - $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), + CALL DBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, + $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), $ RESULT( 25 ) ) - CALL DORT01( 'Columns', MNMIN, NS1, U, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL DORT01( 'Columns', MNMIN, NS1, U, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 26 ) ) - CALL DORT01( 'Rows', NS1, MNMIN, VT, LDPT, + CALL DORT01( 'Rows', NS1, MNMIN, VT, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 27 ) ) * @@ -1368,8 +1368,8 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, 230 CONTINUE RESULT( 29 ) = TEMP2 * -* Use DBDSVDX with RANGE='V': determine the values VL and VU -* of the IL-th and IU-th singular values and ask for all +* Use DBDSVDX with RANGE='V': determine the values VL and VU +* of the IL-th and IU-th singular values and ask for all * singular values in this range. * CALL DCOPY( MNMIN, WORK( IWBS ), 1, S1, 1 ) @@ -1395,21 +1395,21 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, ELSE VL = ZERO VU = ONE - END IF -* + END IF +* CALL DCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) $ CALL DCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL DBDSVDX( UPLO, 'V', 'V', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), VL, VU, 0, 0, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), VL, VU, 0, 0, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from DBDSVDX. * IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9998 )'DBDSVDX(vects,V)', IINFO, + WRITE( NOUT, FMT = 9998 )'DBDSVDX(vects,V)', IINFO, $ M, N, JTYPE, IOLDSD INFO = ABS( IINFO ) IF( IINFO.LT.0 ) THEN @@ -1437,7 +1437,7 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL DBDSVDX( UPLO, 'N', 'V', MNMIN, WORK( IWBD ), $ WORK( IWBE ), VL, VU, 0, 0, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from DBDSVDX. @@ -1461,13 +1461,13 @@ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * non-increasing order and are non-negative * 34: Compare DBDSVDX with and without singular vectors * - CALL DBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, - $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), + CALL DBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, + $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), $ RESULT( 30 ) ) - CALL DORT01( 'Columns', MNMIN, NS1, U, LDPT, + CALL DORT01( 'Columns', MNMIN, NS1, U, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 31 ) ) - CALL DORT01( 'Rows', NS1, MNMIN, VT, LDPT, + CALL DORT01( 'Rows', NS1, MNMIN, VT, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 32 ) ) * diff --git a/lapack-netlib/TESTING/EIG/dchkbk.f b/lapack-netlib/TESTING/EIG/dchkbk.f index 42ee948b10..2accd4bfd9 100644 --- a/lapack-netlib/TESTING/EIG/dchkbk.f +++ b/lapack-netlib/TESTING/EIG/dchkbk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKBK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -21,7 +21,7 @@ *> \verbatim *> *> DCHKBK tests DGEBAK, a routine for backward transformation of -*> the computed right or left eigenvectors if the orginal matrix +*> the computed right or left eigenvectors if the original matrix *> was preprocessed by balance subroutine DGEBAL. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DCHKBK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dchkbl.f b/lapack-netlib/TESTING/EIG/dchkbl.f index bb10fd54c0..403d4edc54 100644 --- a/lapack-netlib/TESTING/EIG/dchkbl.f +++ b/lapack-netlib/TESTING/EIG/dchkbl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKBL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DCHKBL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dchkec.f b/lapack-netlib/TESTING/EIG/dchkec.f index 1681215e93..0b0f7c1e38 100644 --- a/lapack-netlib/TESTING/EIG/dchkec.f +++ b/lapack-netlib/TESTING/EIG/dchkec.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKEC( THRESH, TSTERR, NIN, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NIN, NOUT * DOUBLE PRECISION THRESH * .. -* +* * *> \par Purpose: * ============= @@ -64,22 +64,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DCHKEC( THRESH, TSTERR, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/EIG/dchkee.f b/lapack-netlib/TESTING/EIG/dchkee.f index 14272bc48a..dc6f3205a2 100644 --- a/lapack-netlib/TESTING/EIG/dchkee.f +++ b/lapack-netlib/TESTING/EIG/dchkee.f @@ -1033,17 +1033,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== PROGRAM DCHKEE * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * ===================================================================== * @@ -1106,7 +1106,8 @@ PROGRAM DCHKEE $ DDRGEV, DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, $ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, $ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV, - $ DDRGES3, DDRGEV3 + $ DDRGES3, DDRGEV3, + $ DCHKST2STG, DDRVST2STG, DCHKSB2STG, DDRVSG2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1153,7 +1154,7 @@ PROGRAM DCHKEE PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' ) .OR. - $ LSAMEN( 3, PATH, 'DSG' ) + $ LSAMEN( 3, PATH, 'DSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) DEV = LSAMEN( 3, PATH, 'DEV' ) DES = LSAMEN( 3, PATH, 'DES' ) @@ -1839,7 +1840,8 @@ PROGRAM DCHKEE $ WRITE( NOUT, FMT = 9980 )'DCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1869,6 +1871,15 @@ PROGRAM DCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL DCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL DCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), @@ -1876,16 +1887,26 @@ PROGRAM DCHKEE $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL DDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL DDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), $ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX, $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DDRVST', INFO END IF @@ -1918,11 +1939,17 @@ PROGRAM DCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL DDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO END IF @@ -2105,6 +2132,7 @@ PROGRAM DCHKEE MAXTYP = 26 NTYPES = MIN( MAXTYP, NTYPES ) CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV(1,1) IF( TSTCHK .AND. TSTERR ) $ CALL DERRGG( C3, NOUT ) DO 350 I = 1, NPARMS @@ -2164,6 +2192,7 @@ PROGRAM DCHKEE * * Blocked version * + CALL XLAENV(16, 2) CALL DDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2280,9 +2309,13 @@ PROGRAM DCHKEE CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL DERRST( 'DSB', NOUT ) - CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) +* CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) + CALL DCHKSB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DCHKSB', INFO * @@ -2351,6 +2384,7 @@ PROGRAM DCHKEE * GSV: Generalized Singular Value Decomposition * ---------------------------------------------- * + CALL XLAENV(1,1) IF( TSTERR ) $ CALL DERRGG( 'GSV', NOUT ) CALL DCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, diff --git a/lapack-netlib/TESTING/EIG/dchkgg.f b/lapack-netlib/TESTING/EIG/dchkgg.f index ebdc9f1864..912ca4ae07 100644 --- a/lapack-netlib/TESTING/EIG/dchkgg.f +++ b/lapack-netlib/TESTING/EIG/dchkgg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1, * BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR, * WORK, LWORK, LLWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL TSTDIF * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES @@ -31,7 +31,7 @@ * $ U( LDU, * ), V( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,7 +72,7 @@ *> and each type of matrix, one matrix will be generated and used *> to test the nonsymmetric eigenroutines. For each matrix, 15 *> tests will be performed. The first twelve "test ratios" should be -*> small -- O(1). They will be compared with the threshhold THRESH: +*> small -- O(1). They will be compared with the threshold THRESH: *> *> T *> (1) | A - U H V | / ( |A| n ulp ) @@ -132,7 +132,7 @@ *> |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp *> *> In addition, the normalization of L and R are checked, and compared -*> with the threshhold THRSHN. +*> with the threshold THRSHN. *> *> Test Matrices *> ---- -------- @@ -298,7 +298,7 @@ *> \param[in] THRSHN *> \verbatim *> THRSHN is DOUBLE PRECISION -*> Threshhold for reporting eigenvector normalization error. +*> Threshold for reporting eigenvector normalization error. *> If the normalization of any eigenvector differs from 1 by *> more than THRSHN*ulp, then a special error message will be *> printed. (This is handled separately from the other tests, @@ -495,12 +495,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -511,10 +511,10 @@ SUBROUTINE DCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR, $ WORK, LWORK, LLWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL TSTDIF diff --git a/lapack-netlib/TESTING/EIG/dchkgk.f b/lapack-netlib/TESTING/EIG/dchkgk.f index 1f827a5361..85c7325d49 100644 --- a/lapack-netlib/TESTING/EIG/dchkgk.f +++ b/lapack-netlib/TESTING/EIG/dchkgk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKGK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DCHKGK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dchkgl.f b/lapack-netlib/TESTING/EIG/dchkgl.f index aebc7183dd..d7fd0cadc0 100644 --- a/lapack-netlib/TESTING/EIG/dchkgl.f +++ b/lapack-netlib/TESTING/EIG/dchkgl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKGL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -41,22 +41,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DCHKGL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dchkhs.f b/lapack-netlib/TESTING/EIG/dchkhs.f index 928856b853..375a70e9a4 100644 --- a/lapack-netlib/TESTING/EIG/dchkhs.f +++ b/lapack-netlib/TESTING/EIG/dchkhs.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * WI1, WR2, WI2, WR3, WI3, EVECTL, EVECTR, EVECTY, * EVECTX, UU, TAU, WORK, NWORK, IWORK, SELECT, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK * DOUBLE PRECISION THRESH @@ -29,7 +29,7 @@ * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), * $ WR1( * ), WR2( * ), WR3( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -396,12 +396,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_eig * @@ -412,10 +412,10 @@ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ EVECTY, EVECTX, UU, TAU, WORK, NWORK, IWORK, $ SELECT, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK diff --git a/lapack-netlib/TESTING/EIG/dchksb.f b/lapack-netlib/TESTING/EIG/dchksb.f index b4ba2a89ef..b95e595de2 100644 --- a/lapack-netlib/TESTING/EIG/dchksb.f +++ b/lapack-netlib/TESTING/EIG/dchksb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, * LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, * $ NWDTHS @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ), * $ U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,12 +279,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -293,10 +293,10 @@ SUBROUTINE DCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, $ LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, diff --git a/lapack-netlib/TESTING/EIG/dchksb2stg.f b/lapack-netlib/TESTING/EIG/dchksb2stg.f new file mode 100644 index 0000000000..8cd1944247 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/dchksb2stg.f @@ -0,0 +1,868 @@ +*> \brief \b DCHKSBSTG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ), +* $ U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKSBSTG tests the reduction of a symmetric band matrix to tridiagonal +*> form, used with the symmetric eigenvalue problem. +*> +*> DSBTRD factors a symmetric band matrix A as U S U' , where ' means +*> transpose, S is symmetric tridiagonal, and U is orthogonal. +*> DSBTRD can use either just the lower or just the upper triangle +*> of A; DCHKSBSTG checks both cases. +*> +*> DSYTRD_SB2ST factors a symmetric band matrix A as U S U' , +*> where ' means transpose, S is symmetric tridiagonal, and U is +*> orthogonal. DSYTRD_SB2ST can use either just the lower or just +*> the upper triangle of A; DCHKSBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When DCHKSBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the symmetric banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with +*> UPLO='U' +*> +*> (2) | I - UU' | / ( n ulp ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with +*> UPLO='L' +*> +*> (4) | I - UU' | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> DSYTRD_SB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> DSYTRD_SB2ST with UPLO='L' +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> DCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. The values must be at least zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DCHKSBSTG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DCHKSBSTG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA, max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by DSBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by DSBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> Used to hold the orthogonal matrix computed by DSBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (4) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ), + $ U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TEN = 10.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N, + $ NERRS, NMATS, NMAX, NTEST, NTESTT + DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DLASUM, DLATMR, DLATMS, DSBT21, + $ DSBTRD, XERBLA, DSBTRD_SB2ST, DSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DCHKSBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK( N+1 ), IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call DSBTRD to compute S and U from upper triangle. +* + CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL DSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL DSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_SB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = A( K+1-JR, JC+JR ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call DSBTRD to compute S and U from lower triangle +* + CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL DSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL DSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_SB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'DSB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL DLASUM( 'DSB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' DCHKSBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, + $ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' ) + 9997 FORMAT( ' Matrix types (see DCHKSBSTG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of DCHKSBSTG +* + END diff --git a/lapack-netlib/TESTING/EIG/dchkst.f b/lapack-netlib/TESTING/EIG/dchkst.f index ec90e13655..f08deb5293 100644 --- a/lapack-netlib/TESTING/EIG/dchkst.f +++ b/lapack-netlib/TESTING/EIG/dchkst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, * WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, * LWORK, IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), * $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -518,7 +518,7 @@ *> \verbatim *> LIWORK is INTEGER *> The number of entries in IWORK. This must be at least -*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax *> where Nmax = max( NN(j), 2 ) and lg = log base 2. *> \endverbatim *> @@ -576,12 +576,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -591,10 +591,10 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/dchkst2stg.f b/lapack-netlib/TESTING/EIG/dchkst2stg.f new file mode 100644 index 0000000000..fc015334de --- /dev/null +++ b/lapack-netlib/TESTING/EIG/dchkst2stg.f @@ -0,0 +1,2068 @@ +*> \brief \b DCHKST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKST2STG checks the symmetric eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> DSYTRD. For that, we call the standard DSYTRD and compute D1 using +*> DSTEQR, then we call the 2-stage DSYTRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the DCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> DSYTRD factors A as U S U' , where ' means transpose, +*> S is symmetric tridiagonal, and U is orthogonal. +*> DSYTRD can use either just the lower or just the upper triangle +*> of A; DCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> DSPTRD does the same as DSYTRD, except that A and V are stored +*> in "packed" format. +*> +*> DORGTR constructs the matrix U from the contents of V and TAU. +*> +*> DOPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> DSTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> DSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> DPTEQR factors S as Z4 D4 Z4' , for a +*> symmetric positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> DSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> DSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> DSTEDC factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input orthogonal matrix, usually the output +*> from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> DSTEMR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). DSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When DCHKST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the symmetric eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> DSYTRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> DSYTRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for DSPTRD and DOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) DSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) DSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) DSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> DSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) DPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) DPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) DSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) DSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) DSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) DSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and +*> DSTEDC('N') +*> +*> Test 27 is disabled at the moment because DSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because DSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DCHKST2STG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DCHKST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DCHKST2STG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by DSYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> DSYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DPTEQR(V). +*> DPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by DSYTRD + DORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by DSYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in DSYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as DORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The Householder factors computed by DSYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by DSTEQR, +*> DPTEQR, and DSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF, +*> or DORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT, LH, LW + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + DOUBLE PRECISION DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLACPY, DLASET, DLASUM, DLATMR, + $ DLATMS, DOPGTR, DORGTR, DPTEQR, DSPT21, DSPTRD, + $ DSTEBZ, DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR, + $ DSTERF, DSTT21, DSTT22, DSYT21, DSYTRD, XERBLA, + $ DSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'DSYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call DSYTRD and DORGTR to compute S and U from +* upper triangle. +* + CALL DLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL DSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL DORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL DSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL DSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( "U", N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( "L", N, N, A, LDA, V, LDU ) + CALL DSYTRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call DSPTRD and DOPGTR to compute S and U from AP +* + CALL DCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL DSPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL DOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DOPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL DSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 5 ) ) + CALL DSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call DSPTRD and DOPGTR to compute S and U from AP +* + CALL DCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL DSPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL DOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DOPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 7 ) ) + CALL DSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 8 ) ) +* +* Call DSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 9 + CALL DSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 11 + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 12 + CALL DSTERF( N, D3, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL DSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call DPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL DCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 14 + CALL DPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL DSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RESULT( 14 ) ) +* +* Compute D5 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 16 + CALL DPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call DSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call DSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call DSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL DSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, + $ RESULT( 20 ) ) +* +* Call DSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 22 + CALL DSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 22 ) ) +* +* Call DSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 24 + CALL DSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 24 ) ) +* +* Call DSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 26 + CALL DSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test DSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call DSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. SREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL DSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( SRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL DSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call DSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + IF( SRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL DSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 29 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 31 + CALL DSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call DSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 32 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 34 + CALL DSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call DSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 35 +* + CALL DSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RESULT( 35 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 37 + CALL DSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'DST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL DLASUM( 'DST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' DCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see DCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see DCHKST2STG for details.', / ) +* End of DCHKST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/dckcsd.f b/lapack-netlib/TESTING/EIG/dckcsd.f index 219ebafcfe..50db6baa04 100644 --- a/lapack-netlib/TESTING/EIG/dckcsd.f +++ b/lapack-netlib/TESTING/EIG/dckcsd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, * MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, * WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * DOUBLE PRECISION U1( * ), U2( * ), V1T( * ), V2T( * ), * $ WORK( * ), X( * ), XF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -184,10 +184,10 @@ SUBROUTINE DCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, $ MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, $ WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/dckglm.f b/lapack-netlib/TESTING/EIG/dckglm.f index 2b2a929533..a47e9dbe1f 100644 --- a/lapack-netlib/TESTING/EIG/dckglm.f +++ b/lapack-netlib/TESTING/EIG/dckglm.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * DOUBLE PRECISION THRESH @@ -21,7 +21,7 @@ * DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -167,10 +167,10 @@ SUBROUTINE DCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dckgqr.f b/lapack-netlib/TESTING/EIG/dckgqr.f index 595aed9778..eb86643fc3 100644 --- a/lapack-netlib/TESTING/EIG/dckgqr.f +++ b/lapack-netlib/TESTING/EIG/dckgqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, * THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, * BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP * DOUBLE PRECISION THRESH @@ -22,7 +22,7 @@ * $ BF( * ), BT( * ), BWK( * ), BZ( * ), * $ RWORK( * ), TAUA( * ), TAUB( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -210,10 +210,10 @@ SUBROUTINE DCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, $ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, $ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP diff --git a/lapack-netlib/TESTING/EIG/dckgsv.f b/lapack-netlib/TESTING/EIG/dckgsv.f index 1ef805adcf..bc57ff8416 100644 --- a/lapack-netlib/TESTING/EIG/dckgsv.f +++ b/lapack-netlib/TESTING/EIG/dckgsv.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, * IWORK, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * $ BF( * ), Q( * ), R( * ), RWORK( * ), U( * ), * $ V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_eig * @@ -198,10 +198,10 @@ SUBROUTINE DCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, $ IWORK, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/dcklse.f b/lapack-netlib/TESTING/EIG/dcklse.f index a9853c46ef..7d9b3f594d 100644 --- a/lapack-netlib/TESTING/EIG/dcklse.f +++ b/lapack-netlib/TESTING/EIG/dcklse.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * DOUBLE PRECISION THRESH @@ -21,7 +21,7 @@ * DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -167,10 +167,10 @@ SUBROUTINE DCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/dcsdts.f b/lapack-netlib/TESTING/EIG/dcsdts.f index 528092a1d1..14ffc7814a 100644 --- a/lapack-netlib/TESTING/EIG/dcsdts.f +++ b/lapack-netlib/TESTING/EIG/dcsdts.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, * LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. @@ -22,7 +22,7 @@ * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -229,10 +229,10 @@ SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -280,7 +280,7 @@ SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ DLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) ) ELSE EPS2 = ULP @@ -445,7 +445,7 @@ SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL DSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX, $ ONE, WORK, LDX ) IF( M.GT.0 ) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ DLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) ) ELSE EPS2 = ULP @@ -551,7 +551,7 @@ SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, END DO * RETURN -* +* * End of DCSDTS * END diff --git a/lapack-netlib/TESTING/EIG/ddrges.f b/lapack-netlib/TESTING/EIG/ddrges.f index b16efc65ba..035ba04d0b 100644 --- a/lapack-netlib/TESTING/EIG/ddrges.f +++ b/lapack-netlib/TESTING/EIG/ddrges.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, * ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES * DOUBLE PRECISION THRESH @@ -25,7 +25,7 @@ * $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), * $ WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,7 +52,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -388,12 +388,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -403,10 +403,10 @@ SUBROUTINE DDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES diff --git a/lapack-netlib/TESTING/EIG/ddrges3.f b/lapack-netlib/TESTING/EIG/ddrges3.f index 773630193b..3b23deebef 100644 --- a/lapack-netlib/TESTING/EIG/ddrges3.f +++ b/lapack-netlib/TESTING/EIG/ddrges3.f @@ -52,7 +52,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -403,7 +403,7 @@ SUBROUTINE DDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/ddrgev.f b/lapack-netlib/TESTING/EIG/ddrgev.f index 9155aed3c5..c587e66aba 100644 --- a/lapack-netlib/TESTING/EIG/ddrgev.f +++ b/lapack-netlib/TESTING/EIG/ddrgev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, * ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, * WORK, LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from DGGEV: *> @@ -393,12 +393,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * @@ -408,10 +408,10 @@ SUBROUTINE DDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, $ WORK, LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/ddrgev3.f b/lapack-netlib/TESTING/EIG/ddrgev3.f index e8de1a8a64..1c60e44347 100644 --- a/lapack-netlib/TESTING/EIG/ddrgev3.f +++ b/lapack-netlib/TESTING/EIG/ddrgev3.f @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from DGGEV3: *> @@ -408,7 +408,7 @@ SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, $ WORK, LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/ddrgsx.f b/lapack-netlib/TESTING/EIG/ddrgsx.f index 843fd20429..44c36407fc 100644 --- a/lapack-netlib/TESTING/EIG/ddrgsx.f +++ b/lapack-netlib/TESTING/EIG/ddrgsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI, * BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S, * WORK, LWORK, IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, * $ NOUT, NSIZE @@ -25,7 +25,7 @@ * $ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ), * $ WORK( * ), Z( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> to test DGGESX. *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH except for the tests (7) and (9): +*> compared with the threshold THRESH except for the tests (7) and (9): *> *> (1) | A - Q S Z' | / ( |A| n ulp ) *> @@ -345,12 +345,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -359,10 +359,10 @@ SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI, $ BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S, $ WORK, LWORK, IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, diff --git a/lapack-netlib/TESTING/EIG/ddrgvx.f b/lapack-netlib/TESTING/EIG/ddrgvx.f index 08a7aff07c..32d08b5d77 100644 --- a/lapack-netlib/TESTING/EIG/ddrgvx.f +++ b/lapack-netlib/TESTING/EIG/ddrgvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE, * RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK, * IWORK, LIWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, * $ NSIZE @@ -27,7 +27,7 @@ * $ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ), * $ VL( LDA, * ), VR( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> ``exactly'' (see DLATM6). *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH. +*> compared with the threshold THRESH. *> *> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of *> @@ -212,32 +212,32 @@ *> IHI is INTEGER *> \endverbatim *> -*> \param[out] LSCALE +*> \param[out] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] RSCALE +*> \param[out] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] S +*> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DTRU +*> \param[out] DTRU *> \verbatim *> DTRU is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DIF +*> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DIFTRU +*> \param[out] DIFTRU *> \verbatim *> DIFTRU is DOUBLE PRECISION array, dimension (N) *> \endverbatim @@ -285,10 +285,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -300,7 +300,7 @@ SUBROUTINE DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI, $ RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK, $ IWORK, LIWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/EIG/ddrvbd.f b/lapack-netlib/TESTING/EIG/ddrvbd.f index d73405669b..8686790521 100644 --- a/lapack-netlib/TESTING/EIG/ddrvbd.f +++ b/lapack-netlib/TESTING/EIG/ddrvbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, * SSAV, E, WORK, LWORK, IWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES, * $ NTYPES @@ -24,7 +24,7 @@ * $ SSAV( * ), U( LDU, * ), USAV( LDU, * ), * $ VT( LDVT, * ), VTSAV( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,7 +131,7 @@ *> *> (29) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the *> vector of singular values from the partial SVD -*> +*> *> Test for DGESVDX( 'V', 'V', 'I' ) *> *> (30) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -139,7 +139,7 @@ *> (31) | I - U'U | / ( M ulp ) *> *> (32) | I - VT VT' | / ( N ulp ) -*> +*> *> Test for DGESVDX( 'V', 'V', 'V' ) *> *> (33) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -341,12 +341,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * @@ -355,10 +355,10 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, $ SSAV, E, WORK, LWORK, IWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES, @@ -386,16 +386,16 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, LOGICAL BADMM, BADNN CHARACTER JOBQ, JOBU, JOBVT, RANGE CHARACTER*3 PATH - INTEGER I, IINFO, IJQ, IJU, IJVT, IL,IU, IWS, IWTMP, - $ ITEMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, - $ MMAX, MNMAX, MNMIN, MTYPES, N, NFAIL, + INTEGER I, IINFO, IJQ, IJU, IJVT, IL,IU, IWS, IWTMP, + $ ITEMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, + $ MMAX, MNMAX, MNMIN, MTYPES, N, NFAIL, $ NMAX, NS, NSI, NSV, NTEST - DOUBLE PRECISION ANORM, DIF, DIV, OVFL, RTUNFL, ULP, + DOUBLE PRECISION ANORM, DIF, DIV, OVFL, RTUNFL, ULP, $ ULPINV, UNFL, VL, VU * .. * .. Local Arrays .. CHARACTER CJOB( 4 ), CJOBR( 3 ), CJOBV( 2 ) - INTEGER IOLDSD( 4 ), ISEED2( 4 ) + INTEGER IOLDSD( 4 ), ISEED2( 4 ) DOUBLE PRECISION RESULT( 40 ) * .. * .. External Functions .. @@ -403,9 +403,9 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL DLAMCH, DLARND * .. * .. External Subroutines .. - EXTERNAL ALASVM, DBDT01, DGEJSV, DGESDD, DGESVD, - $ DGESVDX, DGESVJ, DLABAD, DLACPY, DLASET, DLATMS, - $ DORT01, DORT03, XERBLA + EXTERNAL ALASVM, DBDT01, DGEJSV, DGESDD, DGESVD, + $ DGESVDX, DGESVJ, DLABAD, DLACPY, DLASET, + $ DLATMS, DORT01, DORT03, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN @@ -904,12 +904,12 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * Test DGESVDX * CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL DGESVDX( 'V', 'V', 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, - $ VTSAV, LDVT, WORK, LWORK, IWORK, + CALL DGESVDX( 'V', 'V', 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, + $ VTSAV, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -953,11 +953,11 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, JOBVT = CJOBV( IJVT+1 ) RANGE = CJOBR( 1 ) CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, - $ VL, VU, IL, IU, NS, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL DGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, + $ VL, VU, IL, IU, NS, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) -* +* * Compare U * DIF = ZERO @@ -976,7 +976,7 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IF( M.GT.0 .AND. N.GT.0 ) THEN IF( IJVT.EQ.1 ) THEN CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV, - $ LDVT, VT, LDVT, WORK, LWORK, + $ LDVT, VT, LDVT, WORK, LWORK, $ DIF, IINFO ) END IF END IF @@ -1013,14 +1013,14 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IU = IL IL = ITEMP END IF - END IF + END IF CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL DGESVDX( 'V', 'V', 'I', M, N, A, LDA, - $ VL, VU, IL, IU, NSI, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL DGESVDX( 'V', 'V', 'I', M, N, A, LDA, + $ VL, VU, IL, IU, NSI, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1040,11 +1040,11 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( MNMIN.GT.0 .AND. NSI.GT.1 ) THEN IF( IL.NE.1 ) THEN - VU = SSAV( IL ) + + VU = SSAV( IL ) + $ MAX( HALF*ABS( SSAV( IL )-SSAV( IL-1 ) ), $ ULP*ANORM, TWO*RTUNFL ) ELSE - VU = SSAV( 1 ) + + VU = SSAV( 1 ) + $ MAX( HALF*ABS( SSAV( NS )-SSAV( 1 ) ), $ ULP*ANORM, TWO*RTUNFL ) END IF @@ -1061,14 +1061,14 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, ELSE VL = ZERO VU = ONE - END IF + END IF CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL DGESVDX( 'V', 'V', 'V', M, N, A, LDA, - $ VL, VU, IL, IU, NSV, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL DGESVDX( 'V', 'V', 'V', M, N, A, LDA, + $ VL, VU, IL, IU, NSV, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1087,7 +1087,7 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * End of Loop -- Check for RESULT(j) > THRESH * DO 210 J = 1, 35 - IF( RESULT( J ).GE.THRESH ) THEN + IF( RESULT( J ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, FMT = 9999 ) WRITE( NOUT, FMT = 9998 ) @@ -1138,10 +1138,10 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' decreasing order, else 1/ulp', $ / '19 = | U - Upartial | / ( M ulp )', $ / '20 = | VT - VTpartial | / ( N ulp )', - $ / '21 = | S - Spartial | / ( min(M,N) ulp |S| )', + $ / '21 = | S - Spartial | / ( min(M,N) ulp |S| )', $ / '22 = 0 if S contains min(M,N) nonnegative values in', $ ' decreasing order, else 1/ulp', - $ / '23 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ),' + $ / '23 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ),', $ ' DGESVDX(V,V,A) ', $ / '24 = | I - U**T U | / ( M ulp ) ', $ / '25 = | I - VT VT**T | / ( N ulp ) ', @@ -1157,7 +1157,7 @@ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp ),', $ ' DGESVDX(V,V,V) ', $ / '34 = | I - U**T U | / ( M ulp ) ', - $ / '35 = | I - VT VT**T | / ( N ulp ) ', + $ / '35 = | I - VT VT**T | / ( N ulp ) ', $ / / ) 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1, $ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 ) diff --git a/lapack-netlib/TESTING/EIG/ddrves.f b/lapack-netlib/TESTING/EIG/ddrves.f index 93e495e13e..2904b633af 100644 --- a/lapack-netlib/TESTING/EIG/ddrves.f +++ b/lapack-netlib/TESTING/EIG/ddrves.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, * LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * $ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ), * $ WORK( * ), WR( * ), WRT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -374,12 +374,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -388,10 +388,10 @@ SUBROUTINE DDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, $ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK @@ -948,7 +948,7 @@ SUBROUTINE DDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if WR, WI same no matter if VS computed (sort),', $ ' 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / ) + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', / ) 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ), $ ' type ', I2, ', test(', I2, ')=', G10.3 ) 9992 FORMAT( ' DDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', diff --git a/lapack-netlib/TESTING/EIG/ddrvev.f b/lapack-netlib/TESTING/EIG/ddrvev.f index 8b5fc3ef31..a3e6a2023a 100644 --- a/lapack-netlib/TESTING/EIG/ddrvev.f +++ b/lapack-netlib/TESTING/EIG/ddrvev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, * VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -25,7 +25,7 @@ * $ RESULT( 7 ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -391,12 +391,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -406,10 +406,10 @@ SUBROUTINE DDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, $ IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/ddrvsg.f b/lapack-netlib/TESTING/EIG/ddrvsg.f index 9f89d383ff..de094fcd8b 100644 --- a/lapack-netlib/TESTING/EIG/ddrvsg.f +++ b/lapack-netlib/TESTING/EIG/ddrvsg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, * BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -24,7 +24,7 @@ * $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), * $ RESULT( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -341,12 +341,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -355,10 +355,10 @@ SUBROUTINE DDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, $ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/ddrvsg2stg.f b/lapack-netlib/TESTING/EIG/ddrvsg2stg.f new file mode 100644 index 0000000000..700e4f74d5 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/ddrvsg2stg.f @@ -0,0 +1,1362 @@ +*> \brief \b DDRVSG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVSG2STG checks the real symmetric generalized eigenproblem +*> drivers. +*> +*> DSYGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> DSYGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> DSYGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> DSPGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> DSPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> DSPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> DSBGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> DSBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> DSBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> When DDRVSG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) DSYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> DSYGV and D2 is computed by +*> DSYGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling DSPGV +*> (3) as (1) but calling DSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling DSPGV +*> (6) as (4) but calling DSBGV +*> +*> (7) DSYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling DSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling DSPGV +*> +*> (11) DSYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling DSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling DSPGV +*> +*> DSYGVD, DSPGVD and DSBGVD performed the same 14 tests. +*> +*> DSYGVX, DSPGVX and DSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value +*> of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVSG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B DOUBLE PRECISION array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB DOUBLE PRECISION array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB DOUBLE PRECISION array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, +*> DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + 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 .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL LSAME, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLACPY, DLAFTS, DLASET, DLASUM, DLATMR, + $ DLATMS, DSBGV, DSBGVD, DSBGVX, DSGT01, DSPGV, + $ DSPGVD, DSPGVX, DSYGV, DSYGVD, DSYGVX, XERBLA, + $ DSYGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, SSBGVD, +* DSYGVX, DSPGVX, and DSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test DSYGV +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSYGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test DSYGVD +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSYGVX +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL DSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test DSPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL DSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL DSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL DSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL DSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL DSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST DSBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL DSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* TEST DSBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL DSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL DSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL DSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL DSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'DSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL DLASUM( 'DSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of DDRVSG2STG +* + 9999 FORMAT( ' DDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/lapack-netlib/TESTING/EIG/ddrvst.f b/lapack-netlib/TESTING/EIG/ddrvst.f index ebe04b1c28..efa75406f2 100644 --- a/lapack-netlib/TESTING/EIG/ddrvst.f +++ b/lapack-netlib/TESTING/EIG/ddrvst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, * WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, * IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), * $ WA3( * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -438,12 +438,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -453,10 +453,10 @@ SUBROUTINE DDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, $ IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/ddrvst2stg.f b/lapack-netlib/TESTING/EIG/ddrvst2stg.f new file mode 100644 index 0000000000..489c385a16 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/ddrvst2stg.f @@ -0,0 +1,2872 @@ +*> \brief \b DDRVST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVST2STG checks the symmetric eigenvalue problem drivers. +*> +*> DSTEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> DSTEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> DSTEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix +*> using the Relatively Robust Representation where it can. +*> +*> DSYEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> DSYEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> DSYEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix +*> using the Relatively Robust Representation where it can. +*> +*> DSPEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> DSPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> DSBEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> DSBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> DSYEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix using +*> a divide and conquer algorithm. +*> +*> DSPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage, using a divide and conquer algorithm. +*> +*> DSBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix, +*> using a divide and conquer algorithm. +*> +*> When DDRVST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 DOUBLE PRECISION array, dimension +*> +*> EVEIGS DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues as computed by DSTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 DOUBLE PRECISION array, dimension +*> +*> WA2 DOUBLE PRECISION array, dimension +*> +*> WA3 DOUBLE PRECISION array, dimension +*> +*> U DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by DSYTRD + DORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by DSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU DOUBLE PRECISION array, dimension (max(NN)) +*> The Householder factors computed by DSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by DSTEQR, +*> DPTEQR, and DSTEIN. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF, +*> or DORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) DSTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) DSTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) DSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) DSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) DSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) DSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) DSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) DSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) DSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) DSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) DSYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) DSYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEV_2STAGE('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) DSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) DSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) DSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) DSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) DSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) DSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) DSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) DSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) DSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) DSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEV_2STAGE('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) DSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) DSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) DSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) DSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) DSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVD_2STAGE('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) DSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) DSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) DSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) DSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVD_2STAGE('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) DSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) DSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) DSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) DSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) DSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) DSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) DSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) DSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) DSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','V', ... ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TEN = 10.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2, + $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, DLACPY, DLAFTS, DLASET, DLATMR, + $ DLATMS, DSBEV, DSBEVD, DSBEVX, DSPEV, DSPEVD, + $ DSPEVX, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSTT21, + $ DSTT22, DSYEV, DSYEVD, DSYEVR, DSYEVX, DSYT21, + $ DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, + $ DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, + $ DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, + $ DSYTRD_SB2ST, DSYT22, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 band symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call DSTEV and DSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'DSTEV' + CALL DSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 150 CONTINUE + CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'DSTEV' + CALL DSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + NTEST = 4 + DO 190 I = 1, N + EVEIGS( I ) = D3( I ) + D1( I ) = DBLE( A( I, I ) ) + 190 CONTINUE + DO 200 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 200 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + RESULT( 5 ) = ULPINV + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 4 and 5. +* + DO 210 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 210 CONTINUE + DO 220 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 220 CONTINUE + CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 4 ) ) +* + NTEST = 6 + DO 230 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 230 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 240 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 240 CONTINUE + RESULT( 6 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 250 CONTINUE +* + NTEST = 7 + DO 260 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 260 CONTINUE + DO 270 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 270 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + RESULT( 8 ) = ULPINV + GO TO 320 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 7 and 8. +* + DO 280 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 280 CONTINUE + DO 290 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 290 CONTINUE + CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 7 ) ) +* + NTEST = 9 + DO 300 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 300 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 320 + END IF + END IF +* +* Do test 9. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 310 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 310 CONTINUE + RESULT( 9 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 320 CONTINUE +* +* + NTEST = 10 + DO 330 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 330 CONTINUE + DO 340 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 340 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 10 ) = ULPINV + RESULT( 11 ) = ULPINV + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do tests 10 and 11. +* + DO 350 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 350 CONTINUE + DO 360 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 360 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 10 ) ) +* +* + NTEST = 12 + DO 370 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 370 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do test 12. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 380 CONTINUE +* + NTEST = 12 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 390 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 390 CONTINUE + DO 400 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 400 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF +* +* Do tests 13 and 14. +* + DO 410 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 410 CONTINUE + DO 420 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 420 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 13 ) ) +* + NTEST = 15 + DO 430 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 430 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* +* Do test 15. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 440 CONTINUE +* + NTEST = 16 + DO 450 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 450 CONTINUE + DO 460 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 460 CONTINUE + SRNAMT = 'DSTEVD' + CALL DSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVD(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + RESULT( 17 ) = ULPINV + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do tests 16 and 17. +* + DO 470 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 470 CONTINUE + DO 480 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 480 CONTINUE + CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 16 ) ) +* + NTEST = 18 + DO 490 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 490 CONTINUE + SRNAMT = 'DSTEVD' + CALL DSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVD(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 500 J = 1, N + TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ), + $ ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) ) + 500 CONTINUE + RESULT( 18 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 510 CONTINUE +* + NTEST = 19 + DO 520 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 520 CONTINUE + DO 530 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 530 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* DO tests 19 and 20. +* + DO 540 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 540 CONTINUE + DO 550 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 550 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 19 ) ) +* +* + NTEST = 21 + DO 560 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 560 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* Do test 21. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 570 CONTINUE +* + NTEST = 21 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 580 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 580 CONTINUE + DO 590 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 590 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF +* +* Do tests 22 and 23. +* + DO 600 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 600 CONTINUE + DO 610 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 610 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 22 ) ) +* + NTEST = 24 + DO 620 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 620 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* +* Do test 24. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 630 CONTINUE +* +* +* + ELSE +* + DO 640 I = 1, 24 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 24 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call DSYEV and DSYEVX. +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'DSYEV' + CALL DSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEV_2STAGE' + CALL DSYEV_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do tests 28 and 29 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do test 30 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 680 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do tests 31 and 32 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do test 33 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 690 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 34 and 35 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 36 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 700 CONTINUE +* +* 5) Call DSPEV and DSPEVX. +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 720 J = 1, N + DO 710 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 710 CONTINUE + 720 CONTINUE + ELSE + INDX = 1 + DO 740 J = 1, N + DO 730 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 730 CONTINUE + 740 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSPEV' + CALL DSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do tests 37 and 38 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 760 J = 1, N + DO 750 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 750 CONTINUE + 760 CONTINUE + ELSE + INDX = 1 + DO 780 J = 1, N + DO 770 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 770 CONTINUE + 780 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSPEV' + CALL DSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do test 39 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 790 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 790 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 800 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 820 J = 1, N + DO 810 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 810 CONTINUE + 820 CONTINUE + ELSE + INDX = 1 + DO 840 J = 1, N + DO 830 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 830 CONTINUE + 840 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do tests 40 and 41 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 860 J = 1, N + DO 850 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 850 CONTINUE + 860 CONTINUE + ELSE + INDX = 1 + DO 880 J = 1, N + DO 870 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 870 CONTINUE + 880 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do test 42 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 890 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 890 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 900 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 920 J = 1, N + DO 910 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 910 CONTINUE + 920 CONTINUE + ELSE + INDX = 1 + DO 940 J = 1, N + DO 930 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 930 CONTINUE + 940 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 990 + END IF + END IF +* +* Do tests 43 and 44 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 960 J = 1, N + DO 950 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 950 CONTINUE + 960 CONTINUE + ELSE + INDX = 1 + DO 980 J = 1, N + DO 970 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 970 CONTINUE + 980 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF +* +* Do test 45 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 990 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1080 + END IF + END IF +* +* Do tests 46 and 47 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1050 J = 1, N + DO 1040 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1040 CONTINUE + 1050 CONTINUE + ELSE + INDX = 1 + DO 1070 J = 1, N + DO 1060 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1060 CONTINUE + 1070 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF +* +* Do test 48 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1080 CONTINUE +* +* 6) Call DSBEV and DSBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1100 J = 1, N + DO 1090 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1090 CONTINUE + 1100 CONTINUE + ELSE + DO 1120 J = 1, N + DO 1110 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1110 CONTINUE + 1120 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEV' + CALL DSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 49 and 50 (or ... ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1140 J = 1, N + DO 1130 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1130 CONTINUE + 1140 CONTINUE + ELSE + DO 1160 J = 1, N + DO 1150 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1150 CONTINUE + 1160 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSBEV_2STAGE' + CALL DSBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 51 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1170 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1180 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 1200 J = 1, N + DO 1190 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1190 CONTINUE + 1200 CONTINUE + ELSE + DO 1220 J = 1, N + DO 1210 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1210 CONTINUE + 1220 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do tests 52 and 53 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1240 J = 1, N + DO 1230 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1230 CONTINUE + 1240 CONTINUE + ELSE + DO 1260 J = 1, N + DO 1250 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1250 CONTINUE + 1260 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do test 54 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1270 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) ) + 1270 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1280 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1300 J = 1, N + DO 1290 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1290 CONTINUE + 1300 CONTINUE + ELSE + DO 1320 J = 1, N + DO 1310 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1310 CONTINUE + 1320 CONTINUE + END IF +* + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do tests 55 and 56 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1340 J = 1, N + DO 1330 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1330 CONTINUE + 1340 CONTINUE + ELSE + DO 1360 J = 1, N + DO 1350 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1350 CONTINUE + 1360 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do test 57 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1390 J = 1, N + DO 1380 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1380 CONTINUE + 1390 CONTINUE + ELSE + DO 1410 J = 1, N + DO 1400 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1400 CONTINUE + 1410 CONTINUE + END IF +* + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1460 + END IF + END IF +* +* Do tests 58 and 59 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1430 J = 1, N + DO 1420 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1420 CONTINUE + 1430 CONTINUE + ELSE + DO 1450 J = 1, N + DO 1440 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1440 CONTINUE + 1450 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF +* +* Do test 60 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1460 CONTINUE +* +* 7) Call DSYEVD +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'DSYEVD' + CALL DSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do tests 61 and 62 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVD_2STAGE' + CALL DSYEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do test 63 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1470 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1470 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1480 CONTINUE +* +* 8) Call DSPEVD. +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1500 J = 1, N + DO 1490 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1490 CONTINUE + 1500 CONTINUE + ELSE + INDX = 1 + DO 1520 J = 1, N + DO 1510 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1510 CONTINUE + 1520 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSPEVD' + CALL DSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do tests 64 and 65 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1540 J = 1, N + DO 1530 I = 1, J +* + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1530 CONTINUE + 1540 CONTINUE + ELSE + INDX = 1 + DO 1560 J = 1, N + DO 1550 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1550 CONTINUE + 1560 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSPEVD' + CALL DSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do test 66 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1570 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1570 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + 1580 CONTINUE +* +* 9) Call DSBEVD. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1600 J = 1, N + DO 1590 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1590 CONTINUE + 1600 CONTINUE + ELSE + DO 1620 J = 1, N + DO 1610 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1610 CONTINUE + 1620 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEVD' + CALL DSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do tests 67 and 68 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1640 J = 1, N + DO 1630 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1630 CONTINUE + 1640 CONTINUE + ELSE + DO 1660 J = 1, N + DO 1650 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1650 CONTINUE + 1660 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSBEVD_2STAGE' + CALL DSBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do test 69 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1680 CONTINUE +* +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do tests 70 and 71 (or ... ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do test 72 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1690 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1690 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1700 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do tests 73 and 74 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do test 75 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1710 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 76 and 77 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 78 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL DLAFTS( 'DST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'DST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' DDRVST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of DDRVST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/ddrvsx.f b/lapack-netlib/TESTING/EIG/ddrvsx.f index 42b5b76e78..9006f1a929 100644 --- a/lapack-netlib/TESTING/EIG/ddrvsx.f +++ b/lapack-netlib/TESTING/EIG/ddrvsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NIUNIT, NOUNIT, A, LDA, H, HT, WR, WI, WRT, * WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK, * LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ WI( * ), WIT( * ), WITMP( * ), WORK( * ), * $ WR( * ), WRT( * ), WRTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -439,12 +439,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -454,10 +454,10 @@ SUBROUTINE DDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK, $ LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, @@ -933,7 +933,7 @@ SUBROUTINE DDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if WR, WI same no matter what else computed ', $ '(sort), 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', $ / ' 14 = 0 if RCONDE same no matter what else computed,', $ ' 1/ulp otherwise', / $ ' 15 = 0 if RCONDv same no matter what else computed,', diff --git a/lapack-netlib/TESTING/EIG/ddrvvx.f b/lapack-netlib/TESTING/EIG/ddrvvx.f index 14c5c74b9c..b088f6cc33 100644 --- a/lapack-netlib/TESTING/EIG/ddrvvx.f +++ b/lapack-netlib/TESTING/EIG/ddrvvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, * RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, * RESULT, WORK, NWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -29,7 +29,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), WI( * ), * $ WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -471,7 +471,7 @@ *> \verbatim *> INFO is INTEGER *> If 0, then successful exit. -*> If <0, then input paramter -INFO is incorrect. +*> If <0, then input parameter -INFO is incorrect. *> If >0, DLATMR, SLATMS, SLATME or DGET23 returned an error *> code, and INFO is its absolute value. *> @@ -505,12 +505,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * @@ -521,10 +521,10 @@ SUBROUTINE DDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, $ RESULT, WORK, NWORK, IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/derrbd.f b/lapack-netlib/TESTING/EIG/derrbd.f index da03504c16..934eb2066c 100644 --- a/lapack-netlib/TESTING/EIG/derrbd.f +++ b/lapack-netlib/TESTING/EIG/derrbd.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRBD( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DERRBD tests the error exits for DGEBD2, DGEBRD, DORGBR, DORMBR, +*> DERRBD tests the error exits for DGEBD2, DGEBRD, DORGBR, DORMBR, *> DBDSQR, DBDSDC and DBDSVDX. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERRBD( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ SUBROUTINE DERRBD( PATH, NUNIT ) * .. Local Arrays .. INTEGER IQ( NMAX, NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), D( NMAX ), E( NMAX ), - $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ), - $ TQ( NMAX ), U( NMAX, NMAX ), + $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ), + $ TQ( NMAX ), U( NMAX, NMAX ), $ V( NMAX, NMAX ), W( LW ) * .. * .. External Functions .. @@ -89,8 +89,8 @@ SUBROUTINE DERRBD( PATH, NUNIT ) EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL CHKXER, DBDSDC, DBDSQR, DBDSVDX, DGEBD2, DGEBRD, DORGBR, - $ DORMBR + EXTERNAL CHKXER, DBDSDC, DBDSQR, DBDSVDX, DGEBD2, + $ DGEBRD, DORGBR, DORMBR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -309,51 +309,51 @@ SUBROUTINE DERRBD( PATH, NUNIT ) * SRNAMT = 'DBDSVDX' INFOT = 1 - CALL DBDSVDX( 'X', 'N', 'A', 1, D, E, ZERO, ONE, 0, 0, + CALL DBDSVDX( 'X', 'N', 'A', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DBDSVDX( 'U', 'X', 'A', 1, D, E, ZERO, ONE, 0, 0, + CALL DBDSVDX( 'U', 'X', 'A', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL DBDSVDX( 'U', 'V', 'X', 1, D, E, ZERO, ONE, 0, 0, + CALL DBDSVDX( 'U', 'V', 'X', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DBDSVDX( 'U', 'V', 'A', -1, D, E, ZERO, ONE, 0, 0, + CALL DBDSVDX( 'U', 'V', 'A', -1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL DBDSVDX( 'U', 'V', 'V', 2, D, E, -ONE, ZERO, 0, 0, + CALL DBDSVDX( 'U', 'V', 'V', 2, D, E, -ONE, ZERO, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DBDSVDX( 'U', 'V', 'V', 2, D, E, ONE, ZERO, 0, 0, + CALL DBDSVDX( 'U', 'V', 'V', 2, D, E, ONE, ZERO, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL DBDSVDX( 'L', 'V', 'I', 2, D, E, ZERO, ZERO, 0, 2, + CALL DBDSVDX( 'L', 'V', 'I', 2, D, E, ZERO, ZERO, 0, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 5, 2, + CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 5, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 2, + CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 5, + CALL DBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 5, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 14 - CALL DBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, + CALL DBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, $ NS, S, Q, 0, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 14 - CALL DBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, + CALL DBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, $ NS, S, Q, 2, W, IW, INFO) CALL CHKXER( 'DBDSVDX', INFOT, NOUT, LERR, OK ) NT = NT + 12 diff --git a/lapack-netlib/TESTING/EIG/derrec.f b/lapack-netlib/TESTING/EIG/derrec.f index 428fb49f01..dc0828e0c9 100644 --- a/lapack-netlib/TESTING/EIG/derrec.f +++ b/lapack-netlib/TESTING/EIG/derrec.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERREC( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -23,7 +23,7 @@ *> *> DERREC tests the error exits for the routines for eigen- condition *> estimation for DOUBLE PRECISION matrices: -*> DTRSYL, STREXC, STRSNA and STRSEN. +*> DTRSYL, DTREXC, DTRSNA and DTRSEN. *> \endverbatim * * Arguments: @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERREC( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -152,8 +152,8 @@ SUBROUTINE DERREC( PATH, NUNIT ) INFOT = 1 CALL DTREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL DTREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO ) + INFOT = 2 + CALL DTREXC( 'N', -1, A, 1, B, 1, IFST, ILST, WORK, INFO ) CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK ) INFOT = 4 ILST = 2 diff --git a/lapack-netlib/TESTING/EIG/derred.f b/lapack-netlib/TESTING/EIG/derred.f index 4f778b1578..5bde7f67de 100644 --- a/lapack-netlib/TESTING/EIG/derred.f +++ b/lapack-netlib/TESTING/EIG/derred.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRED( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERRED( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -415,7 +415,7 @@ SUBROUTINE DERRED( PATH, NUNIT ) $ 2, 2, A, 2, S, U, 1, VT, 2, $ W, 1, IW, INFO) CALL CHKXER( 'DGEJSV', INFOT, NOUT, LERR, OK ) - INFOT = 14 + INFOT = 15 CALL DGEJSV( 'G', 'U', 'V', 'R', 'N', 'N', $ 2, 2, A, 2, S, U, 2, VT, 1, $ W, 1, IW, INFO) @@ -432,51 +432,51 @@ SUBROUTINE DERRED( PATH, NUNIT ) * SRNAMT = 'DGESVDX' INFOT = 1 - CALL DGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL DGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL DGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL DGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, + CALL DGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, + CALL DGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, + CALL DGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL DGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, + CALL DGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, + CALL DGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL DGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, + CALL DGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL DGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 0, 1, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL DGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL DGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 1, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL DGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, + CALL DGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) - INFOT = 16 - CALL DGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, + INFOT = 17 + CALL DGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'DGESVDX', INFOT, NOUT, LERR, OK ) NT = 12 diff --git a/lapack-netlib/TESTING/EIG/derrgg.f b/lapack-netlib/TESTING/EIG/derrgg.f index 917cf0480b..5671e94478 100644 --- a/lapack-netlib/TESTING/EIG/derrgg.f +++ b/lapack-netlib/TESTING/EIG/derrgg.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRGG( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -45,22 +45,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERRGG( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,7 +83,7 @@ SUBROUTINE DERRGG( PATH, NUNIT ) * .. * .. Local Arrays .. LOGICAL BW( NMAX ), SEL( NMAX ) - INTEGER IW( NMAX ) + INTEGER IW( NMAX ), IDUM(NMAX) DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ), $ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ), $ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ), @@ -305,47 +305,47 @@ SUBROUTINE DERRGG( PATH, NUNIT ) SRNAMT = 'DGGSVD3' INFOT = 1 CALL DGGSVD3( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGGSVD3( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGGSVD3( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGGSVD3( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DGGSVD3( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DGGSVD3( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGGSVD3( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DGGSVD3( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 16 CALL DGGSVD3( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 18 CALL DGGSVD3( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL DGGSVD3( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'DGGSVD3', INFOT, NOUT, LERR, OK ) NT = NT + 11 * @@ -547,56 +547,56 @@ SUBROUTINE DERRGG( PATH, NUNIT ) $ -1, 0, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, -1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, -1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, -1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ -1, W, LW, IW, INFO ) + $ -1, W, LW, IW, INFO ) CALL CHKXER( 'DORCSD', INFOT, NOUT, LERR, OK ) NT = NT + 8 * @@ -869,7 +869,7 @@ SUBROUTINE DERRGG( PATH, NUNIT ) $ 1, INFO ) CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK ) NT = NT + 10 -* +* * DGGEV3 * SRNAMT = 'DGGEV3 ' diff --git a/lapack-netlib/TESTING/EIG/derrhs.f b/lapack-netlib/TESTING/EIG/derrhs.f index b67082bf46..a8a2b865e8 100644 --- a/lapack-netlib/TESTING/EIG/derrhs.f +++ b/lapack-netlib/TESTING/EIG/derrhs.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRHS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERRHS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/derrst.f b/lapack-netlib/TESTING/EIG/derrst.f index 76439de6d0..a544cfbfb7 100644 --- a/lapack-netlib/TESTING/EIG/derrst.f +++ b/lapack-netlib/TESTING/EIG/derrst.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRST( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -25,6 +25,10 @@ *> DOPGTR, DOPMTR, DSTEQR, SSTERF, SSTEBZ, SSTEIN, DPTEQR, DSBTRD, *> DSYEV, SSYEVX, SSYEVD, DSBEV, SSBEVX, SSBEVD, *> DSPEV, SSPEVX, SSPEVD, DSTEV, SSTEVX, SSTEVD, and SSTEDC. +*> DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, +*> DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, +*> DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, +*> DSYTRD_SB2ST *> \endverbatim * * Arguments: @@ -45,22 +49,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DERRST( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -94,7 +98,11 @@ SUBROUTINE DERRST( PATH, NUNIT ) $ DSBEV, DSBEVD, DSBEVX, DSBTRD, DSPEV, DSPEVD, $ DSPEVX, DSPTRD, DSTEBZ, DSTEDC, DSTEIN, DSTEQR, $ DSTERF, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSYEV, - $ DSYEVD, DSYEVR, DSYEVX, DSYTRD + $ DSYEVD, DSYEVR, DSYEVX, DSYTRD, + $ DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, + $ DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, + $ DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, + $ DSYTRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -152,6 +160,103 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* DSYTRD_2STAGE +* + SRNAMT = 'DSYTRD_2STAGE' + INFOT = 1 + CALL DSYTRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYTRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* DSYTRD_SY2SB +* + SRNAMT = 'DSYTRD_SY2SB' + INFOT = 1 + CALL DSYTRD_SY2SB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SY2SB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SY2SB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SY2SB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SY2SB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRD_SY2SB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* DSYTRD_SB2ST +* + SRNAMT = 'DSYTRD_SB2ST' + INFOT = 1 + CALL DSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DORGTR * SRNAMT = 'DORGTR' @@ -536,6 +641,44 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* DSYEVD_2STAGE +* + SRNAMT = 'DSYEVD_2STAGE' + INFOT = 1 + CALL DSYEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL DSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO ) +* CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL DSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) +* CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DSYEVR * SRNAMT = 'DSYEVR' @@ -591,6 +734,74 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* DSYEVR_2STAGE +* + SRNAMT = 'DSYEVR_2STAGE' + N = 1 + INFOT = 1 + CALL DSYEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 0, IW( 2*N+1 ), 10*N, + $ INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 0, + $ INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 +* * DSYEV * SRNAMT = 'DSYEV ' @@ -611,6 +822,29 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* DSYEV_2STAGE +* + SRNAMT = 'DSYEV_2STAGE ' + INFOT = 1 + CALL DSYEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEV_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * DSYEVX * SRNAMT = 'DSYEVX' @@ -663,6 +897,75 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* DSYEVX_2STAGE +* + SRNAMT = 'DSYEVX_2STAGE' + INFOT = 1 + CALL DSYEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + INFOT = 4 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * DSPEVD * SRNAMT = 'DSPEVD' @@ -786,6 +1089,47 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* DSYTRD_SB2ST +* + SRNAMT = 'DSYTRD_SB2ST' + INFOT = 1 + CALL DSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DSBEVD * SRNAMT = 'DSBEVD' @@ -829,6 +1173,60 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* DSBEVD_2STAGE +* + SRNAMT = 'DSBEVD_2STAGE' + INFOT = 1 + CALL DSBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, + $ 4, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, +* $ 25, IW, 12, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 0, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVD_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, + $ 3, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 18, IW, 12, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 0, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 25, IW, 11, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 12 + NT = NT + 9 +* * DSBEV * SRNAMT = 'DSBEV ' @@ -852,6 +1250,35 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* DSBEV_2STAGE +* + SRNAMT = 'DSBEV_2STAGE ' + INFOT = 1 + CALL DSBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 0, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEV_2STAGE( 'N', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * DSBEVX * SRNAMT = 'DSBEVX' @@ -866,6 +1293,7 @@ SUBROUTINE DERRST( PATH, NUNIT ) INFOT = 3 CALL DSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0, $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0, $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) @@ -907,6 +1335,72 @@ SUBROUTINE DERRST( PATH, NUNIT ) $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 13 +* +* DSBEVX_2STAGE +* + SRNAMT = 'DSBEVX_2STAGE' + INFOT = 1 + CALL DSBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL DSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0D0, +* $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 2, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 2, 1, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 2, 1, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 1, 2, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 18 +* CALL DSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0D0, +* $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 15 + NT = NT + 13 END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/EIG/dget02.f b/lapack-netlib/TESTING/EIG/dget02.f index 199c5745bf..c992b524c5 100644 --- a/lapack-netlib/TESTING/EIG/dget02.f +++ b/lapack-netlib/TESTING/EIG/dget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -133,10 +133,10 @@ SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/EIG/dget10.f b/lapack-netlib/TESTING/EIG/dget10.f index 510949a8d4..e0b3577d6d 100644 --- a/lapack-netlib/TESTING/EIG/dget10.f +++ b/lapack-netlib/TESTING/EIG/dget10.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET10( M, N, A, LDA, B, LDB, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, M, N * DOUBLE PRECISION RESULT @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET10( M, N, A, LDA, B, LDB, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, M, N diff --git a/lapack-netlib/TESTING/EIG/dget22.f b/lapack-netlib/TESTING/EIG/dget22.f index 9175b417a8..ff7ba15aa5 100644 --- a/lapack-netlib/TESTING/EIG/dget22.f +++ b/lapack-netlib/TESTING/EIG/dget22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, * WI, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSA, TRANSE, TRANSW * INTEGER LDA, LDE, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ), * $ WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -167,10 +167,10 @@ SUBROUTINE DGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, $ WI, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSA, TRANSE, TRANSW diff --git a/lapack-netlib/TESTING/EIG/dget23.f b/lapack-netlib/TESTING/EIG/dget23.f index 9a641afddf..8c801aeeed 100644 --- a/lapack-netlib/TESTING/EIG/dget23.f +++ b/lapack-netlib/TESTING/EIG/dget23.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * CHARACTER BALANC @@ -30,7 +30,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), WI( * ), * $ WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -362,12 +362,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -378,10 +378,10 @@ SUBROUTINE DGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/dget24.f b/lapack-netlib/TESTING/EIG/dget24.f index ce1c5b20a8..a3c01756cf 100644 --- a/lapack-netlib/TESTING/EIG/dget24.f +++ b/lapack-netlib/TESTING/EIG/dget24.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS, * LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT, * RESULT, WORK, LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT @@ -26,7 +26,7 @@ * $ WI( * ), WIT( * ), WITMP( * ), WORK( * ), * $ WR( * ), WRT( * ), WRTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -328,12 +328,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -343,10 +343,10 @@ SUBROUTINE DGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, $ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT, $ RESULT, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/dget31.f b/lapack-netlib/TESTING/EIG/dget31.f index fe2aefede0..267ed7798e 100644 --- a/lapack-netlib/TESTING/EIG/dget31.f +++ b/lapack-netlib/TESTING/EIG/dget31.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET31( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX * DOUBLE PRECISION RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET31( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX diff --git a/lapack-netlib/TESTING/EIG/dget32.f b/lapack-netlib/TESTING/EIG/dget32.f index b6db206bff..59fccf068b 100644 --- a/lapack-netlib/TESTING/EIG/dget32.f +++ b/lapack-netlib/TESTING/EIG/dget32.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/dget33.f b/lapack-netlib/TESTING/EIG/dget33.f index a7c8f46bee..eb6b4516d9 100644 --- a/lapack-netlib/TESTING/EIG/dget33.f +++ b/lapack-netlib/TESTING/EIG/dget33.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET33( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -64,22 +64,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET33( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/dget34.f b/lapack-netlib/TESTING/EIG/dget34.f index 8bf1b8b622..d3939f7659 100644 --- a/lapack-netlib/TESTING/EIG/dget34.f +++ b/lapack-netlib/TESTING/EIG/dget34.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX * DOUBLE PRECISION RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX diff --git a/lapack-netlib/TESTING/EIG/dget35.f b/lapack-netlib/TESTING/EIG/dget35.f index b0aa091187..c5d4dece5b 100644 --- a/lapack-netlib/TESTING/EIG/dget35.f +++ b/lapack-netlib/TESTING/EIG/dget35.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET35( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET35( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/dget36.f b/lapack-netlib/TESTING/EIG/dget36.f index 4bba768df2..83bed283a2 100644 --- a/lapack-netlib/TESTING/EIG/dget36.f +++ b/lapack-netlib/TESTING/EIG/dget36.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET36( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN * DOUBLE PRECISION RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -76,22 +76,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET36( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN diff --git a/lapack-netlib/TESTING/EIG/dget37.f b/lapack-netlib/TESTING/EIG/dget37.f index 5bdc2db554..2a4132c6ae 100644 --- a/lapack-netlib/TESTING/EIG/dget37.f +++ b/lapack-netlib/TESTING/EIG/dget37.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET37( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * DOUBLE PRECISION RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET37( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/dget38.f b/lapack-netlib/TESTING/EIG/dget38.f index f8cd809365..c677e3175c 100644 --- a/lapack-netlib/TESTING/EIG/dget38.f +++ b/lapack-netlib/TESTING/EIG/dget38.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET38( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * DOUBLE PRECISION RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET38( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/dget39.f b/lapack-netlib/TESTING/EIG/dget39.f index 2d726ddf35..1d0ec1f452 100644 --- a/lapack-netlib/TESTING/EIG/dget39.f +++ b/lapack-netlib/TESTING/EIG/dget39.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET39( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET39( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/dget51.f b/lapack-netlib/TESTING/EIG/dget51.f index 5776bd7dd8..530da5b500 100644 --- a/lapack-netlib/TESTING/EIG/dget51.f +++ b/lapack-netlib/TESTING/EIG/dget51.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER ITYPE, LDA, LDB, LDU, LDV, N * DOUBLE PRECISION RESULT @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -149,10 +149,10 @@ SUBROUTINE DGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ITYPE, LDA, LDB, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/dget52.f b/lapack-netlib/TESTING/EIG/dget52.f index 763071324f..e236fccb1e 100644 --- a/lapack-netlib/TESTING/EIG/dget52.f +++ b/lapack-netlib/TESTING/EIG/dget52.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, * ALPHAI, BETA, WORK, RESULT ) -* +* * .. Scalar Arguments .. * LOGICAL LEFT * INTEGER LDA, LDB, LDE, N @@ -20,7 +20,7 @@ * $ B( LDB, * ), BETA( * ), E( LDE, * ), * $ RESULT( 2 ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -186,12 +186,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -199,10 +199,10 @@ SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, $ ALPHAI, BETA, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LEFT diff --git a/lapack-netlib/TESTING/EIG/dget53.f b/lapack-netlib/TESTING/EIG/dget53.f index 0cc1c8cd64..9cacb3540f 100644 --- a/lapack-netlib/TESTING/EIG/dget53.f +++ b/lapack-netlib/TESTING/EIG/dget53.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB * DOUBLE PRECISION RESULT, SCALE, WI, WR @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB diff --git a/lapack-netlib/TESTING/EIG/dget54.f b/lapack-netlib/TESTING/EIG/dget54.f index 480635aeae..172daabe98 100644 --- a/lapack-netlib/TESTING/EIG/dget54.f +++ b/lapack-netlib/TESTING/EIG/dget54.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, * LDV, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N * DOUBLE PRECISION RESULT @@ -20,7 +20,7 @@ * $ T( LDT, * ), U( LDU, * ), V( LDV, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -156,10 +156,10 @@ SUBROUTINE DGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, $ LDV, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/dglmts.f b/lapack-netlib/TESTING/EIG/dglmts.f index accdbf7e77..1f40fe4990 100644 --- a/lapack-netlib/TESTING/EIG/dglmts.f +++ b/lapack-netlib/TESTING/EIG/dglmts.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U, * WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * DOUBLE PRECISION RESULT * .. * .. Array Arguments .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -146,10 +146,10 @@ SUBROUTINE DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U, $ WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/dgqrts.f b/lapack-netlib/TESTING/EIG/dgqrts.f index 836c856798..34f0bab561 100644 --- a/lapack-netlib/TESTING/EIG/dgqrts.f +++ b/lapack-netlib/TESTING/EIG/dgqrts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. @@ -21,7 +21,7 @@ * $ T( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( LWORK ), Z( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -176,10 +176,10 @@ SUBROUTINE DGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/dgrqts.f b/lapack-netlib/TESTING/EIG/dgrqts.f index 9f06241c54..4e38b0a746 100644 --- a/lapack-netlib/TESTING/EIG/dgrqts.f +++ b/lapack-netlib/TESTING/EIG/dgrqts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. @@ -21,7 +21,7 @@ * $ T( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( LWORK ), Z( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -176,10 +176,10 @@ SUBROUTINE DGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/dgsvts3.f b/lapack-netlib/TESTING/EIG/dgsvts3.f index d7ceeb65e3..131aa81bc3 100644 --- a/lapack-netlib/TESTING/EIG/dgsvts3.f +++ b/lapack-netlib/TESTING/EIG/dgsvts3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, * LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P * .. @@ -23,7 +23,7 @@ * $ RWORK( * ), U( LDU, * ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -196,10 +196,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -210,7 +210,7 @@ SUBROUTINE DGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * August 2015 diff --git a/lapack-netlib/TESTING/EIG/dhst01.f b/lapack-netlib/TESTING/EIG/dhst01.f index af5b4ea147..9e7ae0201d 100644 --- a/lapack-netlib/TESTING/EIG/dhst01.f +++ b/lapack-netlib/TESTING/EIG/dhst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, * LWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), H( LDH, * ), Q( LDQ, * ), * $ RESULT( 2 ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -134,10 +134,10 @@ SUBROUTINE DHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, $ LWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N diff --git a/lapack-netlib/TESTING/EIG/dlafts.f b/lapack-netlib/TESTING/EIG/dlafts.f index 6c35f9881a..634c52c1bb 100644 --- a/lapack-netlib/TESTING/EIG/dlafts.f +++ b/lapack-netlib/TESTING/EIG/dlafts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, * THRESH, IOUNIT, IE ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER IE, IMAT, IOUNIT, M, N, NTESTS @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION RESULT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -99,10 +99,10 @@ SUBROUTINE DLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, $ THRESH, IOUNIT, IE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/dlahd2.f b/lapack-netlib/TESTING/EIG/dlahd2.f index b55236258d..efb32c9170 100644 --- a/lapack-netlib/TESTING/EIG/dlahd2.f +++ b/lapack-netlib/TESTING/EIG/dlahd2.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAHD2( IOUNIT, PATH ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER IOUNIT * .. -* +* * *> \par Purpose: * ============= @@ -53,22 +53,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DLAHD2( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/dlarfy.f b/lapack-netlib/TESTING/EIG/dlarfy.f index 717af4b10c..a0b0ebb31b 100644 --- a/lapack-netlib/TESTING/EIG/dlarfy.f +++ b/lapack-netlib/TESTING/EIG/dlarfy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCV, LDC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dlarhs.f b/lapack-netlib/TESTING/EIG/dlarhs.f index 4b0441e569..435f7d6a28 100644 --- a/lapack-netlib/TESTING/EIG/dlarhs.f +++ b/lapack-netlib/TESTING/EIG/dlarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -204,10 +204,10 @@ SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/EIG/dlasum.f b/lapack-netlib/TESTING/EIG/dlasum.f index 27187d0235..555c405a17 100644 --- a/lapack-netlib/TESTING/EIG/dlasum.f +++ b/lapack-netlib/TESTING/EIG/dlasum.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLASUM( TYPE, IOUNIT, IE, NRUN ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER IE, IOUNIT, NRUN * .. -* +* * *> \par Purpose: * ============= @@ -31,22 +31,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DLASUM( TYPE, IOUNIT, IE, NRUN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/dlatb9.f b/lapack-netlib/TESTING/EIG/dlatb9.f index 85c08be05e..42ce5a07a4 100644 --- a/lapack-netlib/TESTING/EIG/dlatb9.f +++ b/lapack-netlib/TESTING/EIG/dlatb9.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,14 +11,14 @@ * SUBROUTINE DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB, * ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB, * DISTA, DISTB ) -* +* * .. Scalar Arguments .. * CHARACTER DISTA, DISTB, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KLA, KLB, KUA, KUB, M, MODEA, MODEB, N, P * DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB * .. -* +* * *> \par Purpose: * ============= @@ -156,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -170,10 +170,10 @@ SUBROUTINE DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB, $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB, $ DISTA, DISTB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DISTA, DISTB, TYPE diff --git a/lapack-netlib/TESTING/EIG/dlatm4.f b/lapack-netlib/TESTING/EIG/dlatm4.f index bf661f9647..04de323d51 100644 --- a/lapack-netlib/TESTING/EIG/dlatm4.f +++ b/lapack-netlib/TESTING/EIG/dlatm4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND, * TRIANG, IDIST, ISEED, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2 * DOUBLE PRECISION AMAGN, RCOND, TRIANG @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -175,10 +175,10 @@ SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND, $ TRIANG, IDIST, ISEED, A, LDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2 diff --git a/lapack-netlib/TESTING/EIG/dlctes.f b/lapack-netlib/TESTING/EIG/dlctes.f index 71b70919d0..082c4514ea 100644 --- a/lapack-netlib/TESTING/EIG/dlctes.f +++ b/lapack-netlib/TESTING/EIG/dlctes.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION DLCTES( ZR, ZI, D ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION D, ZI, ZR * .. -* +* * *> \par Purpose: * ============= @@ -26,7 +26,7 @@ *> .FALSE.. *> *> It is used by the test routine DDRGES to test whether the driver -*> routine DGGES succesfully sorts eigenvalues. +*> routine DGGES successfully sorts eigenvalues. *> \endverbatim * * Arguments: @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== LOGICAL FUNCTION DLCTES( ZR, ZI, D ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. DOUBLE PRECISION D, ZI, ZR diff --git a/lapack-netlib/TESTING/EIG/dlctsx.f b/lapack-netlib/TESTING/EIG/dlctsx.f index 1521ca14ad..f852b60a73 100644 --- a/lapack-netlib/TESTING/EIG/dlctsx.f +++ b/lapack-netlib/TESTING/EIG/dlctsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION DLCTSX( AR, AI, BETA ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION AI, AR, BETA * .. -* +* * *> \par Purpose: * ============= @@ -53,22 +53,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== LOGICAL FUNCTION DLCTSX( AR, AI, BETA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION AI, AR, BETA diff --git a/lapack-netlib/TESTING/EIG/dlsets.f b/lapack-netlib/TESTING/EIG/dlsets.f index 6ec0e69b9f..f2303614cd 100644 --- a/lapack-netlib/TESTING/EIG/dlsets.f +++ b/lapack-netlib/TESTING/EIG/dlsets.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF, * X, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. -* +* * *> \par Purpose: * ============= @@ -138,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -151,10 +151,10 @@ SUBROUTINE DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF, $ X, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/dort01.f b/lapack-netlib/TESTING/EIG/dort01.f index cab1c99565..32694bd072 100644 --- a/lapack-netlib/TESTING/EIG/dort01.f +++ b/lapack-netlib/TESTING/EIG/dort01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER ROWCOL * INTEGER LDU, LWORK, M, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER ROWCOL diff --git a/lapack-netlib/TESTING/EIG/dort03.f b/lapack-netlib/TESTING/EIG/dort03.f index eb8cf3d5fb..46f34574f2 100644 --- a/lapack-netlib/TESTING/EIG/dort03.f +++ b/lapack-netlib/TESTING/EIG/dort03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) RC * INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -156,10 +156,10 @@ SUBROUTINE DORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) RC diff --git a/lapack-netlib/TESTING/EIG/dsbt21.f b/lapack-netlib/TESTING/EIG/dsbt21.f index 03f2dd3595..e7db231a97 100644 --- a/lapack-netlib/TESTING/EIG/dsbt21.f +++ b/lapack-netlib/TESTING/EIG/dsbt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KA, KS, LDA, LDU, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -146,10 +146,10 @@ SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dsgt01.f b/lapack-netlib/TESTING/EIG/dsgt01.f index c63c0eeb52..bb3e42b4c2 100644 --- a/lapack-netlib/TESTING/EIG/dsgt01.f +++ b/lapack-netlib/TESTING/EIG/dsgt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, * WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, LDA, LDB, LDZ, M, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -146,10 +146,10 @@ SUBROUTINE DSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, $ WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dslect.f b/lapack-netlib/TESTING/EIG/dslect.f index 3978024c90..af58467993 100644 --- a/lapack-netlib/TESTING/EIG/dslect.f +++ b/lapack-netlib/TESTING/EIG/dslect.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION DSLECT( ZR, ZI ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ZI, ZR * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,8 @@ *> *> DSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be *> selected, and otherwise it returns .FALSE. -*> It is used by DCHK41 to test if DGEES succesfully sorts eigenvalues, -*> and by DCHK43 to test if DGEESX succesfully sorts eigenvalues. +*> It is used by DCHK41 to test if DGEES successfully sorts eigenvalues, +*> and by DCHK43 to test if DGEESX successfully sorts eigenvalues. *> *> The common block /SSLCT/ controls how eigenvalues are selected. *> If SELOPT = 0, then DSLECT return .TRUE. when ZR is less than zero, @@ -50,22 +50,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_eig * * ===================================================================== LOGICAL FUNCTION DSLECT( ZR, ZI ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ZI, ZR diff --git a/lapack-netlib/TESTING/EIG/dspt21.f b/lapack-netlib/TESTING/EIG/dspt21.f index 8c6060ed6e..9f87959fe9 100644 --- a/lapack-netlib/TESTING/EIG/dspt21.f +++ b/lapack-netlib/TESTING/EIG/dspt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, * TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDU, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ), * $ U( LDU, * ), VP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -206,12 +206,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -219,10 +219,10 @@ SUBROUTINE DSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, $ TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dstech.f b/lapack-netlib/TESTING/EIG/dstech.f index 4de8e42a17..23ae8e575b 100644 --- a/lapack-netlib/TESTING/EIG/dstech.f +++ b/lapack-netlib/TESTING/EIG/dstech.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSTECH( N, A, B, EIG, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION TOL @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( * ), B( * ), EIG( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DSTECH( N, A, B, EIG, TOL, WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/TESTING/EIG/dstect.f b/lapack-netlib/TESTING/EIG/dstect.f index 016e280d96..1a8aef33b1 100644 --- a/lapack-netlib/TESTING/EIG/dstect.f +++ b/lapack-netlib/TESTING/EIG/dstect.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSTECT( N, A, B, SHIFT, NUM ) -* +* * .. Scalar Arguments .. * INTEGER N, NUM * DOUBLE PRECISION SHIFT @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( * ), B( * ) * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DSTECT( N, A, B, SHIFT, NUM ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NUM diff --git a/lapack-netlib/TESTING/EIG/dstt21.f b/lapack-netlib/TESTING/EIG/dstt21.f index c0df3a1689..9d289ffc70 100644 --- a/lapack-netlib/TESTING/EIG/dstt21.f +++ b/lapack-netlib/TESTING/EIG/dstt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ), * $ SE( * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -127,10 +127,10 @@ SUBROUTINE DSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, N diff --git a/lapack-netlib/TESTING/EIG/dstt22.f b/lapack-netlib/TESTING/EIG/dstt22.f index 07bfa161a2..5cdc056c96 100644 --- a/lapack-netlib/TESTING/EIG/dstt22.f +++ b/lapack-netlib/TESTING/EIG/dstt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, * LDWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, LDWORK, M, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ), * $ SE( * ), U( LDU, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -139,10 +139,10 @@ SUBROUTINE DSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ LDWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, LDWORK, M, N diff --git a/lapack-netlib/TESTING/EIG/dsvdch.f b/lapack-netlib/TESTING/EIG/dsvdch.f index 758225b333..9f3129dd28 100644 --- a/lapack-netlib/TESTING/EIG/dsvdch.f +++ b/lapack-netlib/TESTING/EIG/dsvdch.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSVDCH( N, S, E, SVD, TOL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION TOL @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION E( * ), S( * ), SVD( * ) * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DSVDCH( N, S, E, SVD, TOL, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/TESTING/EIG/dsvdct.f b/lapack-netlib/TESTING/EIG/dsvdct.f index 72d4b63d2c..ddb1ebf681 100644 --- a/lapack-netlib/TESTING/EIG/dsvdct.f +++ b/lapack-netlib/TESTING/EIG/dsvdct.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSVDCT( N, S, E, SHIFT, NUM ) -* +* * .. Scalar Arguments .. * INTEGER N, NUM * DOUBLE PRECISION SHIFT @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION E( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DSVDCT( N, S, E, SHIFT, NUM ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NUM diff --git a/lapack-netlib/TESTING/EIG/dsxt1.f b/lapack-netlib/TESTING/EIG/dsxt1.f index 09b2037d73..6d482c2fea 100644 --- a/lapack-netlib/TESTING/EIG/dsxt1.f +++ b/lapack-netlib/TESTING/EIG/dsxt1.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DSXT1( IJOB, D1, N1, D2, N2, ABSTOL, * ULP, UNFL ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, N1, N2 * DOUBLE PRECISION ABSTOL, ULP, UNFL @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D1( * ), D2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -106,10 +106,10 @@ DOUBLE PRECISION FUNCTION DSXT1( IJOB, D1, N1, D2, N2, ABSTOL, $ ULP, UNFL ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IJOB, N1, N2 diff --git a/lapack-netlib/TESTING/EIG/dsyt21.f b/lapack-netlib/TESTING/EIG/dsyt21.f index 74f084f989..0da3e58821 100644 --- a/lapack-netlib/TESTING/EIG/dsyt21.f +++ b/lapack-netlib/TESTING/EIG/dsyt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, * LDV, TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -205,10 +205,10 @@ SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, $ LDV, TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/dsyt22.f b/lapack-netlib/TESTING/EIG/dsyt22.f index 275b702eee..479b3ba5e5 100644 --- a/lapack-netlib/TESTING/EIG/dsyt22.f +++ b/lapack-netlib/TESTING/EIG/dsyt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, * V, LDV, TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -155,10 +155,10 @@ SUBROUTINE DSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, $ V, LDV, TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/ilaenv.f b/lapack-netlib/TESTING/EIG/ilaenv.f index 135ac099bf..8b741a283f 100644 --- a/lapack-netlib/TESTING/EIG/ilaenv.f +++ b/lapack-netlib/TESTING/EIG/ilaenv.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * N4 ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. -* +* * *> \par Purpose: * ============= @@ -117,14 +117,14 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * -*> \ingroup aux_eig +*> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== @@ -153,10 +153,10 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -169,8 +169,8 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, INTRINSIC INT, MIN, REAL * .. * .. External Functions .. - INTEGER IEEECK - EXTERNAL IEEECK + INTEGER IEEECK, IPARAM2STAGE + EXTERNAL IEEECK, IPARAM2STAGE * .. * .. Arrays in Common .. INTEGER IPARMS( 100 ) @@ -223,11 +223,21 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * ELSE IF(( ISPEC.GE.12 ) .AND. (ISPEC.LE.16)) THEN * -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. * ILAENV = IPARMS( ISPEC ) * WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* + ELSE IF(( ISPEC.GE.17 ) .AND. (ISPEC.LE.21)) THEN +* +* 17 <= ISPEC <= 21: 2stage eigenvalues SVD routines. +* + IF( ISPEC.EQ.17 ) THEN + ILAENV = IPARMS( 1 ) + ELSE + ILAENV = IPARAM2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + ENDIF * ELSE * diff --git a/lapack-netlib/TESTING/EIG/sbdt01.f b/lapack-netlib/TESTING/EIG/sbdt01.f index fa9ad51ffa..7523e1b5bc 100644 --- a/lapack-netlib/TESTING/EIG/sbdt01.f +++ b/lapack-netlib/TESTING/EIG/sbdt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KD, LDA, LDPT, LDQ, M, N * REAL RESID @@ -19,7 +19,7 @@ * REAL A( LDA, * ), D( * ), E( * ), PT( LDPT, * ), * $ Q( LDQ, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -140,10 +140,10 @@ SUBROUTINE SBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KD, LDA, LDPT, LDQ, M, N diff --git a/lapack-netlib/TESTING/EIG/sbdt02.f b/lapack-netlib/TESTING/EIG/sbdt02.f index 72900fe314..b31e64935d 100644 --- a/lapack-netlib/TESTING/EIG/sbdt02.f +++ b/lapack-netlib/TESTING/EIG/sbdt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDC, LDU, M, N * REAL RESID @@ -18,7 +18,7 @@ * REAL B( LDB, * ), C( LDC, * ), U( LDU, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDC, LDU, M, N diff --git a/lapack-netlib/TESTING/EIG/sbdt03.f b/lapack-netlib/TESTING/EIG/sbdt03.f index 4e7f349449..73e58cea77 100644 --- a/lapack-netlib/TESTING/EIG/sbdt03.f +++ b/lapack-netlib/TESTING/EIG/sbdt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDU, LDVT, N @@ -20,7 +20,7 @@ * REAL D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -135,10 +135,10 @@ SUBROUTINE SBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/sbdt04.f b/lapack-netlib/TESTING/EIG/sbdt04.f index 59d113415f..c419876354 100644 --- a/lapack-netlib/TESTING/EIG/sbdt04.f +++ b/lapack-netlib/TESTING/EIG/sbdt04.f @@ -1,14 +1,15 @@ +*> \brief \b SBDT04 * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE SBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, +* SUBROUTINE SBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDU, LDVT, N, NS @@ -18,7 +19,7 @@ * REAL D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -68,14 +69,14 @@ *> \param[in] S *> \verbatim *> S is REAL array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -117,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * @@ -130,10 +131,10 @@ SUBROUTINE SBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/sbdt05.f b/lapack-netlib/TESTING/EIG/sbdt05.f index 53cae36ba0..972ff952f4 100644 --- a/lapack-netlib/TESTING/EIG/sbdt05.f +++ b/lapack-netlib/TESTING/EIG/sbdt05.f @@ -1,14 +1,14 @@ * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE SBDT05( M, N, A, LDA, S, NS, U, LDU, -* VT, LDVT, WORK, RESID ) -* +* SUBROUTINE SBDT05( M, N, A, LDA, S, NS, U, LDU, +* VT, LDVT, WORK, RESID ) +* * .. Scalar Arguments .. * INTEGER LDA, LDU, LDVT, N, NS * REAL RESID @@ -17,7 +17,7 @@ * REAL D( * ), E( * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,14 +62,14 @@ *> \param[in] S *> \verbatim *> S is REAL array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -111,26 +111,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== - SUBROUTINE SBDT05( M, N, A, LDA, S, NS, U, LDU, + SUBROUTINE SBDT05( M, N, A, LDA, S, NS, U, LDU, $ VT, LDVT, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. - CHARACTER UPLO INTEGER LDA, LDU, LDVT, M, N, NS REAL RESID * .. diff --git a/lapack-netlib/TESTING/EIG/schkbb.f b/lapack-netlib/TESTING/EIG/schkbb.f index 749f60d260..55f18c0afe 100644 --- a/lapack-netlib/TESTING/EIG/schkbb.f +++ b/lapack-netlib/TESTING/EIG/schkbb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB, * BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK, * LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, * $ NRHS, NSIZES, NTYPES, NWDTHS @@ -25,7 +25,7 @@ * $ C( LDC, * ), CC( LDC, * ), P( LDP, * ), * $ Q( LDQ, * ), RESULT( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -340,12 +340,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -358,7 +358,7 @@ SUBROUTINE SCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE, * -- LAPACK test routine (input) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/schkbd.f b/lapack-netlib/TESTING/EIG/schkbd.f index 3419c7df0d..4da7798fb1 100644 --- a/lapack-netlib/TESTING/EIG/schkbd.f +++ b/lapack-netlib/TESTING/EIG/schkbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX, * Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, * IWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * $ VT( LDPT, * ), WORK( * ), X( LDX, * ), * $ Y( LDX, * ), Z( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -64,7 +64,7 @@ *> singular vectors are not computed. *> *> SBDSVDX computes the singular value decomposition of the bidiagonal -*> matrix B as B = U S V' using bisection and inverse iteration. It is +*> matrix B as B = U S V' using bisection and inverse iteration. It is *> called six times to compute *> 1) B = U S1 V', RANGE='A', where S1 is the diagonal matrix of singular *> values and the columns of the matrices U and V are the left @@ -147,43 +147,43 @@ *> (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. *> Test SBDSVDX on bidiagonal matrix B -*> +*> *> (20) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' -*> +*> *> (21) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (22) | I - VT VT' | / ( min(M,N) ulp ) -*> +*> *> (23) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (24) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> (25) | S1 - U' B VT' | / ( |S| n ulp ) SBDSVDX('V', 'I') -*> +*> *> (26) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (27) | I - VT VT' | / ( min(M,N) ulp ) *> *> (28) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (29) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> (30) | S1 - U' B VT' | / ( |S1| n ulp ) SBDSVDX('V', 'V') -*> +*> *> (31) | I - U' U | / ( min(M,N) ulp ) -*> +*> *> (32) | I - VT VT' | / ( min(M,N) ulp ) *> *> (33) S1 contains min(M,N) nonnegative values in decreasing order. *> (Return 0 if true, 1/ULP if false.) -*> +*> *> (34) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without *> computing U and V. -*> +*> *> The possible matrix types are *> *> (1) The zero matrix. @@ -478,12 +478,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * @@ -493,10 +493,10 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, $ IWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, @@ -525,18 +525,18 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, LOGICAL BADMM, BADNN, BIDIAG CHARACTER UPLO CHARACTER*3 PATH - INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, IWBD, + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, IWBD, $ IWBE, IWBS, IWBZ, IWWORK, J, JCOL, JSIZE, - $ JTYPE, LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, - $ MNMIN2, MQ, MTYPES, N, NFAIL, NMAX, + $ JTYPE, LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, + $ MNMIN2, MQ, MTYPES, N, NFAIL, NMAX, $ NS1, NS2, NTEST - REAL ABSTOL, AMNINV, ANORM, COND, OVFL, RTOVFL, - $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, - $ UNFL, VL, VU + REAL ABSTOL, AMNINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL, + $ VL, VU * .. * .. Local Arrays .. - INTEGER IDUM( 1 ), IOLDSD( 4 ), ISEED2( 4 ), - $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + INTEGER IDUM( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), $ KTYPE( MAXTYP ) REAL DUM( 1 ), DUMMA( 1 ), RESULT( 40 ) * .. @@ -545,10 +545,10 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, EXTERNAL SLAMCH, SLARND, SSXT1 * .. * .. External Subroutines .. - EXTERNAL ALASUM, SBDSDC, SBDSQR, SBDSVDX, SBDT01, SBDT02, - $ SBDT03, SBDT04, SCOPY, SGEBRD, SGEMM, SLABAD, - $ SLACPY, SLAHD2, SLASET, SLATMR, SLATMS, - $ SORGBR, SORT01, XERBLA + EXTERNAL ALASUM, SBDSDC, SBDSQR, SBDSVDX, SBDT01, + $ SBDT02, SBDT03, SBDT04, SCOPY, SGEBRD, + $ SGEMM, SLABAD, SLACPY, SLAHD2, SLASET, + $ SLATMR, SLATMS, SORGBR, SORT01, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT @@ -563,9 +563,9 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / - DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / - DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / + DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, $ 0, 0, 0 / * .. * .. Executable Statements .. @@ -1143,7 +1143,7 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, IWBD = IWBS + MNMIN IWBE = IWBD + MNMIN IWBZ = IWBE + MNMIN - IWWORK = IWBZ + MNMIN*(MNMIN*2+1) + IWWORK = IWBZ + 2*MNMIN*(MNMIN+1) MNMIN2 = MAX( 1,MNMIN*2 ) * CALL SCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) @@ -1151,10 +1151,10 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ CALL SCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL SBDSVDX( UPLO, 'V', 'A', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO) -* +* * Check error code from SBDSVDX. * IF( IINFO.NE.0 ) THEN @@ -1190,17 +1190,17 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL SCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) - $ CALL SCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) -* + $ CALL SCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) +* CALL SBDSVDX( UPLO, 'N', 'A', MNMIN, WORK( IWBD ), $ WORK( IWBE ), ZERO, ZERO, 0, 0, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from SBDSVDX. * IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9998 )'SBDSVDX(values,A)', IINFO, + WRITE( NOUT, FMT = 9998 )'SBDSVDX(values,A)', IINFO, $ M, N, JTYPE, IOLDSD INFO = ABS( IINFO ) IF( IINFO.LT.0 ) THEN @@ -1224,11 +1224,11 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL SBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, $ LDPT, WORK( IWBS+MNMIN ), RESULT( 20 ) ) - CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 21 ) ) - CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 22) ) * RESULT( 23 ) = ZERO @@ -1272,14 +1272,14 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, IL = ITEMP END IF END IF -* +* CALL SCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) $ CALL SCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL SBDSVDX( UPLO, 'V', 'I', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO) * * Check error code from SBDSVDX. @@ -1313,7 +1313,7 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL SBDSVDX( UPLO, 'N', 'I', MNMIN, WORK( IWBD ), $ WORK( IWBE ), ZERO, ZERO, IL, IU, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from SBDSVDX. @@ -1337,13 +1337,13 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * non-increasing order and are non-negative * 29: Compare SBDSVDX with and without singular vectors * - CALL SBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, - $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), + CALL SBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, + $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), $ RESULT( 25 ) ) - CALL SORT01( 'Columns', MNMIN, NS1, U, LDPT, - $ WORK( IWBS+MNMIN ), LWORK-MNMIN, + CALL SORT01( 'Columns', MNMIN, NS1, U, LDPT, + $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 26 ) ) - CALL SORT01( 'Rows', NS1, MNMIN, VT, LDPT, + CALL SORT01( 'Rows', NS1, MNMIN, VT, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 27 ) ) * @@ -1368,8 +1368,8 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, 230 CONTINUE RESULT( 29 ) = TEMP2 * -* Use SBDSVDX with RANGE='V': determine the values VL and VU -* of the IL-th and IU-th singular values and ask for all +* Use SBDSVDX with RANGE='V': determine the values VL and VU +* of the IL-th and IU-th singular values and ask for all * singular values in this range. * CALL SCOPY( MNMIN, WORK( IWBS ), 1, S1, 1 ) @@ -1395,21 +1395,21 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, ELSE VL = ZERO VU = ONE - END IF -* + END IF +* CALL SCOPY( MNMIN, BD, 1, WORK( IWBD ), 1 ) IF( MNMIN.GT.0 ) $ CALL SCOPY( MNMIN-1, BE, 1, WORK( IWBE ), 1 ) * CALL SBDSVDX( UPLO, 'V', 'V', MNMIN, WORK( IWBD ), - $ WORK( IWBE ), VL, VU, 0, 0, NS1, S1, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBE ), VL, VU, 0, 0, NS1, S1, + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from SBDSVDX. * IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9998 )'SBDSVDX(vects,V)', IINFO, + WRITE( NOUT, FMT = 9998 )'SBDSVDX(vects,V)', IINFO, $ M, N, JTYPE, IOLDSD INFO = ABS( IINFO ) IF( IINFO.LT.0 ) THEN @@ -1437,7 +1437,7 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * CALL SBDSVDX( UPLO, 'N', 'V', MNMIN, WORK( IWBD ), $ WORK( IWBE ), VL, VU, 0, 0, NS2, S2, - $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), + $ WORK( IWBZ ), MNMIN2, WORK( IWWORK ), $ IWORK, IINFO ) * * Check error code from SBDSVDX. @@ -1461,13 +1461,13 @@ SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, * non-increasing order and are non-negative * 34: Compare SBDSVDX with and without singular vectors * - CALL SBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, - $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), + CALL SBDT04( UPLO, MNMIN, BD, BE, S1, NS1, U, + $ LDPT, VT, LDPT, WORK( IWBS+MNMIN ), $ RESULT( 30 ) ) - CALL SORT01( 'Columns', MNMIN, NS1, U, LDPT, + CALL SORT01( 'Columns', MNMIN, NS1, U, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 31 ) ) - CALL SORT01( 'Rows', NS1, MNMIN, VT, LDPT, + CALL SORT01( 'Rows', NS1, MNMIN, VT, LDPT, $ WORK( IWBS+MNMIN ), LWORK-MNMIN, $ RESULT( 32 ) ) * diff --git a/lapack-netlib/TESTING/EIG/schkbk.f b/lapack-netlib/TESTING/EIG/schkbk.f index 7cc799b8b1..37a636bc2b 100644 --- a/lapack-netlib/TESTING/EIG/schkbk.f +++ b/lapack-netlib/TESTING/EIG/schkbk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKBK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -21,7 +21,7 @@ *> \verbatim *> *> SCHKBK tests SGEBAK, a routine for backward transformation of -*> the computed right or left eigenvectors if the orginal matrix +*> the computed right or left eigenvectors if the original matrix *> was preprocessed by balance subroutine SGEBAL. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SCHKBK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/schkbl.f b/lapack-netlib/TESTING/EIG/schkbl.f index 6584cef67e..ebce7cd838 100644 --- a/lapack-netlib/TESTING/EIG/schkbl.f +++ b/lapack-netlib/TESTING/EIG/schkbl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKBL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SCHKBL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/schkec.f b/lapack-netlib/TESTING/EIG/schkec.f index 8d3e5d354a..d4dff03ea3 100644 --- a/lapack-netlib/TESTING/EIG/schkec.f +++ b/lapack-netlib/TESTING/EIG/schkec.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKEC( THRESH, TSTERR, NIN, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NIN, NOUT * REAL THRESH * .. -* +* * *> \par Purpose: * ============= @@ -64,22 +64,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SCHKEC( THRESH, TSTERR, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/EIG/schkee.f b/lapack-netlib/TESTING/EIG/schkee.f index 0bd994cc43..3757e06558 100644 --- a/lapack-netlib/TESTING/EIG/schkee.f +++ b/lapack-netlib/TESTING/EIG/schkee.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SCHKEE -* +* * *> \par Purpose: * ============= @@ -1028,22 +1028,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== PROGRAM SCHKEE * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * ===================================================================== * @@ -1106,7 +1106,8 @@ PROGRAM SCHKEE $ SDRGEV, SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV, $ SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD, $ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV, - $ SDRGES3, SDRGEV3 + $ SDRGES3, SDRGEV3, + $ SCHKST2STG, SDRVST2STG, SCHKSB2STG, SDRVSG2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1153,7 +1154,8 @@ PROGRAM SCHKEE PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'SHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'SST' ) .OR. - $ LSAMEN( 3, PATH, 'SSG' ) + $ LSAMEN( 3, PATH, 'SSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) + SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'SBD' ) SEV = LSAMEN( 3, PATH, 'SEV' ) SES = LSAMEN( 3, PATH, 'SES' ) @@ -1839,7 +1841,8 @@ PROGRAM SCHKEE $ WRITE( NOUT, FMT = 9980 )'SCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1869,6 +1872,15 @@ PROGRAM SCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL SCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL SCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), @@ -1876,16 +1888,26 @@ PROGRAM SCHKEE $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL SDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL SDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), - $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, - $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRVST', INFO END IF @@ -1918,11 +1940,17 @@ PROGRAM SCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL SDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRVSG', INFO END IF @@ -2105,8 +2133,9 @@ PROGRAM SCHKEE MAXTYP = 26 NTYPES = MIN( MAXTYP, NTYPES ) CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV(1,1) IF( TSTCHK .AND. TSTERR ) - $ CALL SERRGG( C3, NOUT ) + & CALL SERRGG( C3, NOUT ) DO 350 I = 1, NPARMS CALL XLAENV( 1, NBVAL( I ) ) CALL XLAENV( 2, NBMIN( I ) ) @@ -2162,9 +2191,10 @@ PROGRAM SCHKEE * IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRGES', INFO -* +* * Blocked version -* +* + CALL XLAENV(16,1) CALL SDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2227,7 +2257,7 @@ PROGRAM SCHKEE $ WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRGEV', INFO -* +* * Blocked version * CALL SDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, @@ -2282,9 +2312,13 @@ PROGRAM SCHKEE CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL SERRST( 'SSB', NOUT ) - CALL SCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) +* CALL SCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) + CALL SCHKSB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SCHKSB', INFO * @@ -2353,6 +2387,7 @@ PROGRAM SCHKEE * GSV: Generalized Singular Value Decomposition * ---------------------------------------------- * + CALL XLAENV( 1, 1 ) IF( TSTERR ) $ CALL SERRGG( 'GSV', NOUT ) CALL SCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, @@ -2465,7 +2500,7 @@ PROGRAM SCHKEE 9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ', $ 'Problem Expert Driver SGGEVX' ) 9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, - $ ', INMIN=', I4, + $ ', INMIN=', I4, $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) diff --git a/lapack-netlib/TESTING/EIG/schkgg.f b/lapack-netlib/TESTING/EIG/schkgg.f index 708b24374b..6b18a68ba7 100644 --- a/lapack-netlib/TESTING/EIG/schkgg.f +++ b/lapack-netlib/TESTING/EIG/schkgg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1, * BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR, * WORK, LWORK, LLWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL TSTDIF * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES @@ -31,7 +31,7 @@ * $ U( LDU, * ), V( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,7 +72,7 @@ *> and each type of matrix, one matrix will be generated and used *> to test the nonsymmetric eigenroutines. For each matrix, 15 *> tests will be performed. The first twelve "test ratios" should be -*> small -- O(1). They will be compared with the threshhold THRESH: +*> small -- O(1). They will be compared with the threshold THRESH: *> *> T *> (1) | A - U H V | / ( |A| n ulp ) @@ -132,7 +132,7 @@ *> |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp *> *> In addition, the normalization of L and R are checked, and compared -*> with the threshhold THRSHN. +*> with the threshold THRSHN. *> *> Test Matrices *> ---- -------- @@ -298,7 +298,7 @@ *> \param[in] THRSHN *> \verbatim *> THRSHN is REAL -*> Threshhold for reporting eigenvector normalization error. +*> Threshold for reporting eigenvector normalization error. *> If the normalization of any eigenvector differs from 1 by *> more than THRSHN*ulp, then a special error message will be *> printed. (This is handled separately from the other tests, @@ -495,12 +495,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -511,10 +511,10 @@ SUBROUTINE SCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR, $ WORK, LWORK, LLWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL TSTDIF diff --git a/lapack-netlib/TESTING/EIG/schkgk.f b/lapack-netlib/TESTING/EIG/schkgk.f index 944cf0e05e..6d86a1380d 100644 --- a/lapack-netlib/TESTING/EIG/schkgk.f +++ b/lapack-netlib/TESTING/EIG/schkgk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKGK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SCHKGK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/schkgl.f b/lapack-netlib/TESTING/EIG/schkgl.f index fc41e48f36..51b6ff8f75 100644 --- a/lapack-netlib/TESTING/EIG/schkgl.f +++ b/lapack-netlib/TESTING/EIG/schkgl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKGL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -41,22 +41,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SCHKGL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/schkhs.f b/lapack-netlib/TESTING/EIG/schkhs.f index 7543093ef0..fab38c2beb 100644 --- a/lapack-netlib/TESTING/EIG/schkhs.f +++ b/lapack-netlib/TESTING/EIG/schkhs.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * WI1, WR2, WI2, WR3, WI3, EVECTL, EVECTR, EVECTY, * EVECTX, UU, TAU, WORK, NWORK, IWORK, SELECT, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK * REAL THRESH @@ -29,7 +29,7 @@ * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), * $ WR1( * ), WR2( * ), WR3( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -396,12 +396,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_eig * @@ -412,10 +412,10 @@ SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ EVECTY, EVECTX, UU, TAU, WORK, NWORK, IWORK, $ SELECT, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK diff --git a/lapack-netlib/TESTING/EIG/schksb.f b/lapack-netlib/TESTING/EIG/schksb.f index 8bcb9b9cde..e68a95cb54 100644 --- a/lapack-netlib/TESTING/EIG/schksb.f +++ b/lapack-netlib/TESTING/EIG/schksb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, * LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, * $ NWDTHS @@ -23,7 +23,7 @@ * REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ), * $ U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -279,12 +279,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -293,10 +293,10 @@ SUBROUTINE SCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, $ LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, diff --git a/lapack-netlib/TESTING/EIG/schksb2stg.f b/lapack-netlib/TESTING/EIG/schksb2stg.f new file mode 100644 index 0000000000..07dfc83a45 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/schksb2stg.f @@ -0,0 +1,868 @@ +*> \brief \b SCHKSBSTG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ), +* $ U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKSBSTG tests the reduction of a symmetric band matrix to tridiagonal +*> form, used with the symmetric eigenvalue problem. +*> +*> SSBTRD factors a symmetric band matrix A as U S U' , where ' means +*> transpose, S is symmetric tridiagonal, and U is orthogonal. +*> SSBTRD can use either just the lower or just the upper triangle +*> of A; SCHKSBSTG checks both cases. +*> +*> SSYTRD_SB2ST factors a symmetric band matrix A as U S U' , +*> where ' means transpose, S is symmetric tridiagonal, and U is +*> orthogonal. SSYTRD_SB2ST can use either just the lower or just +*> the upper triangle of A; SCHKSBSTG checks both cases. +*> +*> SSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSBTRD "U" (used as reference for SSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSYTRD_SB2ST "L". +*> +*> When SCHKSBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the symmetric banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with +*> UPLO='U' +*> +*> (2) | I - UU' | / ( n ulp ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with +*> UPLO='L' +*> +*> (4) | I - UU' | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> SSBTRD with UPLO='U' and +*> D2 is computed by +*> SSYTRD_SB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> SSBTRD with UPLO='U' and +*> D3 is computed by +*> SSYTRD_SB2ST with UPLO='L' +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> SCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. The values must be at least zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SCHKSBSTG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SCHKSBSTG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension +*> (LDA, max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by SSBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by SSBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is REAL array, dimension (LDU, max(NN)) +*> Used to hold the orthogonal matrix computed by SSBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (4) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ), + $ U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ TEN = 10.0E0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N, + $ NERRS, NMATS, NMAX, NTEST, NTESTT + REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLACPY, SLASET, SLASUM, SLATMR, SLATMS, SSBT21, + $ SSBTRD, XERBLA, SSBTRD_SB2ST, SSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SCHKSBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK( N+1 ), IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call SSBTRD to compute S and U from upper triangle. +* + CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL SSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL SSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 1 ) ) +* +* Before converting A into lower for SSBTRD, run SSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofSSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the SSBTRD and used as reference to compare +* with the SSYTRD_SB2ST routine +* +* Compute D1 from the SSBTRD and used as reference for the +* SSYTRD_SB2ST +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* SSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the SSBTRD. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_SB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the SSYTRD_SB2ST Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = A( K+1-JR, JC+JR ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call SSBTRD to compute S and U from lower triangle +* + CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL SSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL SSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 3 ) ) +* +* SSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the SSBTRD. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_SB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'SSB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL SLASUM( 'SSB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' SCHKSBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, + $ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' ) + 9997 FORMAT( ' Matrix types (see SCHKSBSTG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of SCHKSBSTG +* + END diff --git a/lapack-netlib/TESTING/EIG/schkst.f b/lapack-netlib/TESTING/EIG/schkst.f index 39cb7d7a74..f4ae46832b 100644 --- a/lapack-netlib/TESTING/EIG/schkst.f +++ b/lapack-netlib/TESTING/EIG/schkst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, * WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, * LWORK, IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), * $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -518,7 +518,7 @@ *> \verbatim *> LIWORK is INTEGER *> The number of entries in IWORK. This must be at least -*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax *> where Nmax = max( NN(j), 2 ) and lg = log base 2. *> \endverbatim *> @@ -576,12 +576,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -591,10 +591,10 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/schkst2stg.f b/lapack-netlib/TESTING/EIG/schkst2stg.f new file mode 100644 index 0000000000..1c18e21bc0 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/schkst2stg.f @@ -0,0 +1,2068 @@ +*> \brief \b SCHKST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKST2STG checks the symmetric eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> SSYTRD. For that, we call the standard SSYTRD and compute D1 using +*> SSTEQR, then we call the 2-stage SSYTRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using SSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the SCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> SSYTRD factors A as U S U' , where ' means transpose, +*> S is symmetric tridiagonal, and U is orthogonal. +*> SSYTRD can use either just the lower or just the upper triangle +*> of A; SCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> SSPTRD does the same as SSYTRD, except that A and V are stored +*> in "packed" format. +*> +*> SORGTR constructs the matrix U from the contents of V and TAU. +*> +*> SOPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> SSTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> SSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> SPTEQR factors S as Z4 D4 Z4' , for a +*> symmetric positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> SSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> SSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> SSTEDC factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input orthogonal matrix, usually the output +*> from SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> SSTEMR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). SSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When SCHKST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the symmetric eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) SORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> SSYTRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via SSTEQR('N',...) +*> +*> (4) | I - UV' | / ( n ulp ) SORGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> SSYTRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via SSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for SSPTRD and SOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) SSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) SSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) SSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) SSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and +*> SSTEDC('N') +*> +*> Test 27 is disabled at the moment because SSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because SSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SCHKST2STG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SCHKST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SCHKST2STG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by SSYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> SSYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(V). +*> SPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is REAL array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in SSYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as SORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array of +*> dimension( max(NN) ) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT, LH, LW + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + REAL DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLABAD, SLACPY, SLASET, SLASUM, SLATMR, + $ SLATMS, SOPGTR, SORGTR, SPTEQR, SSPT21, SSPTRD, + $ SSTEBZ, SSTECH, SSTEDC, SSTEMR, SSTEIN, SSTEQR, + $ SSTERF, SSTT21, SSTT22, SSYT21, SSYTRD, XERBLA, + $ SSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'SSYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call SSYTRD and SORGTR to compute S and U from +* upper triangle. +* + CALL SLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL SSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL SORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL SSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL SSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( "U", N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( "L", N, N, A, LDA, V, LDU ) + CALL SSYTRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call SSPTRD and SOPGTR to compute S and U from AP +* + CALL SCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL SSPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL SOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SOPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL SSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 5 ) ) + CALL SSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call SSPTRD and SOPGTR to compute S and U from AP +* + CALL SCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL SSPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL SOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SOPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 7 ) ) + CALL SSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 8 ) ) +* +* Call SSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 9 + CALL SSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 11 + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 12 + CALL SSTERF( N, D3, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL SSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call SPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL SCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 14 + CALL SPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL SSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RESULT( 14 ) ) +* +* Compute D5 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 16 + CALL SPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call SSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call SSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call SSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL SSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, + $ RESULT( 20 ) ) +* +* Call SSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 22 + CALL SSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 22 ) ) +* +* Call SSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 24 + CALL SSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 24 ) ) +* +* Call SSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 26 + CALL SSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test SSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call SSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. SREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL SSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( SRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL SSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call SSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + IF( SRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL SSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 29 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 31 + CALL SSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call SSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 32 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 34 + CALL SSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call SSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 35 +* + CALL SSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RESULT( 35 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 37 + CALL SSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'SST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL SLASUM( 'SST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' SCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see SCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see SCHKST2STG for details.', / ) +* End of SCHKST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/sckcsd.f b/lapack-netlib/TESTING/EIG/sckcsd.f index 20ba3d66fe..5a6e4a0991 100644 --- a/lapack-netlib/TESTING/EIG/sckcsd.f +++ b/lapack-netlib/TESTING/EIG/sckcsd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, * MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, * WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * REAL U1( * ), U2( * ), V1T( * ), V2T( * ), * $ WORK( * ), X( * ), XF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -184,10 +184,10 @@ SUBROUTINE SCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, $ MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, $ WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/sckglm.f b/lapack-netlib/TESTING/EIG/sckglm.f index 7280abfb76..0ac1046159 100644 --- a/lapack-netlib/TESTING/EIG/sckglm.f +++ b/lapack-netlib/TESTING/EIG/sckglm.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * REAL THRESH @@ -21,7 +21,7 @@ * REAL A( * ), AF( * ), B( * ), BF( * ), RWORK( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -167,10 +167,10 @@ SUBROUTINE SCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/sckgqr.f b/lapack-netlib/TESTING/EIG/sckgqr.f index 819cc6fd74..73656315ba 100644 --- a/lapack-netlib/TESTING/EIG/sckgqr.f +++ b/lapack-netlib/TESTING/EIG/sckgqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, * THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, * BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP * REAL THRESH @@ -22,7 +22,7 @@ * $ BF( * ), BT( * ), BWK( * ), BZ( * ), * $ RWORK( * ), TAUA( * ), TAUB( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -210,10 +210,10 @@ SUBROUTINE SCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, $ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, $ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP diff --git a/lapack-netlib/TESTING/EIG/sckgsv.f b/lapack-netlib/TESTING/EIG/sckgsv.f index 3b2676d2a8..6e2b76e7ba 100644 --- a/lapack-netlib/TESTING/EIG/sckgsv.f +++ b/lapack-netlib/TESTING/EIG/sckgsv.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, * IWORK, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * $ BF( * ), Q( * ), R( * ), RWORK( * ), U( * ), * $ V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_eig * @@ -198,10 +198,10 @@ SUBROUTINE SCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, $ IWORK, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/scklse.f b/lapack-netlib/TESTING/EIG/scklse.f index b28d72d989..daf1145d54 100644 --- a/lapack-netlib/TESTING/EIG/scklse.f +++ b/lapack-netlib/TESTING/EIG/scklse.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * REAL THRESH @@ -21,7 +21,7 @@ * REAL A( * ), AF( * ), B( * ), BF( * ), RWORK( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -167,10 +167,10 @@ SUBROUTINE SCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/scsdts.f b/lapack-netlib/TESTING/EIG/scsdts.f index a326f356cf..8ddf119c10 100644 --- a/lapack-netlib/TESTING/EIG/scsdts.f +++ b/lapack-netlib/TESTING/EIG/scsdts.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, * LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. @@ -22,7 +22,7 @@ * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -229,10 +229,10 @@ SUBROUTINE SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -280,7 +280,7 @@ SUBROUTINE SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL SSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ SLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) ELSE EPS2 = ULP @@ -445,7 +445,7 @@ SUBROUTINE SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL SSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX, $ ONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ SLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) ) ELSE EPS2 = ULP @@ -551,7 +551,7 @@ SUBROUTINE SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, END DO * RETURN -* +* * End of SCSDTS * END diff --git a/lapack-netlib/TESTING/EIG/sdrges.f b/lapack-netlib/TESTING/EIG/sdrges.f index f4d9a12466..4e98bfff08 100644 --- a/lapack-netlib/TESTING/EIG/sdrges.f +++ b/lapack-netlib/TESTING/EIG/sdrges.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, * ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES * REAL THRESH @@ -25,7 +25,7 @@ * $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), * $ WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,7 +52,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -388,12 +388,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -403,10 +403,10 @@ SUBROUTINE SDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES diff --git a/lapack-netlib/TESTING/EIG/sdrges3.f b/lapack-netlib/TESTING/EIG/sdrges3.f index 6fed3c846e..90351f6df7 100644 --- a/lapack-netlib/TESTING/EIG/sdrges3.f +++ b/lapack-netlib/TESTING/EIG/sdrges3.f @@ -52,7 +52,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -403,7 +403,7 @@ SUBROUTINE SDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/sdrgev.f b/lapack-netlib/TESTING/EIG/sdrgev.f index 816b37bbf2..d3f8a06ac2 100644 --- a/lapack-netlib/TESTING/EIG/sdrgev.f +++ b/lapack-netlib/TESTING/EIG/sdrgev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, * ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, * WORK, LWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from SGGEV: *> @@ -393,12 +393,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * @@ -408,10 +408,10 @@ SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, $ WORK, LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/sdrgev3.f b/lapack-netlib/TESTING/EIG/sdrgev3.f index c1c92a89ee..9492d43bff 100644 --- a/lapack-netlib/TESTING/EIG/sdrgev3.f +++ b/lapack-netlib/TESTING/EIG/sdrgev3.f @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from SGGEV3: *> @@ -408,7 +408,7 @@ SUBROUTINE SDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, $ WORK, LWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/sdrgsx.f b/lapack-netlib/TESTING/EIG/sdrgsx.f index 4cc8d01927..bb5af0fd62 100644 --- a/lapack-netlib/TESTING/EIG/sdrgsx.f +++ b/lapack-netlib/TESTING/EIG/sdrgsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, * AI, BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S, * WORK, LWORK, IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, * $ NOUT, NSIZE @@ -25,7 +25,7 @@ * $ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ), * $ WORK( * ), Z( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -60,7 +60,7 @@ *> to test SGGESX. *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH except for the tests (7) and (9): +*> compared with the threshold THRESH except for the tests (7) and (9): *> *> (1) | A - Q S Z' | / ( |A| n ulp ) *> @@ -345,12 +345,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -359,10 +359,10 @@ SUBROUTINE SDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, $ AI, BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S, $ WORK, LWORK, IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, diff --git a/lapack-netlib/TESTING/EIG/sdrgvx.f b/lapack-netlib/TESTING/EIG/sdrgvx.f index d899e56db7..b6cc91dc4f 100644 --- a/lapack-netlib/TESTING/EIG/sdrgvx.f +++ b/lapack-netlib/TESTING/EIG/sdrgvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE, * RSCALE, S, STRU, DIF, DIFTRU, WORK, LWORK, * IWORK, LIWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, * $ NSIZE @@ -28,7 +28,7 @@ * $ STRU( * ), VL( LDA, * ), VR( LDA, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -51,7 +51,7 @@ *> ``exactly'' (see SLATM6). *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH. +*> compared with the threshold THRESH. *> *> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of *> @@ -213,32 +213,32 @@ *> IHI is INTEGER *> \endverbatim *> -*> \param[out] LSCALE +*> \param[out] LSCALE *> \verbatim *> LSCALE is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] RSCALE +*> \param[out] RSCALE *> \verbatim *> RSCALE is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] S +*> \param[out] S *> \verbatim *> S is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] STRU +*> \param[out] STRU *> \verbatim *> STRU is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] DIF +*> \param[out] DIF *> \verbatim *> DIF is REAL array, dimension (N) *> \endverbatim *> -*> \param[out] DIFTRU +*> \param[out] DIFTRU *> \verbatim *> DIFTRU is REAL array, dimension (N) *> \endverbatim @@ -286,12 +286,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -301,10 +301,10 @@ SUBROUTINE SDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI, $ RSCALE, S, STRU, DIF, DIFTRU, WORK, LWORK, $ IWORK, LIWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, diff --git a/lapack-netlib/TESTING/EIG/sdrvbd.f b/lapack-netlib/TESTING/EIG/sdrvbd.f index 0eeddb8f7c..b5d8a9b9a9 100644 --- a/lapack-netlib/TESTING/EIG/sdrvbd.f +++ b/lapack-netlib/TESTING/EIG/sdrvbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, * SSAV, E, WORK, LWORK, IWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES, * $ NTYPES @@ -24,7 +24,7 @@ * $ SSAV( * ), U( LDU, * ), USAV( LDU, * ), * $ VT( LDVT, * ), VTSAV( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,7 +131,7 @@ *> *> (29) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the *> vector of singular values from the partial SVD -*> +*> *> Test for SGESVDX( 'V', 'V', 'I' ) *> *> (30) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -139,7 +139,7 @@ *> (31) | I - U'U | / ( M ulp ) *> *> (32) | I - VT VT' | / ( N ulp ) -*> +*> *> Test for SGESVDX( 'V', 'V', 'V' ) *> *> (33) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -341,12 +341,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * @@ -355,10 +355,10 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, $ SSAV, E, WORK, LWORK, IWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES, @@ -386,16 +386,16 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, LOGICAL BADMM, BADNN CHARACTER JOBQ, JOBU, JOBVT, RANGE CHARACTER*3 PATH - INTEGER I, IINFO, IJQ, IJU, IJVT, IL,IU, IWS, IWTMP, - $ ITEMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, - $ MMAX, MNMAX, MNMIN, MTYPES, N, NFAIL, + INTEGER I, IINFO, IJQ, IJU, IJVT, IL,IU, IWS, IWTMP, + $ ITEMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, + $ MMAX, MNMAX, MNMIN, MTYPES, N, NFAIL, $ NMAX, NS, NSI, NSV, NTEST - REAL ANORM, DIF, DIV, OVFL, RTUNFL, ULP, + REAL ANORM, DIF, DIV, OVFL, RTUNFL, ULP, $ ULPINV, UNFL, VL, VU * .. * .. Local Arrays .. CHARACTER CJOB( 4 ), CJOBR( 3 ), CJOBV( 2 ) - INTEGER IOLDSD( 4 ), ISEED2( 4 ) + INTEGER IOLDSD( 4 ), ISEED2( 4 ) REAL RESULT( 40 ) * .. * .. External Functions .. @@ -403,9 +403,9 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL SLAMCH, SLARND * .. * .. External Subroutines .. - EXTERNAL ALASVM, SBDT01, SGEJSV, SGESDD, SGESVD, - $ SGESVDX, SGESVJ, SLABAD, SLACPY, SLASET, SLATMS, - $ SORT01, SORT03, XERBLA + EXTERNAL ALASVM, SBDT01, SGEJSV, SGESDD, SGESVD, + $ SGESVDX, SGESVJ, SLABAD, SLACPY, SLASET, + $ SLATMS, SORT01, SORT03, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, INT, MAX, MIN @@ -904,12 +904,12 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * Test SGESVDX * CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL SGESVDX( 'V', 'V', 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, - $ VTSAV, LDVT, WORK, LWORK, IWORK, + CALL SGESVDX( 'V', 'V', 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, + $ VTSAV, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -953,11 +953,11 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, JOBVT = CJOBV( IJVT+1 ) RANGE = CJOBR( 1 ) CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, - $ VL, VU, IL, IU, NS, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, + $ VL, VU, IL, IU, NS, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) -* +* * Compare U * DIF = ZERO @@ -976,7 +976,7 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IF( M.GT.0 .AND. N.GT.0 ) THEN IF( IJVT.EQ.1 ) THEN CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV, - $ LDVT, VT, LDVT, WORK, LWORK, + $ LDVT, VT, LDVT, WORK, LWORK, $ DIF, IINFO ) END IF END IF @@ -1013,14 +1013,14 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IU = IL IL = ITEMP END IF - END IF + END IF CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL SGESVDX( 'V', 'V', 'I', M, N, A, LDA, - $ VL, VU, IL, IU, NSI, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL SGESVDX( 'V', 'V', 'I', M, N, A, LDA, + $ VL, VU, IL, IU, NSI, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1040,11 +1040,11 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( MNMIN.GT.0 .AND. NSI.GT.1 ) THEN IF( IL.NE.1 ) THEN - VU = SSAV( IL ) + + VU = SSAV( IL ) + $ MAX( HALF*ABS( SSAV( IL )-SSAV( IL-1 ) ), $ ULP*ANORM, TWO*RTUNFL ) ELSE - VU = SSAV( 1 ) + + VU = SSAV( 1 ) + $ MAX( HALF*ABS( SSAV( NS )-SSAV( 1 ) ), $ ULP*ANORM, TWO*RTUNFL ) END IF @@ -1061,14 +1061,14 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, ELSE VL = ZERO VU = ONE - END IF + END IF CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA ) - CALL SGESVDX( 'V', 'V', 'V', M, N, A, LDA, - $ VL, VU, IL, IU, NSV, S, U, LDU, - $ VT, LDVT, WORK, LWORK, IWORK, + CALL SGESVDX( 'V', 'V', 'V', M, N, A, LDA, + $ VL, VU, IL, IU, NSV, S, U, LDU, + $ VT, LDVT, WORK, LWORK, IWORK, $ IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1087,7 +1087,7 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * End of Loop -- Check for RESULT(j) > THRESH * DO 210 J = 1, 35 - IF( RESULT( J ).GE.THRESH ) THEN + IF( RESULT( J ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, FMT = 9999 ) WRITE( NOUT, FMT = 9998 ) @@ -1138,7 +1138,7 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' decreasing order, else 1/ulp', $ / '19 = | U - Upartial | / ( M ulp )', $ / '20 = | VT - VTpartial | / ( N ulp )', - $ / '21 = | S - Spartial | / ( min(M,N) ulp |S| )', + $ / '21 = | S - Spartial | / ( min(M,N) ulp |S| )', $ / '22 = 0 if S contains min(M,N) nonnegative values in', $ ' decreasing order, else 1/ulp', $ ' SGESVDX(V,V,A) ', @@ -1157,7 +1157,7 @@ SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp ),', $ ' SGESVDX(V,V,V) ', $ / '34 = | I - U**T U | / ( M ulp ) ', - $ / '35 = | I - VT VT**T | / ( N ulp ) ', + $ / '35 = | I - VT VT**T | / ( N ulp ) ', $ / / ) 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1, $ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 ) diff --git a/lapack-netlib/TESTING/EIG/sdrves.f b/lapack-netlib/TESTING/EIG/sdrves.f index f2ec1e7277..64cd86118f 100644 --- a/lapack-netlib/TESTING/EIG/sdrves.f +++ b/lapack-netlib/TESTING/EIG/sdrves.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, * LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK * REAL THRESH @@ -23,7 +23,7 @@ * $ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ), * $ WORK( * ), WR( * ), WRT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -374,12 +374,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -388,10 +388,10 @@ SUBROUTINE SDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, $ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK @@ -948,7 +948,7 @@ SUBROUTINE SDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if WR, WI same no matter if VS computed (sort),', $ ' 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / ) + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', / ) 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ), $ ' type ', I2, ', test(', I2, ')=', G10.3 ) 9992 FORMAT( ' SDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', diff --git a/lapack-netlib/TESTING/EIG/sdrvev.f b/lapack-netlib/TESTING/EIG/sdrvev.f index f728cb4fba..4888bc8bfd 100644 --- a/lapack-netlib/TESTING/EIG/sdrvev.f +++ b/lapack-netlib/TESTING/EIG/sdrvev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, * VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, * IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -25,7 +25,7 @@ * $ RESULT( 7 ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -391,12 +391,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -406,10 +406,10 @@ SUBROUTINE SDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK, $ IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/sdrvsg.f b/lapack-netlib/TESTING/EIG/sdrvsg.f index 5cbf775cca..c6eeec6d90 100644 --- a/lapack-netlib/TESTING/EIG/sdrvsg.f +++ b/lapack-netlib/TESTING/EIG/sdrvsg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, * BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -24,7 +24,7 @@ * $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), * $ RESULT( * ), WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -341,12 +341,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -355,10 +355,10 @@ SUBROUTINE SDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, $ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/sdrvsg2stg.f b/lapack-netlib/TESTING/EIG/sdrvsg2stg.f new file mode 100644 index 0000000000..66ba8c4dd3 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/sdrvsg2stg.f @@ -0,0 +1,1363 @@ +*> \brief \b SDRVSG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVSG2STG checks the real symmetric generalized eigenproblem +*> drivers. +*> +*> SSYGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> SSYGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> SSYGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> SSPGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> SSPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> SSPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> SSBGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> SSBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> SSBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> When SDRVSG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) SSYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> SSYGV and D2 is computed by +*> SSYGV_2STAGE. This test is +*> only performed for SSYGV +*> +*> (2) as (1) but calling SSPGV +*> (3) as (1) but calling SSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling SSPGV +*> (6) as (4) but calling SSBGV +*> +*> (7) SSYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling SSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling SSPGV +*> +*> (11) SSYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling SSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling SSPGV +*> +*> SSYGVD, SSPGVD and SSBGVD performed the same 14 tests. +*> +*> SSYGVX, SSPGVX and SSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value +*> of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVSG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. real) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B REAL array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D REAL array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z REAL array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB REAL array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB REAL array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK REAL array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT REAL array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, +*> SSBGVD, SSYGVX, SSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup real_eig +* +* ===================================================================== + SUBROUTINE SDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + 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 .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLARND + EXTERNAL LSAME, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL SLABAD, SLACPY, SLAFTS, SLASET, SLASUM, SLATMR, + $ SLATMS, SSBGV, SSBGVD, SSBGVX, SSGT01, SSPGV, + $ SSPGVD, SSPGVX, SSYGV, SSYGVD, SSYGVX, XERBLA, + $ SSYGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD, +* SSYGVX, SSPGVX, and SSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL SLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test SSYGV +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSYGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test SSYGVD +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSYGVX +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL SSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test SSPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL SSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL SSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL SSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL SSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL SSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST SSBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL SSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* TEST SSBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL SSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL SSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL SSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL SSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'SSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL SLASUM( 'SSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of SDRVSG2STG +* + 9999 FORMAT( ' SDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/lapack-netlib/TESTING/EIG/sdrvst.f b/lapack-netlib/TESTING/EIG/sdrvst.f index 1dea83b0d0..00e14f3968 100644 --- a/lapack-netlib/TESTING/EIG/sdrvst.f +++ b/lapack-netlib/TESTING/EIG/sdrvst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, * WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, * IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), * $ WA3( * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -438,12 +438,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -453,10 +453,10 @@ SUBROUTINE SDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, $ IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/sdrvst2stg.f b/lapack-netlib/TESTING/EIG/sdrvst2stg.f new file mode 100644 index 0000000000..32a3de05f6 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/sdrvst2stg.f @@ -0,0 +1,2872 @@ +*> \brief \b SDRVST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVST2STG checks the symmetric eigenvalue problem drivers. +*> +*> SSTEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> SSTEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> SSTEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix +*> using the Relatively Robust Representation where it can. +*> +*> SSYEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> SSYEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> SSYEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix +*> using the Relatively Robust Representation where it can. +*> +*> SSPEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> SSPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> SSBEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> SSBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> SSYEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix using +*> a divide and conquer algorithm. +*> +*> SSPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage, using a divide and conquer algorithm. +*> +*> SSBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix, +*> using a divide and conquer algorithm. +*> +*> When SDRVST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 REAL array, dimension +*> +*> EVEIGS REAL array, dimension (max(NN)) +*> The eigenvalues as computed by SSTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 REAL array, dimension +*> +*> WA2 REAL array, dimension +*> +*> WA3 REAL array, dimension +*> +*> U REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V REAL array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU REAL array, dimension (max(NN)) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> Modified. +*> +*> WORK REAL array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT REAL array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) SSTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) SSTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) SSYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) SSYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEV_2STAGE('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV_2STAGE('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD_2STAGE('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD_2STAGE('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ TEN = 10.0E0 ) + REAL HALF + PARAMETER ( HALF = 0.5E+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2, + $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SLABAD, SLACPY, SLAFTS, SLASET, SLATMR, + $ SLATMS, SSBEV, SSBEVD, SSBEVX, SSPEV, SSPEVD, + $ SSPEVX, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSTT21, + $ SSTT22, SSYEV, SSYEVD, SSYEVR, SSYEVX, SSYT21, + $ SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, + $ SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, + $ SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, + $ SSYTRD_SB2ST, SSYT22, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 band symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call SSTEV and SSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'SSTEV' + CALL SSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 150 CONTINUE + CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'SSTEV' + CALL SSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + NTEST = 4 + DO 190 I = 1, N + EVEIGS( I ) = D3( I ) + D1( I ) = REAL( A( I, I ) ) + 190 CONTINUE + DO 200 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 200 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + RESULT( 5 ) = ULPINV + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 4 and 5. +* + DO 210 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 210 CONTINUE + DO 220 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 220 CONTINUE + CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 4 ) ) +* + NTEST = 6 + DO 230 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 230 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 240 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 240 CONTINUE + RESULT( 6 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 250 CONTINUE +* + NTEST = 7 + DO 260 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 260 CONTINUE + DO 270 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 270 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + RESULT( 8 ) = ULPINV + GO TO 320 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 7 and 8. +* + DO 280 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 280 CONTINUE + DO 290 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 290 CONTINUE + CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 7 ) ) +* + NTEST = 9 + DO 300 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 300 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 320 + END IF + END IF +* +* Do test 9. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 310 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 310 CONTINUE + RESULT( 9 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 320 CONTINUE +* +* + NTEST = 10 + DO 330 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 330 CONTINUE + DO 340 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 340 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 10 ) = ULPINV + RESULT( 11 ) = ULPINV + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do tests 10 and 11. +* + DO 350 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 350 CONTINUE + DO 360 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 360 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 10 ) ) +* +* + NTEST = 12 + DO 370 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 370 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do test 12. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 380 CONTINUE +* + NTEST = 12 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 390 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 390 CONTINUE + DO 400 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 400 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF +* +* Do tests 13 and 14. +* + DO 410 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 410 CONTINUE + DO 420 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 420 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 13 ) ) +* + NTEST = 15 + DO 430 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 430 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* +* Do test 15. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 440 CONTINUE +* + NTEST = 16 + DO 450 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 450 CONTINUE + DO 460 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 460 CONTINUE + SRNAMT = 'SSTEVD' + CALL SSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVD(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + RESULT( 17 ) = ULPINV + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do tests 16 and 17. +* + DO 470 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 470 CONTINUE + DO 480 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 480 CONTINUE + CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 16 ) ) +* + NTEST = 18 + DO 490 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 490 CONTINUE + SRNAMT = 'SSTEVD' + CALL SSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVD(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 500 J = 1, N + TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ), + $ ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) ) + 500 CONTINUE + RESULT( 18 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 510 CONTINUE +* + NTEST = 19 + DO 520 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 520 CONTINUE + DO 530 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 530 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* DO tests 19 and 20. +* + DO 540 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 540 CONTINUE + DO 550 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 550 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 19 ) ) +* +* + NTEST = 21 + DO 560 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 560 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* Do test 21. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 570 CONTINUE +* + NTEST = 21 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 580 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 580 CONTINUE + DO 590 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 590 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF +* +* Do tests 22 and 23. +* + DO 600 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 600 CONTINUE + DO 610 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 610 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 22 ) ) +* + NTEST = 24 + DO 620 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 620 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* +* Do test 24. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 630 CONTINUE +* +* +* + ELSE +* + DO 640 I = 1, 24 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 24 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call SSYEV and SSYEVX. +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'SSYEV' + CALL SSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEV_2STAGE' + CALL SSYEV_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do tests 28 and 29 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do test 30 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 680 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do tests 31 and 32 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do test 33 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 690 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 34 and 35 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 36 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 700 CONTINUE +* +* 5) Call SSPEV and SSPEVX. +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 720 J = 1, N + DO 710 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 710 CONTINUE + 720 CONTINUE + ELSE + INDX = 1 + DO 740 J = 1, N + DO 730 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 730 CONTINUE + 740 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSPEV' + CALL SSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do tests 37 and 38 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 760 J = 1, N + DO 750 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 750 CONTINUE + 760 CONTINUE + ELSE + INDX = 1 + DO 780 J = 1, N + DO 770 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 770 CONTINUE + 780 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSPEV' + CALL SSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do test 39 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 790 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 790 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 800 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 820 J = 1, N + DO 810 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 810 CONTINUE + 820 CONTINUE + ELSE + INDX = 1 + DO 840 J = 1, N + DO 830 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 830 CONTINUE + 840 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do tests 40 and 41 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 860 J = 1, N + DO 850 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 850 CONTINUE + 860 CONTINUE + ELSE + INDX = 1 + DO 880 J = 1, N + DO 870 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 870 CONTINUE + 880 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do test 42 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 890 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 890 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 900 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 920 J = 1, N + DO 910 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 910 CONTINUE + 920 CONTINUE + ELSE + INDX = 1 + DO 940 J = 1, N + DO 930 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 930 CONTINUE + 940 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 990 + END IF + END IF +* +* Do tests 43 and 44 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 960 J = 1, N + DO 950 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 950 CONTINUE + 960 CONTINUE + ELSE + INDX = 1 + DO 980 J = 1, N + DO 970 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 970 CONTINUE + 980 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF +* +* Do test 45 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 990 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1080 + END IF + END IF +* +* Do tests 46 and 47 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1050 J = 1, N + DO 1040 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1040 CONTINUE + 1050 CONTINUE + ELSE + INDX = 1 + DO 1070 J = 1, N + DO 1060 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1060 CONTINUE + 1070 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF +* +* Do test 48 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1080 CONTINUE +* +* 6) Call SSBEV and SSBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1100 J = 1, N + DO 1090 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1090 CONTINUE + 1100 CONTINUE + ELSE + DO 1120 J = 1, N + DO 1110 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1110 CONTINUE + 1120 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEV' + CALL SSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 49 and 50 (or ... ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1140 J = 1, N + DO 1130 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1130 CONTINUE + 1140 CONTINUE + ELSE + DO 1160 J = 1, N + DO 1150 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1150 CONTINUE + 1160 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSBEV_2STAGE' + CALL SSBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 51 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1170 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1180 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 1200 J = 1, N + DO 1190 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1190 CONTINUE + 1200 CONTINUE + ELSE + DO 1220 J = 1, N + DO 1210 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1210 CONTINUE + 1220 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do tests 52 and 53 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1240 J = 1, N + DO 1230 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1230 CONTINUE + 1240 CONTINUE + ELSE + DO 1260 J = 1, N + DO 1250 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1250 CONTINUE + 1260 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do test 54 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1270 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) ) + 1270 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1280 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1300 J = 1, N + DO 1290 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1290 CONTINUE + 1300 CONTINUE + ELSE + DO 1320 J = 1, N + DO 1310 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1310 CONTINUE + 1320 CONTINUE + END IF +* + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do tests 55 and 56 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1340 J = 1, N + DO 1330 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1330 CONTINUE + 1340 CONTINUE + ELSE + DO 1360 J = 1, N + DO 1350 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1350 CONTINUE + 1360 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do test 57 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1390 J = 1, N + DO 1380 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1380 CONTINUE + 1390 CONTINUE + ELSE + DO 1410 J = 1, N + DO 1400 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1400 CONTINUE + 1410 CONTINUE + END IF +* + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1460 + END IF + END IF +* +* Do tests 58 and 59 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1430 J = 1, N + DO 1420 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1420 CONTINUE + 1430 CONTINUE + ELSE + DO 1450 J = 1, N + DO 1440 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1440 CONTINUE + 1450 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF +* +* Do test 60 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1460 CONTINUE +* +* 7) Call SSYEVD +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'SSYEVD' + CALL SSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do tests 61 and 62 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVD_2STAGE' + CALL SSYEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do test 63 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1470 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1470 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1480 CONTINUE +* +* 8) Call SSPEVD. +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1500 J = 1, N + DO 1490 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1490 CONTINUE + 1500 CONTINUE + ELSE + INDX = 1 + DO 1520 J = 1, N + DO 1510 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1510 CONTINUE + 1520 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSPEVD' + CALL SSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do tests 64 and 65 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1540 J = 1, N + DO 1530 I = 1, J +* + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1530 CONTINUE + 1540 CONTINUE + ELSE + INDX = 1 + DO 1560 J = 1, N + DO 1550 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1550 CONTINUE + 1560 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSPEVD' + CALL SSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do test 66 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1570 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1570 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + 1580 CONTINUE +* +* 9) Call SSBEVD. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1600 J = 1, N + DO 1590 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1590 CONTINUE + 1600 CONTINUE + ELSE + DO 1620 J = 1, N + DO 1610 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1610 CONTINUE + 1620 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEVD' + CALL SSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do tests 67 and 68 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1640 J = 1, N + DO 1630 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1630 CONTINUE + 1640 CONTINUE + ELSE + DO 1660 J = 1, N + DO 1650 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1650 CONTINUE + 1660 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSBEVD_2STAGE' + CALL SSBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do test 69 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1680 CONTINUE +* +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do tests 70 and 71 (or ... ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do test 72 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1690 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1690 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1700 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do tests 73 and 74 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do test 75 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1710 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 76 and 77 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 78 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL SLAFTS( 'SST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'SST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' SDRVST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of SDRVST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/sdrvsx.f b/lapack-netlib/TESTING/EIG/sdrvsx.f index a4437adb45..25ca8b1c53 100644 --- a/lapack-netlib/TESTING/EIG/sdrvsx.f +++ b/lapack-netlib/TESTING/EIG/sdrvsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NIUNIT, NOUNIT, A, LDA, H, HT, WR, WI, WRT, * WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK, * LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ WI( * ), WIT( * ), WITMP( * ), WORK( * ), * $ WR( * ), WRT( * ), WRTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -439,12 +439,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -454,10 +454,10 @@ SUBROUTINE SDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK, $ LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, @@ -933,7 +933,7 @@ SUBROUTINE SDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if WR, WI same no matter what else computed ', $ '(sort), 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', $ / ' 14 = 0 if RCONDE same no matter what else computed,', $ ' 1/ulp otherwise', / $ ' 15 = 0 if RCONDv same no matter what else computed,', diff --git a/lapack-netlib/TESTING/EIG/sdrvvx.f b/lapack-netlib/TESTING/EIG/sdrvvx.f index a71361967b..1c574e7360 100644 --- a/lapack-netlib/TESTING/EIG/sdrvvx.f +++ b/lapack-netlib/TESTING/EIG/sdrvvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, * RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, * RESULT, WORK, NWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -29,7 +29,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), WI( * ), * $ WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -470,7 +470,7 @@ *> \verbatim *> INFO is INTEGER *> If 0, then successful exit. -*> If <0, then input paramter -INFO is incorrect. +*> If <0, then input parameter -INFO is incorrect. *> If >0, SLATMR, SLATMS, SLATME or SGET23 returned an error *> code, and INFO is its absolute value. *> @@ -504,12 +504,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * @@ -520,10 +520,10 @@ SUBROUTINE SDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, $ RESULT, WORK, NWORK, IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/serrbd.f b/lapack-netlib/TESTING/EIG/serrbd.f index fbd1c2eb93..96f51dfe83 100644 --- a/lapack-netlib/TESTING/EIG/serrbd.f +++ b/lapack-netlib/TESTING/EIG/serrbd.f @@ -2,26 +2,26 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRBD( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SERRBD tests the error exits for SGEBD2, SGEBRD, SORGBR, SORMBR, +*> SERRBD tests the error exits for SGEBD2, SGEBRD, SORGBR, SORMBR, *> SBDSQR, SBDSDC and SBDSVDX. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERRBD( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ SUBROUTINE SERRBD( PATH, NUNIT ) * .. Local Arrays .. INTEGER IQ( NMAX, NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), D( NMAX ), E( NMAX ), - $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ), - $ TQ( NMAX ), U( NMAX, NMAX ), + $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ), + $ TQ( NMAX ), U( NMAX, NMAX ), $ V( NMAX, NMAX ), W( LW ) * .. * .. External Functions .. @@ -89,8 +89,8 @@ SUBROUTINE SERRBD( PATH, NUNIT ) EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL CHKXER, SBDSDC, SBDSQR, SBDSVDX, SGEBD2, SGEBRD, SORGBR, - $ SORMBR + EXTERNAL CHKXER, SBDSDC, SBDSQR, SBDSVDX, SGEBD2, + $ SGEBRD, SORGBR, SORMBR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -309,51 +309,51 @@ SUBROUTINE SERRBD( PATH, NUNIT ) * SRNAMT = 'SBDSVDX' INFOT = 1 - CALL SBDSVDX( 'X', 'N', 'A', 1, D, E, ZERO, ONE, 0, 0, + CALL SBDSVDX( 'X', 'N', 'A', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL SBDSVDX( 'U', 'X', 'A', 1, D, E, ZERO, ONE, 0, 0, + CALL SBDSVDX( 'U', 'X', 'A', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL SBDSVDX( 'U', 'V', 'X', 1, D, E, ZERO, ONE, 0, 0, + CALL SBDSVDX( 'U', 'V', 'X', 1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SBDSVDX( 'U', 'V', 'A', -1, D, E, ZERO, ONE, 0, 0, + CALL SBDSVDX( 'U', 'V', 'A', -1, D, E, ZERO, ONE, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL SBDSVDX( 'U', 'V', 'V', 2, D, E, -ONE, ZERO, 0, 0, + CALL SBDSVDX( 'U', 'V', 'V', 2, D, E, -ONE, ZERO, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SBDSVDX( 'U', 'V', 'V', 2, D, E, ONE, ZERO, 0, 0, + CALL SBDSVDX( 'U', 'V', 'V', 2, D, E, ONE, ZERO, 0, 0, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL SBDSVDX( 'L', 'V', 'I', 2, D, E, ZERO, ZERO, 0, 2, + CALL SBDSVDX( 'L', 'V', 'I', 2, D, E, ZERO, ZERO, 0, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 5, 2, + CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 5, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 2, + CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 2, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 5, + CALL SBDSVDX( 'L', 'V', 'I', 4, D, E, ZERO, ZERO, 3, 5, $ NS, S, Q, 1, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 14 - CALL SBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, + CALL SBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, $ NS, S, Q, 0, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) INFOT = 14 - CALL SBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, + CALL SBDSVDX( 'L', 'V', 'A', 4, D, E, ZERO, ZERO, 0, 0, $ NS, S, Q, 2, W, IW, INFO) CALL CHKXER( 'SBDSVDX', INFOT, NOUT, LERR, OK ) NT = NT + 12 diff --git a/lapack-netlib/TESTING/EIG/serrec.f b/lapack-netlib/TESTING/EIG/serrec.f index f99632fa29..6414a82008 100644 --- a/lapack-netlib/TESTING/EIG/serrec.f +++ b/lapack-netlib/TESTING/EIG/serrec.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERREC( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERREC( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -152,8 +152,8 @@ SUBROUTINE SERREC( PATH, NUNIT ) INFOT = 1 CALL STREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO ) CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL STREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO ) + INFOT = 2 + CALL STREXC( 'N', -1, A, 1, B, 1, IFST, ILST, WORK, INFO ) CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK ) INFOT = 4 ILST = 2 diff --git a/lapack-netlib/TESTING/EIG/serred.f b/lapack-netlib/TESTING/EIG/serred.f index 72ff23914a..f478fcdb1f 100644 --- a/lapack-netlib/TESTING/EIG/serred.f +++ b/lapack-netlib/TESTING/EIG/serred.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRED( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERRED( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -415,7 +415,7 @@ SUBROUTINE SERRED( PATH, NUNIT ) $ 2, 2, A, 2, S, U, 1, VT, 2, $ W, 1, IW, INFO) CALL CHKXER( 'SGEJSV', INFOT, NOUT, LERR, OK ) - INFOT = 14 + INFOT = 15 CALL SGEJSV( 'G', 'U', 'V', 'R', 'N', 'N', $ 2, 2, A, 2, S, U, 2, VT, 1, $ W, 1, IW, INFO) @@ -432,51 +432,51 @@ SUBROUTINE SERRED( PATH, NUNIT ) * SRNAMT = 'SGESVDX' INFOT = 1 - CALL SGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL SGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL SGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL SGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL SGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, + CALL SGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, + CALL SGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, + CALL SGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL SGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, + CALL SGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, + CALL SGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL SGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, + CALL SGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL SGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 0, 1, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL SGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL SGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 1, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL SGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, + CALL SGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) - INFOT = 16 - CALL SGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, + INFOT = 17 + CALL SGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, IW, INFO ) CALL CHKXER( 'SGESVDX', INFOT, NOUT, LERR, OK ) NT = 12 diff --git a/lapack-netlib/TESTING/EIG/serrgg.f b/lapack-netlib/TESTING/EIG/serrgg.f index aede817b6c..5025103eb9 100644 --- a/lapack-netlib/TESTING/EIG/serrgg.f +++ b/lapack-netlib/TESTING/EIG/serrgg.f @@ -50,17 +50,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERRGG( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,7 +83,7 @@ SUBROUTINE SERRGG( PATH, NUNIT ) * .. * .. Local Arrays .. LOGICAL BW( NMAX ), SEL( NMAX ) - INTEGER IW( NMAX ) + INTEGER IW( NMAX ), IDUM(NMAX) REAL A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ), $ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ), $ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ), @@ -305,47 +305,47 @@ SUBROUTINE SERRGG( PATH, NUNIT ) SRNAMT = 'SGGSVD3' INFOT = 1 CALL SGGSVD3( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGGSVD3( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGGSVD3( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGGSVD3( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 5 CALL SGGSVD3( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL SGGSVD3( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGGSVD3( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SGGSVD3( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 16 CALL SGGSVD3( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 18 CALL SGGSVD3( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL SGGSVD3( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, LWORK, INFO ) + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, IDUM, INFO ) CALL CHKXER( 'SGGSVD3', INFOT, NOUT, LERR, OK ) NT = NT + 11 * diff --git a/lapack-netlib/TESTING/EIG/serrhs.f b/lapack-netlib/TESTING/EIG/serrhs.f index c4e3fc3884..b78267cc8c 100644 --- a/lapack-netlib/TESTING/EIG/serrhs.f +++ b/lapack-netlib/TESTING/EIG/serrhs.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRHS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERRHS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/serrst.f b/lapack-netlib/TESTING/EIG/serrst.f index 7155ff6aad..7e5383866f 100644 --- a/lapack-netlib/TESTING/EIG/serrst.f +++ b/lapack-netlib/TESTING/EIG/serrst.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRST( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -25,6 +25,10 @@ *> SOPGTR, SOPMTR, SSTEQR, SSTERF, SSTEBZ, SSTEIN, SPTEQR, SSBTRD, *> SSYEV, SSYEVX, SSYEVD, SSBEV, SSBEVX, SSBEVD, *> SSPEV, SSPEVX, SSPEVD, SSTEV, SSTEVX, SSTEVD, and SSTEDC. +*> SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, +*> SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, +*> SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, +*> SSYTRD_SB2ST *> \endverbatim * * Arguments: @@ -45,22 +49,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SERRST( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -94,7 +98,11 @@ SUBROUTINE SERRST( PATH, NUNIT ) $ SSBEV, SSBEVD, SSBEVX, SSBTRD, SSPEV, SSPEVD, $ SSPEVX, SSPTRD, SSTEBZ, SSTEDC, SSTEIN, SSTEQR, $ SSTERF, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSYEV, - $ SSYEVD, SSYEVR, SSYEVX, SSYTRD + $ SSYEVD, SSYEVR, SSYEVX, SSYTRD, + $ SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, + $ SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, + $ SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, + $ SSYTRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -152,6 +160,103 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* SSYTRD_2STAGE +* + SRNAMT = 'SSYTRD_2STAGE' + INFOT = 1 + CALL SSYTRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYTRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* SSYTRD_SY2SB +* + SRNAMT = 'SSYTRD_SY2SB' + INFOT = 1 + CALL SSYTRD_SY2SB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SY2SB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SY2SB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SY2SB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SY2SB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRD_SY2SB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* SSYTRD_SB2ST +* + SRNAMT = 'SSYTRD_SB2ST' + INFOT = 1 + CALL SSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SORGTR * SRNAMT = 'SORGTR' @@ -536,6 +641,44 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* SSYEVD_2STAGE +* + SRNAMT = 'SSYEVD_2STAGE' + INFOT = 1 + CALL SSYEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL SSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO ) +* CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL SSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) +* CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SSYEVR * SRNAMT = 'SSYEVR' @@ -589,6 +732,74 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* SSYEVR_2STAGE +* + SRNAMT = 'SSYEVR_2STAGE' + N = 1 + INFOT = 1 + CALL SSYEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 0, IW( 2*N+1 ), 10*N, + $ INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 0, + $ INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 +* * SSYEV * SRNAMT = 'SSYEV ' @@ -609,6 +820,29 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* SSYEV_2STAGE +* + SRNAMT = 'SSYEV_2STAGE ' + INFOT = 1 + CALL SSYEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEV_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * SSYEVX * SRNAMT = 'SSYEVX' @@ -661,6 +895,75 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* SSYEVX_2STAGE +* + SRNAMT = 'SSYEVX_2STAGE' + INFOT = 1 + CALL SSYEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0E0, 1.0E0, 1, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + INFOT = 4 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 2, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 0, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * SSPEVD * SRNAMT = 'SSPEVD' @@ -784,6 +1087,47 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* SSYTRD_SB2ST +* + SRNAMT = 'SSYTRD_SB2ST' + INFOT = 1 + CALL SSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SSBEVD * SRNAMT = 'SSBEVD' @@ -827,6 +1171,60 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* SSBEVD_2STAGE +* + SRNAMT = 'SSBEVD_2STAGE' + INFOT = 1 + CALL SSBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, + $ 4, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, +* $ 25, IW, 12, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 0, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVD_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, + $ 3, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 18, IW, 12, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 0, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 25, IW, 11, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 12 + NT = NT + 9 +* * SSBEV * SRNAMT = 'SSBEV ' @@ -850,6 +1248,35 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* SSBEV_2STAGE +* + SRNAMT = 'SSBEV_2STAGE ' + INFOT = 1 + CALL SSBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 0, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEV_2STAGE( 'N', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * SSBEVX * SRNAMT = 'SSBEVX' @@ -864,6 +1291,7 @@ SUBROUTINE SERRST( PATH, NUNIT ) INFOT = 3 CALL SSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0, $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0, $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) @@ -905,6 +1333,72 @@ SUBROUTINE SERRST( PATH, NUNIT ) $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 13 +* +* SSBEVX_2STAGE +* + SRNAMT = 'SSBEVX_2STAGE' + INFOT = 1 + CALL SSBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL SSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0E0, +* $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 2, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 2, 1, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 2, 1, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 1, 2, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 18 +* CALL SSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0E0, +* $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 15 + NT = NT + 13 END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/EIG/sget02.f b/lapack-netlib/TESTING/EIG/sget02.f index 8d2a9fba49..50546869dd 100644 --- a/lapack-netlib/TESTING/EIG/sget02.f +++ b/lapack-netlib/TESTING/EIG/sget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -133,10 +133,10 @@ SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/EIG/sget10.f b/lapack-netlib/TESTING/EIG/sget10.f index d8fc1fa098..8c489d58a9 100644 --- a/lapack-netlib/TESTING/EIG/sget10.f +++ b/lapack-netlib/TESTING/EIG/sget10.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET10( M, N, A, LDA, B, LDB, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, M, N * REAL RESULT @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET10( M, N, A, LDA, B, LDB, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, M, N diff --git a/lapack-netlib/TESTING/EIG/sget22.f b/lapack-netlib/TESTING/EIG/sget22.f index 58c60df4bc..1fcd2b0954 100644 --- a/lapack-netlib/TESTING/EIG/sget22.f +++ b/lapack-netlib/TESTING/EIG/sget22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, * WI, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSA, TRANSE, TRANSW * INTEGER LDA, LDE, N @@ -19,7 +19,7 @@ * REAL A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ), * $ WORK( * ), WR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -167,10 +167,10 @@ SUBROUTINE SGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, $ WI, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSA, TRANSE, TRANSW diff --git a/lapack-netlib/TESTING/EIG/sget23.f b/lapack-netlib/TESTING/EIG/sget23.f index 2178296fed..ac936bc897 100644 --- a/lapack-netlib/TESTING/EIG/sget23.f +++ b/lapack-netlib/TESTING/EIG/sget23.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, LWORK, IWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * CHARACTER BALANC @@ -30,7 +30,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), WI( * ), * $ WI1( * ), WORK( * ), WR( * ), WR1( * ) * .. -* +* * *> \par Purpose: * ============= @@ -362,12 +362,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -378,10 +378,10 @@ SUBROUTINE SGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/sget24.f b/lapack-netlib/TESTING/EIG/sget24.f index 33ead76ef5..e0b75ff0fc 100644 --- a/lapack-netlib/TESTING/EIG/sget24.f +++ b/lapack-netlib/TESTING/EIG/sget24.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS, * LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT, * RESULT, WORK, LWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT @@ -26,7 +26,7 @@ * $ WI( * ), WIT( * ), WITMP( * ), WORK( * ), * $ WR( * ), WRT( * ), WRTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -328,12 +328,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -343,10 +343,10 @@ SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, $ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT, $ RESULT, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/sget31.f b/lapack-netlib/TESTING/EIG/sget31.f index 365bb8e2e9..00b05ad772 100644 --- a/lapack-netlib/TESTING/EIG/sget31.f +++ b/lapack-netlib/TESTING/EIG/sget31.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET31( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX * REAL RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET31( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX diff --git a/lapack-netlib/TESTING/EIG/sget32.f b/lapack-netlib/TESTING/EIG/sget32.f index a7f5f5781b..60547e0349 100644 --- a/lapack-netlib/TESTING/EIG/sget32.f +++ b/lapack-netlib/TESTING/EIG/sget32.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET32( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET32( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/sget33.f b/lapack-netlib/TESTING/EIG/sget33.f index c7d256fdcf..c1859f4e49 100644 --- a/lapack-netlib/TESTING/EIG/sget33.f +++ b/lapack-netlib/TESTING/EIG/sget33.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET33( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -64,22 +64,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET33( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/sget34.f b/lapack-netlib/TESTING/EIG/sget34.f index b7f6fcbd0d..87c7ac99a3 100644 --- a/lapack-netlib/TESTING/EIG/sget34.f +++ b/lapack-netlib/TESTING/EIG/sget34.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET34( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX * REAL RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 2 ) * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET34( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX diff --git a/lapack-netlib/TESTING/EIG/sget35.f b/lapack-netlib/TESTING/EIG/sget35.f index d9b2c57577..919a6469f7 100644 --- a/lapack-netlib/TESTING/EIG/sget35.f +++ b/lapack-netlib/TESTING/EIG/sget35.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET35( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET35( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/sget36.f b/lapack-netlib/TESTING/EIG/sget36.f index 825c6305b1..bf419869c8 100644 --- a/lapack-netlib/TESTING/EIG/sget36.f +++ b/lapack-netlib/TESTING/EIG/sget36.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET36( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN * REAL RMAX @@ -17,7 +17,7 @@ * .. Array Arguments .. * INTEGER NINFO( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -76,22 +76,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET36( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN diff --git a/lapack-netlib/TESTING/EIG/sget37.f b/lapack-netlib/TESTING/EIG/sget37.f index 320df9fa85..7e63f9bdf9 100644 --- a/lapack-netlib/TESTING/EIG/sget37.f +++ b/lapack-netlib/TESTING/EIG/sget37.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET37( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * REAL RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET37( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/sget38.f b/lapack-netlib/TESTING/EIG/sget38.f index 44fea40443..ca3475bf93 100644 --- a/lapack-netlib/TESTING/EIG/sget38.f +++ b/lapack-netlib/TESTING/EIG/sget38.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET38( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * REAL RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET38( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/sget39.f b/lapack-netlib/TESTING/EIG/sget39.f index c934499e35..f02c6f8566 100644 --- a/lapack-netlib/TESTING/EIG/sget39.f +++ b/lapack-netlib/TESTING/EIG/sget39.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET39( RMAX, LMAX, NINFO, KNT ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NINFO * REAL RMAX * .. -* +* * *> \par Purpose: * ============= @@ -91,22 +91,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET39( RMAX, LMAX, NINFO, KNT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NINFO diff --git a/lapack-netlib/TESTING/EIG/sget51.f b/lapack-netlib/TESTING/EIG/sget51.f index 22feacbede..750cc7ce15 100644 --- a/lapack-netlib/TESTING/EIG/sget51.f +++ b/lapack-netlib/TESTING/EIG/sget51.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER ITYPE, LDA, LDB, LDU, LDV, N * REAL RESULT @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDB, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -149,10 +149,10 @@ SUBROUTINE SGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ITYPE, LDA, LDB, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/sget52.f b/lapack-netlib/TESTING/EIG/sget52.f index f3debdbdf4..135ab1903b 100644 --- a/lapack-netlib/TESTING/EIG/sget52.f +++ b/lapack-netlib/TESTING/EIG/sget52.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, * ALPHAI, BETA, WORK, RESULT ) -* +* * .. Scalar Arguments .. * LOGICAL LEFT * INTEGER LDA, LDB, LDE, N @@ -20,7 +20,7 @@ * $ B( LDB, * ), BETA( * ), E( LDE, * ), * $ RESULT( 2 ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -62,7 +62,7 @@ *> supposed to be normalized so that the maximum "absolute value" *> of its elements is 1, where in this case, "absolute value" *> of a complex value x is |Re(x)| + |Im(x)| ; let us call this -*> maximum "absolute value" norm of a vector v M(v). +*> maximum "absolute value" norm of a vector v M(v). *> if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate *> vector. The normalization test is: *> @@ -186,12 +186,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -199,10 +199,10 @@ SUBROUTINE SGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, $ ALPHAI, BETA, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LEFT diff --git a/lapack-netlib/TESTING/EIG/sget53.f b/lapack-netlib/TESTING/EIG/sget53.f index 74f4056ebe..0811db75ff 100644 --- a/lapack-netlib/TESTING/EIG/sget53.f +++ b/lapack-netlib/TESTING/EIG/sget53.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB * REAL RESULT, SCALE, WI, WR @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,22 +114,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB diff --git a/lapack-netlib/TESTING/EIG/sget54.f b/lapack-netlib/TESTING/EIG/sget54.f index 48324eaacf..adc5886baf 100644 --- a/lapack-netlib/TESTING/EIG/sget54.f +++ b/lapack-netlib/TESTING/EIG/sget54.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, * LDV, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N * REAL RESULT @@ -20,7 +20,7 @@ * $ T( LDT, * ), U( LDU, * ), V( LDV, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -156,10 +156,10 @@ SUBROUTINE SGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, $ LDV, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/sglmts.f b/lapack-netlib/TESTING/EIG/sglmts.f index 2e8988a42d..1ae58da706 100644 --- a/lapack-netlib/TESTING/EIG/sglmts.f +++ b/lapack-netlib/TESTING/EIG/sglmts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, * X, U, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * REAL RESULT @@ -19,7 +19,7 @@ * REAL A( LDA, * ), AF( LDA, * ), B( LDB, * ), * $ BF( LDB, * ), RWORK( * ), D( * ), DF( * ), * $ U( * ), WORK( LWORK ), X( * ) -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -149,10 +149,10 @@ SUBROUTINE SGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, $ X, U, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/sgqrts.f b/lapack-netlib/TESTING/EIG/sgqrts.f index 725ab258a0..2ed6dfc475 100644 --- a/lapack-netlib/TESTING/EIG/sgqrts.f +++ b/lapack-netlib/TESTING/EIG/sgqrts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -21,7 +21,7 @@ * $ TAUA( * ), TAUB( * ), RESULT( 4 ), * $ RWORK( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -176,10 +176,10 @@ SUBROUTINE SGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/sgrqts.f b/lapack-netlib/TESTING/EIG/sgrqts.f index b2d692b5d4..0e26783c6b 100644 --- a/lapack-netlib/TESTING/EIG/sgrqts.f +++ b/lapack-netlib/TESTING/EIG/sgrqts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -22,7 +22,7 @@ * $ TAUA( * ), TAUB( * ), * $ RESULT( 4 ), RWORK( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -164,12 +164,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -177,10 +177,10 @@ SUBROUTINE SGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/sgsvts3.f b/lapack-netlib/TESTING/EIG/sgsvts3.f index 23aa62c77c..50ccd378bc 100644 --- a/lapack-netlib/TESTING/EIG/sgsvts3.f +++ b/lapack-netlib/TESTING/EIG/sgsvts3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, * LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P * .. @@ -23,7 +23,7 @@ * $ RWORK( * ), U( LDU, * ), V( LDV, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -196,10 +196,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -210,7 +210,7 @@ SUBROUTINE SGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * August 2015 diff --git a/lapack-netlib/TESTING/EIG/shst01.f b/lapack-netlib/TESTING/EIG/shst01.f index b1c9dbd1f6..50fd361854 100644 --- a/lapack-netlib/TESTING/EIG/shst01.f +++ b/lapack-netlib/TESTING/EIG/shst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, * LWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), H( LDH, * ), Q( LDQ, * ), * $ RESULT( 2 ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -134,10 +134,10 @@ SUBROUTINE SHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, $ LWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N diff --git a/lapack-netlib/TESTING/EIG/slafts.f b/lapack-netlib/TESTING/EIG/slafts.f index 0b1c089fc2..008c118ad2 100644 --- a/lapack-netlib/TESTING/EIG/slafts.f +++ b/lapack-netlib/TESTING/EIG/slafts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, * THRESH, IOUNIT, IE ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER IE, IMAT, IOUNIT, M, N, NTESTS @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * REAL RESULT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,12 +86,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -99,10 +99,10 @@ SUBROUTINE SLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, $ THRESH, IOUNIT, IE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/slahd2.f b/lapack-netlib/TESTING/EIG/slahd2.f index bdfc510fff..440f958910 100644 --- a/lapack-netlib/TESTING/EIG/slahd2.f +++ b/lapack-netlib/TESTING/EIG/slahd2.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAHD2( IOUNIT, PATH ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER IOUNIT * .. -* +* * *> \par Purpose: * ============= @@ -53,22 +53,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SLAHD2( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/slarfy.f b/lapack-netlib/TESTING/EIG/slarfy.f index 461393e92a..340c544130 100644 --- a/lapack-netlib/TESTING/EIG/slarfy.f +++ b/lapack-netlib/TESTING/EIG/slarfy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCV, LDC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/slarhs.f b/lapack-netlib/TESTING/EIG/slarhs.f index 6cabe40984..e4a8159f79 100644 --- a/lapack-netlib/TESTING/EIG/slarhs.f +++ b/lapack-netlib/TESTING/EIG/slarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -204,10 +204,10 @@ SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/EIG/slasum.f b/lapack-netlib/TESTING/EIG/slasum.f index d673954a70..58fd580810 100644 --- a/lapack-netlib/TESTING/EIG/slasum.f +++ b/lapack-netlib/TESTING/EIG/slasum.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLASUM( TYPE, IOUNIT, IE, NRUN ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER IE, IOUNIT, NRUN * .. -* +* * Purpose * ======= * @@ -28,22 +28,22 @@ * Authors: * ======== * -* \author Univ. of Tennessee -* \author Univ. of California Berkeley -* \author Univ. of Colorado Denver -* \author NAG Ltd. +* \author Univ. of Tennessee +* \author Univ. of California Berkeley +* \author Univ. of Colorado Denver +* \author NAG Ltd. * -* \date November 2011 +* \date December 2016 * * \ingroup single_eig * * ===================================================================== SUBROUTINE SLASUM( TYPE, IOUNIT, IE, NRUN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/EIG/slatb9.f b/lapack-netlib/TESTING/EIG/slatb9.f index ad612073c2..49fb162882 100644 --- a/lapack-netlib/TESTING/EIG/slatb9.f +++ b/lapack-netlib/TESTING/EIG/slatb9.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,14 +11,14 @@ * SUBROUTINE SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, * KLB, KUB, ANORM, BNORM, MODEA, MODEB, * CNDNMA, CNDNMB, DISTA, DISTB ) -* +* * .. Scalar Arguments .. * CHARACTER DISTA, DISTB, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KLA, KUA, KLB, KUB, M, P, MODEA, MODEB, N * REAL ANORM, BNORM, CNDNMA, CNDNMB * .. -* +* * *> \par Purpose: * ============= @@ -156,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -170,10 +170,10 @@ SUBROUTINE SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, $ KLB, KUB, ANORM, BNORM, MODEA, MODEB, $ CNDNMA, CNDNMB, DISTA, DISTB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DISTA, DISTB, TYPE @@ -276,7 +276,7 @@ SUBROUTINE SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, ELSE * * A: general dense, B: general dense -* +* KLA = MAX( M-1, 0 ) KUA = MAX( N-1, 0 ) KLB = MAX( P-1, 0 ) diff --git a/lapack-netlib/TESTING/EIG/slatm4.f b/lapack-netlib/TESTING/EIG/slatm4.f index d2e52d4f92..3607c04ba2 100644 --- a/lapack-netlib/TESTING/EIG/slatm4.f +++ b/lapack-netlib/TESTING/EIG/slatm4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND, * TRIANG, IDIST, ISEED, A, LDA ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2 * REAL AMAGN, RCOND, TRIANG @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -175,10 +175,10 @@ SUBROUTINE SLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND, $ TRIANG, IDIST, ISEED, A, LDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2 diff --git a/lapack-netlib/TESTING/EIG/slctes.f b/lapack-netlib/TESTING/EIG/slctes.f index e39b0d6358..8753d43a21 100644 --- a/lapack-netlib/TESTING/EIG/slctes.f +++ b/lapack-netlib/TESTING/EIG/slctes.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION SLCTES( ZR, ZI, D ) -* +* * .. Scalar Arguments .. * REAL D, ZI, ZR * .. -* +* * *> \par Purpose: * ============= @@ -26,7 +26,7 @@ *> .FALSE.. *> *> It is used by the test routine SDRGES to test whether the driver -*> routine SGGES succesfully sorts eigenvalues. +*> routine SGGES successfully sorts eigenvalues. *> \endverbatim * * Arguments: @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== LOGICAL FUNCTION SLCTES( ZR, ZI, D ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. REAL D, ZI, ZR diff --git a/lapack-netlib/TESTING/EIG/slctsx.f b/lapack-netlib/TESTING/EIG/slctsx.f index d17064514f..084d2a8bbb 100644 --- a/lapack-netlib/TESTING/EIG/slctsx.f +++ b/lapack-netlib/TESTING/EIG/slctsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION SLCTSX( AR, AI, BETA ) -* +* * .. Scalar Arguments .. * REAL AI, AR, BETA * .. -* +* * *> \par Purpose: * ============= @@ -53,22 +53,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== LOGICAL FUNCTION SLCTSX( AR, AI, BETA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL AI, AR, BETA diff --git a/lapack-netlib/TESTING/EIG/slsets.f b/lapack-netlib/TESTING/EIG/slsets.f index 50a8a6c742..ad483bcd0a 100644 --- a/lapack-netlib/TESTING/EIG/slsets.f +++ b/lapack-netlib/TESTING/EIG/slsets.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, * D, DF, X, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, P, N * .. @@ -19,7 +19,7 @@ * $ BF( LDB, * ), RESULT( 2 ), RWORK( * ), * $ C( * ), D( * ), CF( * ), DF( * ), * $ WORK( LWORK ), X( * ) -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -155,10 +155,10 @@ SUBROUTINE SLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, $ D, DF, X, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, P, N diff --git a/lapack-netlib/TESTING/EIG/sort01.f b/lapack-netlib/TESTING/EIG/sort01.f index 4e7b0b04e8..d013c70c51 100644 --- a/lapack-netlib/TESTING/EIG/sort01.f +++ b/lapack-netlib/TESTING/EIG/sort01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER ROWCOL * INTEGER LDU, LWORK, M, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER ROWCOL diff --git a/lapack-netlib/TESTING/EIG/sort03.f b/lapack-netlib/TESTING/EIG/sort03.f index ade9a4f335..09a941487a 100644 --- a/lapack-netlib/TESTING/EIG/sort03.f +++ b/lapack-netlib/TESTING/EIG/sort03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) RC * INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -156,10 +156,10 @@ SUBROUTINE SORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) RC diff --git a/lapack-netlib/TESTING/EIG/ssbt21.f b/lapack-netlib/TESTING/EIG/ssbt21.f index 88dd0a876c..50128ddbb6 100644 --- a/lapack-netlib/TESTING/EIG/ssbt21.f +++ b/lapack-netlib/TESTING/EIG/ssbt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KA, KS, LDA, LDU, N @@ -19,7 +19,7 @@ * REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -146,10 +146,10 @@ SUBROUTINE SSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/ssgt01.f b/lapack-netlib/TESTING/EIG/ssgt01.f index f60a28baa1..e4af48ddb7 100644 --- a/lapack-netlib/TESTING/EIG/ssgt01.f +++ b/lapack-netlib/TESTING/EIG/ssgt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, * WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, LDA, LDB, LDZ, M, N @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), * $ WORK( * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -146,10 +146,10 @@ SUBROUTINE SSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, $ WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/sslect.f b/lapack-netlib/TESTING/EIG/sslect.f index 89d0981a20..5a85e25209 100644 --- a/lapack-netlib/TESTING/EIG/sslect.f +++ b/lapack-netlib/TESTING/EIG/sslect.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION SSLECT( ZR, ZI ) -* +* * .. Scalar Arguments .. * REAL ZI, ZR * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,8 @@ *> *> SSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be *> selected, and otherwise it returns .FALSE. -*> It is used by SCHK41 to test if SGEES succesfully sorts eigenvalues, -*> and by SCHK43 to test if SGEESX succesfully sorts eigenvalues. +*> It is used by SCHK41 to test if SGEES successfully sorts eigenvalues, +*> and by SCHK43 to test if SGEESX successfully sorts eigenvalues. *> *> The common block /SSLCT/ controls how eigenvalues are selected. *> If SELOPT = 0, then SSLECT return .TRUE. when ZR is less than zero, @@ -50,22 +50,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup single_eig * * ===================================================================== LOGICAL FUNCTION SSLECT( ZR, ZI ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. REAL ZI, ZR diff --git a/lapack-netlib/TESTING/EIG/sspt21.f b/lapack-netlib/TESTING/EIG/sspt21.f index 69dc683587..2384c87de9 100644 --- a/lapack-netlib/TESTING/EIG/sspt21.f +++ b/lapack-netlib/TESTING/EIG/sspt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, * TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDU, N @@ -19,7 +19,7 @@ * REAL AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ), * $ U( LDU, * ), VP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -206,12 +206,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -219,10 +219,10 @@ SUBROUTINE SSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, $ TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/sstech.f b/lapack-netlib/TESTING/EIG/sstech.f index 3ed8cb12e8..d383e47ce2 100644 --- a/lapack-netlib/TESTING/EIG/sstech.f +++ b/lapack-netlib/TESTING/EIG/sstech.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSTECH( N, A, B, EIG, TOL, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * REAL TOL @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( * ), B( * ), EIG( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SSTECH( N, A, B, EIG, TOL, WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/TESTING/EIG/sstect.f b/lapack-netlib/TESTING/EIG/sstect.f index 9033a4eaa7..314d0f68e8 100644 --- a/lapack-netlib/TESTING/EIG/sstect.f +++ b/lapack-netlib/TESTING/EIG/sstect.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSTECT( N, A, B, SHIFT, NUM ) -* +* * .. Scalar Arguments .. * INTEGER N, NUM * REAL SHIFT @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL A( * ), B( * ) * .. -* +* * *> \par Purpose: * ============= @@ -70,22 +70,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SSTECT( N, A, B, SHIFT, NUM ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NUM diff --git a/lapack-netlib/TESTING/EIG/sstt21.f b/lapack-netlib/TESTING/EIG/sstt21.f index 08fcf9faef..5045d7f0fa 100644 --- a/lapack-netlib/TESTING/EIG/sstt21.f +++ b/lapack-netlib/TESTING/EIG/sstt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, N * .. @@ -18,7 +18,7 @@ * REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ), * $ SE( * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -127,10 +127,10 @@ SUBROUTINE SSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, N diff --git a/lapack-netlib/TESTING/EIG/sstt22.f b/lapack-netlib/TESTING/EIG/sstt22.f index 607e8532ff..0a65e4d5de 100644 --- a/lapack-netlib/TESTING/EIG/sstt22.f +++ b/lapack-netlib/TESTING/EIG/sstt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, * LDWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, LDWORK, M, N * .. @@ -18,7 +18,7 @@ * REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ), * $ SE( * ), U( LDU, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -139,10 +139,10 @@ SUBROUTINE SSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ LDWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, LDWORK, M, N diff --git a/lapack-netlib/TESTING/EIG/ssvdch.f b/lapack-netlib/TESTING/EIG/ssvdch.f index 1bee8001e4..73654f7cfc 100644 --- a/lapack-netlib/TESTING/EIG/ssvdch.f +++ b/lapack-netlib/TESTING/EIG/ssvdch.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSVDCH( N, S, E, SVD, TOL, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, N * REAL TOL @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL E( * ), S( * ), SVD( * ) * .. -* +* * *> \par Purpose: * ============= @@ -85,22 +85,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SSVDCH( N, S, E, SVD, TOL, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/lapack-netlib/TESTING/EIG/ssvdct.f b/lapack-netlib/TESTING/EIG/ssvdct.f index 60af26fa4d..8db20bad7d 100644 --- a/lapack-netlib/TESTING/EIG/ssvdct.f +++ b/lapack-netlib/TESTING/EIG/ssvdct.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSVDCT( N, S, E, SHIFT, NUM ) -* +* * .. Scalar Arguments .. * INTEGER N, NUM * REAL SHIFT @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL E( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * * ===================================================================== SUBROUTINE SSVDCT( N, S, E, SHIFT, NUM ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NUM diff --git a/lapack-netlib/TESTING/EIG/ssxt1.f b/lapack-netlib/TESTING/EIG/ssxt1.f index 164633cc74..858ef8c6f2 100644 --- a/lapack-netlib/TESTING/EIG/ssxt1.f +++ b/lapack-netlib/TESTING/EIG/ssxt1.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SSXT1( IJOB, D1, N1, D2, N2, ABSTOL, * ULP, UNFL ) -* +* * .. Scalar Arguments .. * INTEGER IJOB, N1, N2 * REAL ABSTOL, ULP, UNFL @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL D1( * ), D2( * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,12 +93,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -106,10 +106,10 @@ REAL FUNCTION SSXT1( IJOB, D1, N1, D2, N2, ABSTOL, $ ULP, UNFL ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IJOB, N1, N2 diff --git a/lapack-netlib/TESTING/EIG/ssyt21.f b/lapack-netlib/TESTING/EIG/ssyt21.f index d2ce8bf643..a7add34187 100644 --- a/lapack-netlib/TESTING/EIG/ssyt21.f +++ b/lapack-netlib/TESTING/EIG/ssyt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, * LDV, TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, N @@ -19,7 +19,7 @@ * REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -192,12 +192,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -205,10 +205,10 @@ SUBROUTINE SSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, $ LDV, TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/ssyt22.f b/lapack-netlib/TESTING/EIG/ssyt22.f index dbc0438a54..3b748ec7f4 100644 --- a/lapack-netlib/TESTING/EIG/ssyt22.f +++ b/lapack-netlib/TESTING/EIG/ssyt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, * V, LDV, TAU, WORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N @@ -19,7 +19,7 @@ * REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ), * $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_eig * @@ -155,10 +155,10 @@ SUBROUTINE SSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, $ V, LDV, TAU, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/xerbla.f b/lapack-netlib/TESTING/EIG/xerbla.f index 8694ff1ff7..d57f6bcf84 100644 --- a/lapack-netlib/TESTING/EIG/xerbla.f +++ b/lapack-netlib/TESTING/EIG/xerbla.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. -* +* * *> \par Purpose: * ============= @@ -47,12 +47,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * @@ -75,10 +75,10 @@ * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*(*) SRNAME diff --git a/lapack-netlib/TESTING/EIG/xlaenv.f b/lapack-netlib/TESTING/EIG/xlaenv.f index 66705f8563..e973bc2cb0 100644 --- a/lapack-netlib/TESTING/EIG/xlaenv.f +++ b/lapack-netlib/TESTING/EIG/xlaenv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XLAENV( ISPEC, NVALUE ) -* +* * .. Scalar Arguments .. * INTEGER ISPEC, NVALUE * .. -* +* * *> \par Purpose: * ============= @@ -69,22 +69,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * * ===================================================================== SUBROUTINE XLAENV( ISPEC, NVALUE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ISPEC, NVALUE diff --git a/lapack-netlib/TESTING/EIG/zbdt01.f b/lapack-netlib/TESTING/EIG/zbdt01.f index 419f1642cb..ead9f10508 100644 --- a/lapack-netlib/TESTING/EIG/zbdt01.f +++ b/lapack-netlib/TESTING/EIG/zbdt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER KD, LDA, LDPT, LDQ, M, N * DOUBLE PRECISION RESID @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -146,10 +146,10 @@ SUBROUTINE ZBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KD, LDA, LDPT, LDQ, M, N diff --git a/lapack-netlib/TESTING/EIG/zbdt02.f b/lapack-netlib/TESTING/EIG/zbdt02.f index e517c871ca..2101a2e0cf 100644 --- a/lapack-netlib/TESTING/EIG/zbdt02.f +++ b/lapack-netlib/TESTING/EIG/zbdt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDC, LDU, M, N * DOUBLE PRECISION RESID @@ -20,7 +20,7 @@ * COMPLEX*16 B( LDB, * ), C( LDC, * ), U( LDU, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -119,10 +119,10 @@ SUBROUTINE ZBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDC, LDU, M, N diff --git a/lapack-netlib/TESTING/EIG/zbdt03.f b/lapack-netlib/TESTING/EIG/zbdt03.f index 6f1d443f9f..079d4ffb03 100644 --- a/lapack-netlib/TESTING/EIG/zbdt03.f +++ b/lapack-netlib/TESTING/EIG/zbdt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDU, LDVT, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION D( * ), E( * ), S( * ) * COMPLEX*16 U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -135,10 +135,10 @@ SUBROUTINE ZBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zbdt05.f b/lapack-netlib/TESTING/EIG/zbdt05.f index e64c93b0d9..7a493292a3 100644 --- a/lapack-netlib/TESTING/EIG/zbdt05.f +++ b/lapack-netlib/TESTING/EIG/zbdt05.f @@ -1,14 +1,15 @@ +*> \brief \b ZBDT05 * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU, -* VT, LDVT, WORK, RESID ) -* +* SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU, +* VT, LDVT, WORK, RESID ) +* * .. Scalar Arguments .. * INTEGER LDA, LDU, LDVT, N, NS * DOUBLE PRECISION RESID @@ -61,14 +62,14 @@ *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (NS) -*> The singular values from the (partial) SVD of B, sorted in +*> The singular values from the (partial) SVD of B, sorted in *> decreasing order. *> \endverbatim *> *> \param[in] NS *> \verbatim *> NS is INTEGER -*> The number of singular values/vectors from the (partial) +*> The number of singular values/vectors from the (partial) *> SVD of B. *> \endverbatim *> @@ -110,26 +111,25 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_eig * * ===================================================================== - SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU, + SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU, $ VT, LDVT, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. - CHARACTER UPLO INTEGER LDA, LDU, LDVT, M, N, NS DOUBLE PRECISION RESID * .. diff --git a/lapack-netlib/TESTING/EIG/zchkbb.f b/lapack-netlib/TESTING/EIG/zchkbb.f index 3563f5fdee..877caffa5a 100644 --- a/lapack-netlib/TESTING/EIG/zchkbb.f +++ b/lapack-netlib/TESTING/EIG/zchkbb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB, * BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK, * LWORK, RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, * $ NRHS, NSIZES, NTYPES, NWDTHS @@ -26,7 +26,7 @@ * $ CC( LDC, * ), P( LDP, * ), Q( LDQ, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -346,12 +346,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -364,7 +364,7 @@ SUBROUTINE ZCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE, * -- LAPACK test routine (input) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/zchkbd.f b/lapack-netlib/TESTING/EIG/zchkbd.f index f126e47c83..b3d5605542 100644 --- a/lapack-netlib/TESTING/EIG/zchkbd.f +++ b/lapack-netlib/TESTING/EIG/zchkbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX, * Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, * RWORK, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * $ U( LDPT, * ), VT( LDPT, * ), WORK( * ), * $ X( LDX, * ), Y( LDX, * ), Z( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -400,12 +400,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -415,10 +415,10 @@ SUBROUTINE ZCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK, $ RWORK, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS, @@ -483,9 +483,9 @@ SUBROUTINE ZCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / - DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / - DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 / + DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, $ 0, 0, 0 / * .. * .. Executable Statements .. diff --git a/lapack-netlib/TESTING/EIG/zchkbk.f b/lapack-netlib/TESTING/EIG/zchkbk.f index cfd14de315..4f9f43cc91 100644 --- a/lapack-netlib/TESTING/EIG/zchkbk.f +++ b/lapack-netlib/TESTING/EIG/zchkbk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKBK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -21,7 +21,7 @@ *> \verbatim *> *> ZCHKBK tests ZGEBAK, a routine for backward transformation of -*> the computed right or left eigenvectors if the orginal matrix +*> the computed right or left eigenvectors if the original matrix *> was preprocessed by balance subroutine ZGEBAL. *> \endverbatim * @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZCHKBK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zchkbl.f b/lapack-netlib/TESTING/EIG/zchkbl.f index 66af6713b0..6e0a18118b 100644 --- a/lapack-netlib/TESTING/EIG/zchkbl.f +++ b/lapack-netlib/TESTING/EIG/zchkbl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKBL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZCHKBL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zchkec.f b/lapack-netlib/TESTING/EIG/zchkec.f index ed2229451c..86643969b7 100644 --- a/lapack-netlib/TESTING/EIG/zchkec.f +++ b/lapack-netlib/TESTING/EIG/zchkec.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKEC( THRESH, TSTERR, NIN, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NIN, NOUT * DOUBLE PRECISION THRESH * .. -* +* * *> \par Purpose: * ============= @@ -63,22 +63,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZCHKEC( THRESH, TSTERR, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.2) -- +* -- 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/EIG/zchkee.f b/lapack-netlib/TESTING/EIG/zchkee.f index 67221276ef..6807ef7e4b 100644 --- a/lapack-netlib/TESTING/EIG/zchkee.f +++ b/lapack-netlib/TESTING/EIG/zchkee.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZCHKEE -* +* * *> \par Purpose: * ============= @@ -1022,22 +1022,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16_eig * * ===================================================================== PROGRAM ZCHKEE * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * ===================================================================== * @@ -1102,7 +1102,8 @@ PROGRAM ZCHKEE $ ZDRGES, ZDRGEV, ZDRGSX, ZDRGVX, ZDRVBD, ZDRVES, $ ZDRVEV, ZDRVSG, ZDRVST, ZDRVSX, ZDRVVX, $ ZERRBD, ZERRED, ZERRGG, ZERRHS, ZERRST, ILAVER, - $ ZDRGES3, ZDRGEV3 + $ ZDRGES3, ZDRGEV3, + $ ZCHKST2STG, ZDRVST2STG, ZCHKHB2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1149,7 +1150,7 @@ PROGRAM ZCHKEE PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'ZHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'ZST' ) .OR. - $ LSAMEN( 3, PATH, 'ZSG' ) + $ LSAMEN( 3, PATH, 'ZSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'ZBD' ) ZEV = LSAMEN( 3, PATH, 'ZEV' ) ZES = LSAMEN( 3, PATH, 'ZES' ) @@ -1829,7 +1830,8 @@ PROGRAM ZCHKEE $ WRITE( NOUT, FMT = 9980 )'ZCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'ZST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'ZST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1859,6 +1861,17 @@ PROGRAM ZCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL ZCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), + $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), + $ DR( 1, 4 ), DR( 1, 5 ), DR( 1, 6 ), + $ DR( 1, 7 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), DR( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), + $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + ELSE CALL ZCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), @@ -1868,16 +1881,26 @@ PROGRAM ZCHKEE $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, $ RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL ZDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL ZDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, - $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), - $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), - $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), - $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) + $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRVST', INFO END IF @@ -1910,12 +1933,18 @@ PROGRAM ZCHKEE WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL ZDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, - $ INFO ) +* CALL ZDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, +* $ INFO ) + CALL ZDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ DR( 1, 3 ), DR( 1, 4 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, RWORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRVSG', INFO END IF @@ -2098,6 +2127,7 @@ PROGRAM ZCHKEE MAXTYP = 26 NTYPES = MIN( MAXTYP, NTYPES ) CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV(1,1) IF( TSTCHK .AND. TSTERR ) $ CALL ZERRGG( C3, NOUT ) DO 350 I = 1, NPARMS @@ -2156,7 +2186,7 @@ PROGRAM ZCHKEE $ WRITE( NOUT, FMT = 9980 )'ZDRGES', INFO * * Blocked version -* +* CALL ZDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2221,7 +2251,8 @@ PROGRAM ZCHKEE $ WRITE( NOUT, FMT = 9980 )'ZDRGEV', INFO * * Blocked version -* +* + CALL XLAENV(16,2) CALL ZDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), @@ -2274,10 +2305,15 @@ PROGRAM ZCHKEE CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL ZERRST( 'ZHB', NOUT ) - CALL ZCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, - $ INFO ) +* CALL ZCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, +* $ INFO ) + CALL ZCHKHB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), + $ DR( 1, 2 ), DR( 1, 3 ), DR( 1, 4 ), DR( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, + $ INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZCHKHB', INFO * @@ -2347,6 +2383,7 @@ PROGRAM ZCHKEE * GSV: Generalized Singular Value Decomposition * ---------------------------------------------- * + CALL XLAENV(1,1) IF( TSTERR ) $ CALL ZERRGG( 'GSV', NOUT ) CALL ZCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, @@ -2458,7 +2495,7 @@ PROGRAM ZCHKEE 9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ', $ 'Problem Expert Driver ZGGEVX' ) 9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, - $ ', INMIN=', I4, + $ ', INMIN=', I4, $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) diff --git a/lapack-netlib/TESTING/EIG/zchkgg.f b/lapack-netlib/TESTING/EIG/zchkgg.f index 5c554caece..2f99d76f36 100644 --- a/lapack-netlib/TESTING/EIG/zchkgg.f +++ b/lapack-netlib/TESTING/EIG/zchkgg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * S2, P1, P2, U, LDU, V, Q, Z, ALPHA1, BETA1, * ALPHA3, BETA3, EVECTL, EVECTR, WORK, LWORK, * RWORK, LLWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL TSTDIF * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES @@ -31,7 +31,7 @@ * $ T( LDA, * ), U( LDU, * ), V( LDU, * ), * $ WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -68,7 +68,7 @@ *> and each type of matrix, one matrix will be generated and used *> to test the nonsymmetric eigenroutines. For each matrix, 13 *> tests will be performed. The first twelve "test ratios" should be -*> small -- O(1). They will be compared with the threshhold THRESH: +*> small -- O(1). They will be compared with the threshold THRESH: *> *> H *> (1) | A - U H V | / ( |A| n ulp ) @@ -128,7 +128,7 @@ *> |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp *> *> In addition, the normalization of L and R are checked, and compared -*> with the threshhold THRSHN. +*> with the threshold THRSHN. *> *> Test Matrices *> ---- -------- @@ -298,7 +298,7 @@ *> \param[in] THRSHN *> \verbatim *> THRSHN is DOUBLE PRECISION -*> Threshhold for reporting eigenvector normalization error. +*> Threshold for reporting eigenvector normalization error. *> If the normalization of any eigenvector differs from 1 by *> more than THRSHN*ulp, then a special error message will be *> printed. (This is handled separately from the other tests, @@ -487,12 +487,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -503,10 +503,10 @@ SUBROUTINE ZCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA3, BETA3, EVECTL, EVECTR, WORK, LWORK, $ RWORK, LLWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. LOGICAL TSTDIF diff --git a/lapack-netlib/TESTING/EIG/zchkgk.f b/lapack-netlib/TESTING/EIG/zchkgk.f index 37a72f6a12..56a34fe0c5 100644 --- a/lapack-netlib/TESTING/EIG/zchkgk.f +++ b/lapack-netlib/TESTING/EIG/zchkgk.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKGK( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZCHKGK( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zchkgl.f b/lapack-netlib/TESTING/EIG/zchkgl.f index c0845868cc..48afa62a12 100644 --- a/lapack-netlib/TESTING/EIG/zchkgl.f +++ b/lapack-netlib/TESTING/EIG/zchkgl.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKGL( NIN, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NIN, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -41,22 +41,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZCHKGL( NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NIN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zchkhb.f b/lapack-netlib/TESTING/EIG/zchkhb.f index f923496e7c..a4c658ff3d 100644 --- a/lapack-netlib/TESTING/EIG/zchkhb.f +++ b/lapack-netlib/TESTING/EIG/zchkhb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, * LWORK, RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, * $ NWDTHS @@ -23,7 +23,7 @@ * DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ) * COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -284,12 +284,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -298,10 +298,10 @@ SUBROUTINE ZCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, $ LWORK, RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, diff --git a/lapack-netlib/TESTING/EIG/zchkhb2stg.f b/lapack-netlib/TESTING/EIG/zchkhb2stg.f new file mode 100644 index 0000000000..88c049919a --- /dev/null +++ b/lapack-netlib/TESTING/EIG/zchkhb2stg.f @@ -0,0 +1,878 @@ +*> \brief \b ZCHKHBSTG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHBSTG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RWORK RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ) +* COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHBSTG tests the reduction of a Hermitian band matrix to tridiagonal +*> from, used with the Hermitian eigenvalue problem. +*> +*> ZHBTRD factors a Hermitian band matrix A as U S U* , where * means +*> conjugate transpose, S is symmetric tridiagonal, and U is unitary. +*> ZHBTRD can use either just the lower or just the upper triangle +*> of A; ZCHKHBSTG checks both cases. +*> +*> ZHETRD_HB2ST factors a Hermitian band matrix A as U S U* , +*> where * means conjugate transpose, S is symmetric tridiagonal, and U is +*> unitary. ZHETRD_HB2ST can use either just the lower or just +*> the upper triangle of A; ZCHKHBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When ZCHKHBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the hermitian banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with +*> UPLO='U' +*> +*> (2) | I - UU* | / ( n ulp ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with +*> UPLO='L' +*> +*> (4) | I - UU* | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> ZHETRD_HB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> ZHETRD_HB2ST with UPLO='L' +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> ZCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. The values must be at least zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, ZCHKHBSTG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to ZCHKHBSTG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA, max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by ZHBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by ZHBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array, dimension (LDU, max(NN)) +*> Used to hold the unitary matrix computed by ZHBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (4) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZCHKHB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, WORK, LWORK, RWORK, RESULT, + $ INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ) + COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ TEN = 10.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N, + $ NERRS, NMATS, NMAX, NTEST, NTESTT + DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLASUM, XERBLA, ZHBT21, ZHBTRD, ZLACPY, ZLASET, + $ ZLATMR, ZLATMS, ZHETRD_HB2ST, ZSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCHKHBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, WORK, + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call ZHBTRD to compute S and U from upper triangle. +* + CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL ZHBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL ZHBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D1, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_HB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = DCONJG( A( K+1-JR, JC+JR ) ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call ZHBTRD to compute S and U from lower triangle +* + CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL ZHBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL ZHBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_HB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D3, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 )'unitary', '*', + $ 'conjugate transpose', ( '*', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZHB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' ZCHKHBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( / 1X, A3, + $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines' + $ ) + 9997 FORMAT( ' Matrix types (see DCHK23 for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of ZCHKHBSTG +* + END diff --git a/lapack-netlib/TESTING/EIG/zchkhs.f b/lapack-netlib/TESTING/EIG/zchkhs.f index a2433944e7..ec89b44f98 100644 --- a/lapack-netlib/TESTING/EIG/zchkhs.f +++ b/lapack-netlib/TESTING/EIG/zchkhs.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * W3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, * WORK, NWORK, RWORK, IWORK, SELECT, RESULT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK * DOUBLE PRECISION THRESH @@ -29,7 +29,7 @@ * $ UU( LDU, * ), UZ( LDU, * ), W1( * ), W3( * ), * $ WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -396,12 +396,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -412,10 +412,10 @@ SUBROUTINE ZCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ WORK, NWORK, RWORK, IWORK, SELECT, RESULT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK diff --git a/lapack-netlib/TESTING/EIG/zchkst.f b/lapack-netlib/TESTING/EIG/zchkst.f index d62ce26aaf..4a8636ad93 100644 --- a/lapack-netlib/TESTING/EIG/zchkst.f +++ b/lapack-netlib/TESTING/EIG/zchkst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, * LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, * $ NSIZES, NTYPES @@ -28,7 +28,7 @@ * COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), * $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -519,7 +519,7 @@ *> \verbatim *> LIWORK is INTEGER *> The number of entries in IWORK. This must be at least -*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax *> where Nmax = max( NN(j), 2 ) and lg = log base 2. *> \endverbatim *> @@ -588,12 +588,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -604,10 +604,10 @@ SUBROUTINE ZCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/zchkst2stg.f b/lapack-netlib/TESTING/EIG/zchkst2stg.f new file mode 100644 index 0000000000..cd952bc37d --- /dev/null +++ b/lapack-netlib/TESTING/EIG/zchkst2stg.f @@ -0,0 +1,2093 @@ +*> \brief \b ZCHKST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), +* $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), +* $ WA1( * ), WA2( * ), WA3( * ), WR( * ) +* COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKST2STG checks the Hermitian eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> ZHETRD. For that, we call the standard ZHETRD and compute D1 using +*> DSTEQR, then we call the 2-stage ZHETRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the ZCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> ZHETRD factors A as U S U* , where * means conjugate transpose, +*> S is real symmetric tridiagonal, and U is unitary. +*> ZHETRD can use either just the lower or just the upper triangle +*> of A; ZCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> ZHPTRD does the same as ZHETRD, except that A and V are stored +*> in "packed" format. +*> +*> ZUNGTR constructs the matrix U from the contents of V and TAU. +*> +*> ZUPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> ZSTEQR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> DSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> ZPTEQR factors S as Z4 D4 Z4* , for a +*> Hermitian positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> DSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> ZSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> ZSTEDC factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input unitary matrix, usually the output +*> from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> ZSTEMR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). ZSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When ZCHKST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the Hermitian eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... ) +*> +*> (2) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> ZHETRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> ZHETRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for ZHPTRD and ZUPGTR. +*> +*> (9) | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...) +*> +*> (10) | I - ZZ* | / ( n ulp ) ZSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) ZSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) DSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> DSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...) +*> +*> (15) | I - Z4 Z4* | / ( n ulp ) ZPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) ZPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y* | / ( |S| n ulp ) DSTEBZ, ZSTEIN +*> +*> (21) | I - Y Y* | / ( n ulp ) DSTEBZ, ZSTEIN +*> +*> (22) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('I') +*> +*> (23) | I - ZZ* | / ( n ulp ) ZSTEDC('I') +*> +*> (24) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('V') +*> +*> (25) | I - ZZ* | / ( n ulp ) ZSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) ZSTEDC('V') and +*> ZSTEDC('N') +*> +*> Test 27 is disabled at the moment because ZSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> ZSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> ZSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because ZSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'I') +*> +*> (30) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'I') vs. CSTEMR('V', 'I') +*> +*> (32) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'V') +*> +*> (33) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'V') vs. CSTEMR('V', 'V') +*> +*> (35) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'A') +*> +*> (36) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'A') vs. CSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZCHKST2STG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, ZCHKST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to ZCHKST2STG to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is COMPLEX*16 array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by ZHETRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> ZHETRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZPTEQR(V). +*> ZPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix computed by ZHETRD + ZUNGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by ZHETRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in ZHETRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as ZUNGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is COMPLEX*16 array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array of +*> dimension( max(NN) ) +*> The Householder factors computed by ZHETRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix of eigenvectors computed by ZSTEQR, +*> ZPTEQR, and ZSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The number of entries in LRWORK (dimension( ??? ) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF, +*> or ZUNMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, + $ INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), + $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ WA1( * ), WA2( * ), WA3( * ), WR( * ) + COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL CRANGE + PARAMETER ( CRANGE = .FALSE. ) + LOGICAL CREL + PARAMETER ( CREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP, + $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN, + $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3, + $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX, + $ NSPLIT, NTEST, NTESTT, LH, LW + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + DOUBLE PRECISION DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLASUM, DSTEBZ, DSTECH, DSTERF, + $ XERBLA, ZCOPY, ZHET21, ZHETRD, ZHPT21, ZHPTRD, + $ ZLACPY, ZLASET, ZLATMR, ZLATMS, ZPTEQR, ZSTEDC, + $ ZSTEMR, ZSTEIN, ZSTEQR, ZSTT21, ZSTT22, ZUNGTR, + $ ZUPGTR, ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'ZHETRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LRWEDC = 1 + 3*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LRWEDC = 7 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) + TEMP2 = SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF*TEMP2 ) THEN + A( I-1, I ) = A( I-1, I )* + $ ( HALF*TEMP2 / ( UNFL+TEMP1 ) ) + A( I, I-1 ) = DCONJG( A( I-1, I ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call ZHETRD and ZUNGTR to compute S and U from +* upper triangle. +* + CALL ZLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL ZHETRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHETRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL ZUNGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUNGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL ZHET21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 1 ) ) + CALL ZHET21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D1, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( 'U', N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 3 + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( 'L', N, N, A, LDA, V, LDU ) + CALL ZHETRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 4 + CALL ZSTEQR( 'N', N, D3, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call ZHPTRD and ZUPGTR to compute S and U from AP +* + CALL ZCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL ZHPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL ZUPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL ZHPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 5 ) ) + CALL ZHPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call ZHPTRD and ZUPGTR to compute S and U from AP +* + CALL ZCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL ZHPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL ZUPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZHPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 7 ) ) + CALL ZHPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 8 ) ) +* +* Call ZSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 9 + CALL ZSTEQR( 'V', N, D1, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 11 + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 12 + CALL DSTERF( N, D3, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL DSTECH( N, SD, SE, D1, TEMP1, RWORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL DCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 14 + CALL ZPTEQR( 'V', N, D4, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL ZSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RWORK, RESULT( 14 ) ) +* +* Compute D5 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 16 + CALL ZPTEQR( 'N', N, D5, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call DSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call ZSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call DSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL ZSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 20 ) ) +* +* Call ZSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + INDE = 1 + INDRWK = INDE + N + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 22 + CALL ZSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 22 ) ) +* +* Call ZSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 24 + CALL ZSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 24 ) ) +* +* Call ZSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 26 + CALL ZSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test ZSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call ZSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. CREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL ZSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( CRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL ZSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call ZSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + IF( CRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL ZSTEMR( 'V', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 31 + CALL ZSTEMR( 'N', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call ZSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL ZSTEMR( 'V', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, M, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL ZSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RWORK, RESULT( 32 ) ) +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 34 + CALL ZSTEMR( 'N', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call ZSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 35 +* + CALL ZSTEMR( 'V', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL ZSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RWORK, RESULT( 35 ) ) +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 37 + CALL ZSTEMR( 'N', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9987 ) + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9988 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' ZCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see ZCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 ) + 9988 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 ) +* + 9987 FORMAT( / 'Test performed: see ZCHKST2STG for details.', / ) +* End of ZCHKST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/zckcsd.f b/lapack-netlib/TESTING/EIG/zckcsd.f index 99ed5bd5de..f77b111a49 100644 --- a/lapack-netlib/TESTING/EIG/zckcsd.f +++ b/lapack-netlib/TESTING/EIG/zckcsd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, * MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, * WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * COMPLEX*16 U1( * ), U2( * ), V1T( * ), V2T( * ), * $ WORK( * ), X( * ), XF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -170,12 +170,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -184,10 +184,10 @@ SUBROUTINE ZCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, $ MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, $ WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/zckglm.f b/lapack-netlib/TESTING/EIG/zckglm.f index ed05544f72..565c747917 100644 --- a/lapack-netlib/TESTING/EIG/zckglm.f +++ b/lapack-netlib/TESTING/EIG/zckglm.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCKGLM( NN, NVAL, MVAL, PVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * DOUBLE PRECISION THRESH @@ -22,7 +22,7 @@ * COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), WORK( * ), * $ X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -168,10 +168,10 @@ SUBROUTINE ZCKGLM( NN, NVAL, MVAL, PVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zckgqr.f b/lapack-netlib/TESTING/EIG/zckgqr.f index fccac22164..2d137785b2 100644 --- a/lapack-netlib/TESTING/EIG/zckgqr.f +++ b/lapack-netlib/TESTING/EIG/zckgqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, * THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, * BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * $ BF( * ), BT( * ), BWK( * ), BZ( * ), TAUA( * ), * $ TAUB( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -197,12 +197,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -211,10 +211,10 @@ SUBROUTINE ZCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED, $ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ, $ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP diff --git a/lapack-netlib/TESTING/EIG/zckgsv.f b/lapack-netlib/TESTING/EIG/zckgsv.f index ace98cee0f..32352fc067 100644 --- a/lapack-netlib/TESTING/EIG/zckgsv.f +++ b/lapack-netlib/TESTING/EIG/zckgsv.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, * IWORK, WORK, RWORK, NIN, NOUT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), Q( * ), * $ R( * ), U( * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -184,12 +184,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -198,10 +198,10 @@ SUBROUTINE ZCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R, $ IWORK, WORK, RWORK, NIN, NOUT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT diff --git a/lapack-netlib/TESTING/EIG/zcklse.f b/lapack-netlib/TESTING/EIG/zcklse.f index a3cfa033cd..e38a4c0a85 100644 --- a/lapack-netlib/TESTING/EIG/zcklse.f +++ b/lapack-netlib/TESTING/EIG/zcklse.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, * NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT * DOUBLE PRECISION THRESH @@ -22,7 +22,7 @@ * COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), WORK( * ), * $ X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -168,10 +168,10 @@ SUBROUTINE ZCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT diff --git a/lapack-netlib/TESTING/EIG/zcsdts.f b/lapack-netlib/TESTING/EIG/zcsdts.f index bc6afb417a..c5fd68eb9a 100644 --- a/lapack-netlib/TESTING/EIG/zcsdts.f +++ b/lapack-netlib/TESTING/EIG/zcsdts.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, * LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. @@ -22,7 +22,7 @@ * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -229,10 +229,10 @@ SUBROUTINE ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q @@ -280,7 +280,7 @@ SUBROUTINE ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ ZLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) ) ELSE EPS2 = ULP @@ -446,7 +446,7 @@ SUBROUTINE ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, CALL ZHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) IF (M.GT.0) THEN - EPS2 = MAX( ULP, + EPS2 = MAX( ULP, $ ZLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) ) ELSE EPS2 = ULP @@ -553,7 +553,7 @@ SUBROUTINE ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, END DO * RETURN -* +* * End of ZCSDTS * END diff --git a/lapack-netlib/TESTING/EIG/zdrges.f b/lapack-netlib/TESTING/EIG/zdrges.f index 6e10cb1e20..c09984e091 100644 --- a/lapack-netlib/TESTING/EIG/zdrges.f +++ b/lapack-netlib/TESTING/EIG/zdrges.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, * BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES * DOUBLE PRECISION THRESH @@ -24,7 +24,7 @@ * $ BETA( * ), Q( LDQ, * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -50,7 +50,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -367,12 +367,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -381,10 +381,10 @@ SUBROUTINE ZDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES diff --git a/lapack-netlib/TESTING/EIG/zdrges3.f b/lapack-netlib/TESTING/EIG/zdrges3.f index 9a4277398b..2b3be003ca 100644 --- a/lapack-netlib/TESTING/EIG/zdrges3.f +++ b/lapack-netlib/TESTING/EIG/zdrges3.f @@ -50,7 +50,7 @@ *> number of matrix "TYPES" are specified. For each size ("N") *> and each TYPE of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following 13 tests -*> will be performed and compared with the threshhold THRESH except +*> will be performed and compared with the threshold THRESH except *> the tests (5), (11) and (13). *> *> @@ -382,7 +382,7 @@ SUBROUTINE ZDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/zdrgev.f b/lapack-netlib/TESTING/EIG/zdrgev.f index 96727449ba..2588816a56 100644 --- a/lapack-netlib/TESTING/EIG/zdrgev.f +++ b/lapack-netlib/TESTING/EIG/zdrgev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, * ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -27,7 +27,7 @@ * $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), * $ T( LDA, * ), WORK( * ), Z( LDQ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from ZGGEV: *> @@ -384,12 +384,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -399,10 +399,10 @@ SUBROUTINE ZDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/zdrgev3.f b/lapack-netlib/TESTING/EIG/zdrgev3.f index cc9526c3c9..62ddf2b56a 100644 --- a/lapack-netlib/TESTING/EIG/zdrgev3.f +++ b/lapack-netlib/TESTING/EIG/zdrgev3.f @@ -55,7 +55,7 @@ *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, a pair of matrices (A, B) will be generated *> and used for testing. For each matrix pair, the following tests -*> will be performed and compared with the threshhold THRESH. +*> will be performed and compared with the threshold THRESH. *> *> Results from ZGGEV3: *> @@ -399,7 +399,7 @@ SUBROUTINE ZDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, $ RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.6.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * February 2015 diff --git a/lapack-netlib/TESTING/EIG/zdrgsx.f b/lapack-netlib/TESTING/EIG/zdrgsx.f index 9b859e493f..51a7d773fd 100644 --- a/lapack-netlib/TESTING/EIG/zdrgsx.f +++ b/lapack-netlib/TESTING/EIG/zdrgsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI, * BI, Z, Q, ALPHA, BETA, C, LDC, S, WORK, LWORK, * RWORK, IWORK, LIWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, * $ NOUT, NSIZE @@ -26,7 +26,7 @@ * $ C( LDC, * ), Q( LDA, * ), WORK( * ), * $ Z( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -59,7 +59,7 @@ *> (need more details on what kind of read-in data are needed). *> *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH except for the tests (7) and (9): +*> compared with the threshold THRESH except for the tests (7) and (9): *> *> (1) | A - Q S Z' | / ( |A| n ulp ) *> @@ -335,12 +335,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -349,10 +349,10 @@ SUBROUTINE ZDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI, $ BI, Z, Q, ALPHA, BETA, C, LDC, S, WORK, LWORK, $ RWORK, IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN, diff --git a/lapack-netlib/TESTING/EIG/zdrgvx.f b/lapack-netlib/TESTING/EIG/zdrgvx.f index 452530feb4..4a69564514 100644 --- a/lapack-netlib/TESTING/EIG/zdrgvx.f +++ b/lapack-netlib/TESTING/EIG/zdrgvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * ALPHA, BETA, VL, VR, ILO, IHI, LSCALE, RSCALE, * S, DTRU, DIF, DIFTRU, WORK, LWORK, RWORK, * IWORK, LIWORK, RESULT, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, * $ NSIZE @@ -27,7 +27,7 @@ * $ B( LDA, * ), BETA( * ), BI( LDA, * ), * $ VL( LDA, * ), VR( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -49,7 +49,7 @@ *> corresponding the first and last eigenvalues are also know *> ``exactly'' (see ZLATM6). *> For each matrix pair, the following tests will be performed and -*> compared with the threshhold THRESH. +*> compared with the threshold THRESH. *> *> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of *> @@ -204,32 +204,32 @@ *> IHI is INTEGER *> \endverbatim *> -*> \param[out] LSCALE +*> \param[out] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] RSCALE +*> \param[out] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] S +*> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DTRU +*> \param[out] DTRU *> \verbatim *> DTRU is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DIF +*> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> -*> \param[out] DIFTRU +*> \param[out] DIFTRU *> \verbatim *> DIFTRU is DOUBLE PRECISION array, dimension (N) *> \endverbatim @@ -261,7 +261,7 @@ *> Leading dimension of IWORK. LIWORK >= N+2. *> \endverbatim *> -*> \param[out] RESULT +*> \param[out] RESULT *> \verbatim *> RESULT is DOUBLE PRECISION array, dimension (4) *> \endverbatim @@ -282,12 +282,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -297,10 +297,10 @@ SUBROUTINE ZDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI, $ S, DTRU, DIF, DIFTRU, WORK, LWORK, RWORK, $ IWORK, LIWORK, RESULT, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT, diff --git a/lapack-netlib/TESTING/EIG/zdrvbd.f b/lapack-netlib/TESTING/EIG/zdrvbd.f index 2f1e3cc38e..4bdbdfe2e9 100644 --- a/lapack-netlib/TESTING/EIG/zdrvbd.f +++ b/lapack-netlib/TESTING/EIG/zdrvbd.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S, * SSAV, E, WORK, LWORK, RWORK, IWORK, NOUNIT, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ USAV( LDU, * ), VT( LDVT, * ), * $ VTSAV( LDVT, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,7 +132,7 @@ *> *> (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the *> vector of singular values from the partial SVD -*> +*> *> Test for ZGESVDX( 'V', 'V', 'I' ) *> *> (8) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -140,7 +140,7 @@ *> (9) | I - U'U | / ( M ulp ) *> *> (10) | I - VT VT' | / ( N ulp ) -*> +*> *> Test for ZGESVDX( 'V', 'V', 'V' ) *> *> (11) | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp ) @@ -374,12 +374,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -389,10 +389,10 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ SSAV, E, WORK, LWORK, RWORK, IWORK, NOUNIT, $ INFO ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES, @@ -423,12 +423,12 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Scalars .. LOGICAL BADMM, BADNN CHARACTER JOBQ, JOBU, JOBVT, RANGE - INTEGER I, IINFO, IJQ, IJU, IJVT, IL, IU, ITEMP, IWSPC, - $ IWTMP, J, JSIZE, JTYPE, LSWORK, M, MINWRK, - $ MMAX, MNMAX, MNMIN, MTYPES, N, NERRS, NFAIL, - $ NMAX, NS, NSI, NSV, NTEST, NTESTF, NTESTT, - $ LRWORK - DOUBLE PRECISION ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV, + INTEGER I, IINFO, IJQ, IJU, IJVT, IL, IU, ITEMP, + $ IWSPC, IWTMP, J, JSIZE, JTYPE, LSWORK, M, + $ MINWRK, MMAX, MNMAX, MNMIN, MTYPES, N, + $ NERRS, NFAIL, NMAX, NS, NSI, NSV, NTEST, + $ NTESTF, NTESTT, LRWORK + DOUBLE PRECISION ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV, $ UNFL, VL, VU * .. * .. Local Arrays .. @@ -441,9 +441,9 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL DLAMCH, DLARND * .. * .. External Subroutines .. - EXTERNAL ALASVM, XERBLA, ZBDT01, ZBDT05, ZGESDD, ZGESVD, - $ ZGESVJ, ZGEJSV, ZGESVDX, ZLACPY, ZLASET, ZLATMS, - $ ZUNT01, ZUNT03 + EXTERNAL ALASVM, XERBLA, ZBDT01, ZBDT05, ZGESDD, + $ ZGESVD, ZGESVJ, ZGEJSV, ZGESVDX, ZLACPY, + $ ZLASET, ZLATMS, ZUNT01, ZUNT03 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN @@ -858,7 +858,7 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, CALL ZLACPY( 'F', M, N, ASAV, LDA, USAV, LDA ) SRNAMT = 'ZGESVJ' CALL ZGESVJ( 'G', 'U', 'V', M, N, USAV, LDA, SSAV, - & 0, A, LDVT, WORK, LWORK, RWORK, + & 0, A, LDVT, WORK, LWORK, RWORK, & LRWORK, IINFO ) * * ZGESVJ retuns V not VT, so we transpose to use the same @@ -920,7 +920,7 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, SRNAMT = 'ZGEJSV' CALL ZGEJSV( 'G', 'U', 'V', 'R', 'N', 'N', & M, N, VTSAV, LDA, SSAV, USAV, LDU, A, LDVT, - & WORK, LWORK, RWORK, + & WORK, LWORK, RWORK, & LRWORK, IWORK, IINFO ) * * ZGEJSV retuns V not VT, so we transpose to use the same @@ -968,8 +968,8 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * CALL ZLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'ZGESVDX' - CALL ZGESVDX( 'V', 'V', 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, + CALL ZGESVDX( 'V', 'V', 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, USAV, LDU, $ VTSAV, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN @@ -1018,8 +1018,8 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, RANGE = CJOBR( 1 ) CALL ZLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'ZGESVDX' - CALL ZGESVDX( JOBU, JOBVT, 'A', M, N, A, LDA, - $ VL, VU, IL, IU, NS, SSAV, U, LDU, + CALL ZGESVDX( JOBU, JOBVT, 'A', M, N, A, LDA, + $ VL, VU, IL, IU, NS, SSAV, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) * @@ -1079,15 +1079,15 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, IU = IL IL = ITEMP END IF - END IF + END IF CALL ZLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'ZGESVDX' - CALL ZGESVDX( 'V', 'V', 'I', M, N, A, LDA, - $ VL, VU, IL, IU, NSI, S, U, LDU, + CALL ZGESVDX( 'V', 'V', 'I', M, N, A, LDA, + $ VL, VU, IL, IU, NSI, S, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1109,11 +1109,11 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( MNMIN.GT.0 .AND. NSI.GT.1 ) THEN IF( IL.NE.1 ) THEN - VU = SSAV( IL ) + + VU = SSAV( IL ) + $ MAX( HALF*ABS( SSAV( IL )-SSAV( IL-1 ) ), $ ULP*ANORM, TWO*RTUNFL ) ELSE - VU = SSAV( 1 ) + + VU = SSAV( 1 ) + $ MAX( HALF*ABS( SSAV( NS )-SSAV( 1 ) ), $ ULP*ANORM, TWO*RTUNFL ) END IF @@ -1130,15 +1130,15 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, ELSE VL = ZERO VU = ONE - END IF + END IF CALL ZLACPY( 'F', M, N, ASAV, LDA, A, LDA ) SRNAMT = 'ZGESVDX' - CALL ZGESVDX( 'V', 'V', 'V', M, N, A, LDA, - $ VL, VU, IL, IU, NSV, S, U, LDU, + CALL ZGESVDX( 'V', 'V', 'V', M, N, A, LDA, + $ VL, VU, IL, IU, NSV, S, U, LDU, $ VT, LDVT, WORK, LWORK, RWORK, $ IWORK, IINFO ) IF( IINFO.NE.0 ) THEN - WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, + WRITE( NOUNIT, FMT = 9995 )'GESVDX', IINFO, M, N, $ JTYPE, LSWORK, IOLDSD INFO = ABS( IINFO ) RETURN @@ -1221,7 +1221,7 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' decreasing order, else 1/ulp', $ / '12 = | U - Upartial | / ( M ulp )', $ / '13 = | VT - VTpartial | / ( N ulp )', - $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', + $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', $ / ' ZGESVJ: ', / $ / '15 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ', $ / '16 = | I - U**T U | / ( M ulp ) ', @@ -1231,7 +1231,7 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / ' ZGESJV: ', / $ / '19 = | A - U diag(S) VT | / ( |A| max(M,N) ulp )', $ / '20 = | I - U**T U | / ( M ulp ) ', - $ / '21 = | I - VT VT**T | / ( N ulp ) ', + $ / '21 = | I - VT VT**T | / ( N ulp ) ', $ / '22 = 0 if S contains min(M,N) nonnegative values in', $ ' decreasing order, else 1/ulp', $ / ' ZGESVDX(V,V,A): ', / @@ -1250,7 +1250,7 @@ SUBROUTINE ZDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH, $ / ' ZGESVDX(V,V,V) ', $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )', $ / '34 = | I - U**T U | / ( M ulp ) ', - $ / '35 = | I - VT VT**T | / ( N ulp ) ', + $ / '35 = | I - VT VT**T | / ( N ulp ) ', $ / / ) 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1, $ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 ) diff --git a/lapack-netlib/TESTING/EIG/zdrves.f b/lapack-netlib/TESTING/EIG/zdrves.f index d2657720a2..7a625e1b75 100644 --- a/lapack-netlib/TESTING/EIG/zdrves.f +++ b/lapack-netlib/TESTING/EIG/zdrves.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, * WORK, NWORK, RWORK, IWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * COMPLEX*16 A( LDA, * ), H( LDA, * ), HT( LDA, * ), * $ VS( LDVS, * ), W( * ), WORK( * ), WT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -364,12 +364,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -378,10 +378,10 @@ SUBROUTINE ZDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, $ WORK, NWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK @@ -901,7 +901,7 @@ SUBROUTINE ZDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if W same no matter if VS computed (sort),', $ ' 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / ) + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', / ) 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ), $ ' type ', I2, ', test(', I2, ')=', G10.3 ) 9992 FORMAT( ' ZDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', diff --git a/lapack-netlib/TESTING/EIG/zdrvev.f b/lapack-netlib/TESTING/EIG/zdrvev.f index de5a03b291..e818f7ea63 100644 --- a/lapack-netlib/TESTING/EIG/zdrvev.f +++ b/lapack-netlib/TESTING/EIG/zdrvev.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, H, W, W1, VL, LDVL, VR, LDVR, * LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, * $ NTYPES, NWORK @@ -26,7 +26,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -376,12 +376,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -391,10 +391,10 @@ SUBROUTINE ZDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LRE, LDLRE, RESULT, WORK, NWORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES, diff --git a/lapack-netlib/TESTING/EIG/zdrvsg.f b/lapack-netlib/TESTING/EIG/zdrvsg.f index f2c791e8c1..8238dceef1 100644 --- a/lapack-netlib/TESTING/EIG/zdrvsg.f +++ b/lapack-netlib/TESTING/EIG/zdrvsg.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, * BP, WORK, NWORK, RWORK, LRWORK, IWORK, LIWORK, * RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -26,7 +26,7 @@ * $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -355,12 +355,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -370,10 +370,10 @@ SUBROUTINE ZDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BP, WORK, NWORK, RWORK, LRWORK, IWORK, LIWORK, $ RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/zdrvsg2stg.f b/lapack-netlib/TESTING/EIG/zdrvsg2stg.f new file mode 100644 index 0000000000..8929b33c42 --- /dev/null +++ b/lapack-netlib/TESTING/EIG/zdrvsg2stg.f @@ -0,0 +1,1382 @@ +*> \brief \b ZDRVSG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, +* $ NSIZES, NTYPES, NWORK +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D( * ), RESULT( * ), RWORK( * ) +* COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSG2STG checks the complex Hermitian generalized eigenproblem +*> drivers. +*> +*> ZHEGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> ZHEGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> ZHEGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> ZHPGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> ZHPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> ZHPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> ZHBGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> ZHBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> ZHBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> When ZDRVSG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) ZHEGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> ZHEGV and D2 is computed by +*> ZHEGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling ZHPGV +*> (3) as (1) but calling ZHBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling ZHPGV +*> (6) as (4) but calling ZHBGV +*> +*> (7) ZHEGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling ZHPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling ZHPGV +*> +*> (11) ZHEGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling ZHPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling ZHPGV +*> +*> ZHEGVD, ZHPGVD and ZHBGVD performed the same 14 tests. +*> +*> ZHEGVX, ZHPGVX and ZHBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, ZDRVSG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to ZDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX*16 array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B COMPLEX*16 array, dimension (LDB , max(NN)) +*> Used to hold the Hermitian positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z COMPLEX*16 array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of ZZ. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB COMPLEX*16 array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB COMPLEX*16 array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP COMPLEX*16 array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP COMPLEX*16 array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK COMPLEX*16 array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 2*N + N**2 where N = max( NN(j), 2 ). +*> Not modified. +*> +*> RWORK DOUBLE PRECISION array, dimension (LRWORK) +*> Workspace. +*> Modified. +*> +*> LRWORK INTEGER +*> The number of entries in RWORK. This must be at least +*> max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where +*> N = max( NN(j) ) and lg( N ) = smallest integer k such +*> that 2**k >= N . +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK)) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in IWORK. This must be at least +*> 2 + 5*max( NN(j) ). +*> Not modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LRWORK too small. +*> -25: LIWORK too small. +*> If ZLATMR, CLATMS, ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, +*> ZHPGVD, ZHEGVX, CHPGVX, ZHBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* + 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 .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, + $ NSIZES, NTYPES, NWORK + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D( * ), D2( * ), RESULT( * ), RWORK( * ) + COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 10.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL LSAME, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLAFTS, DLASUM, XERBLA, ZHBGV, ZHBGVD, + $ ZHBGVX, ZHEGV, ZHEGVD, ZHEGVX, ZHPGV, ZHPGVD, + $ ZHPGVX, ZLACPY, ZLASET, ZLATMR, ZLATMS, ZSGT01, + $ ZHEGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LRWORK ) THEN + INFO = -23 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LIWORK ) THEN + INFO = -25 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK, IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, CHBGVD, +* ZHEGVX, ZHPGVX and ZHBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL ZLATMS( N, N, 'U', ISEED, 'P', RWORK, 5, TEN, + $ ONE, KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test ZHEGV +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHEGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test ZHEGVD +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHEGVX +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL ZHEGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test ZHPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL ZHPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL ZHPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL ZHPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL ZHPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL ZHPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST ZHBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL ZHBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* TEST ZHBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL ZHBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, RWORK, + $ LRWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL ZHBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL ZHBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL ZHBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'ZSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* + 9999 FORMAT( ' ZDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* +* End of ZDRVSG2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/zdrvst.f b/lapack-netlib/TESTING/EIG/zdrvst.f index aee691fea7..cf2dc03ed3 100644 --- a/lapack-netlib/TESTING/EIG/zdrvst.f +++ b/lapack-netlib/TESTING/EIG/zdrvst.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, * LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, * IWORK, LIWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, * $ NSIZES, NTYPES @@ -26,7 +26,7 @@ * COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDU, * ), WORK( * ), Z( LDU, * ) * .. -* +* * *> \par Purpose: * ============= @@ -323,12 +323,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -338,10 +338,10 @@ SUBROUTINE ZDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, $ IWORK, LIWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/zdrvst2stg.f b/lapack-netlib/TESTING/EIG/zdrvst2stg.f new file mode 100644 index 0000000000..dbf8d8037f --- /dev/null +++ b/lapack-netlib/TESTING/EIG/zdrvst2stg.f @@ -0,0 +1,2115 @@ +*> \brief \b ZDRVST2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, +* LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ), +* $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVST2STG checks the Hermitian eigenvalue problem drivers. +*> +*> ZHEEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix, +*> using a divide-and-conquer algorithm. +*> +*> ZHEEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> ZHEEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix +*> using the Relatively Robust Representation where it can. +*> +*> ZHPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage, using a divide-and-conquer algorithm. +*> +*> ZHPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> ZHBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix, +*> using a divide-and-conquer algorithm. +*> +*> ZHBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> ZHEEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> ZHPEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> ZHBEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> When ZDRVST2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, ZDRVST2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to ZDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX*16 array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by ZSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by ZSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> WA1 DOUBLE PRECISION array, dimension +*> +*> WA2 DOUBLE PRECISION array, dimension +*> +*> WA3 DOUBLE PRECISION array, dimension +*> +*> U COMPLEX*16 array, dimension (LDU, max(NN)) +*> The unitary matrix computed by ZHETRD + ZUNGC3. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V COMPLEX*16 array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by ZHETRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU COMPLEX*16 array, dimension (max(NN)) +*> The Householder factors computed by ZHETRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z COMPLEX*16 array, dimension (LDU, max(NN)) +*> The unitary matrix of eigenvectors computed by ZHEEVD, +*> ZHEEVX, ZHPEVD, CHPEVX, ZHBEVD, and CHBEVX. +*> Modified. +*> +*> WORK - COMPLEX*16 array of dimension ( LWORK ) +*> Workspace. +*> Modified. +*> +*> LWORK - INTEGER +*> The number of entries in WORK. This must be at least +*> 2*max( NN(j), 2 )**2. +*> Not modified. +*> +*> RWORK DOUBLE PRECISION array, dimension (3*max(NN)) +*> Workspace. +*> Modified. +*> +*> LRWORK - INTEGER +*> The number of entries in RWORK. +*> +*> IWORK INTEGER array, dimension (6*max(NN)) +*> Workspace. +*> Modified. +*> +*> LIWORK - INTEGER +*> The number of entries in IWORK. +*> +*> RESULT DOUBLE PRECISION array, dimension (??) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If DLATMR, SLATMS, ZHETRD, DORGC3, ZSTEQR, DSTERF, +*> or DORMC2 returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, + $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- 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 .. + INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ), + $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ TEN = 10.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX, + $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC, + $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX, + $ NTEST, NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, DLAFTS, XERBLA, ZHBEV, ZHBEVD, + $ ZHBEVX, ZHEEV, ZHEEVD, ZHEEVR, ZHEEVX, ZHET21, + $ ZHET22, ZHPEV, ZHPEVD, ZHPEVX, ZLACPY, ZLASET, + $ ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, + $ ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, + $ ZHBEVX_2STAGE, ZHETRD_2STAGE, ZLATMR, ZLATMS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -22 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* + DO 1220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = MAX( 2*N+N*N, 2*N*N ) + LRWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 + LIWEDC = 3 + 5*N + ELSE + LWEDC = 2 + LRWEDC = 8 + LIWEDC = 8 + END IF + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1210 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 band Hermitian, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) ) + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK, + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* Perform tests storing upper or lower triangular +* part of matrix. +* + DO 1200 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* Call ZHEEVD and CHEEVX. +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL ZHEEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do tests 1 and 2. +* + CALL ZHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL ZHEEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 120 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 120 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 130 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL ZHEEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 4 and 5. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZHEEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 140 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 140 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 150 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL ZHEEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do tests 7 and 8. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL ZHEEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do test 9. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 160 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL ZHEEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* +* Do tests 10 and 11. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL ZHEEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF +* +* Do test 12. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 170 CONTINUE +* +* Call ZHPEVD and CHPEVX. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 190 J = 1, N + DO 180 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 180 CONTINUE + 190 CONTINUE + ELSE + INDX = 1 + DO 210 J = 1, N + DO 200 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 200 CONTINUE + 210 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do tests 13 and 14. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 230 J = 1, N + DO 220 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 220 CONTINUE + 230 CONTINUE + ELSE + INDX = 1 + DO 250 J = 1, N + DO 240 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 240 CONTINUE + 250 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 15. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 260 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 270 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 290 J = 1, N + DO 280 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 280 CONTINUE + 290 CONTINUE + ELSE + INDX = 1 + DO 310 J = 1, N + DO 300 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 300 CONTINUE + 310 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL ZHPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do tests 16 and 17. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 330 J = 1, N + DO 320 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 320 CONTINUE + 330 CONTINUE + ELSE + INDX = 1 + DO 350 J = 1, N + DO 340 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 340 CONTINUE + 350 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 360 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 360 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 390 J = 1, N + DO 380 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 380 CONTINUE + 390 CONTINUE + ELSE + INDX = 1 + DO 410 J = 1, N + DO 400 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 400 CONTINUE + 410 CONTINUE + END IF +* + CALL ZHPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do tests 19 and 20. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 430 J = 1, N + DO 420 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 420 CONTINUE + 430 CONTINUE + ELSE + INDX = 1 + DO 450 J = 1, N + DO 440 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 440 CONTINUE + 450 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do test 21. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 460 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 480 J = 1, N + DO 470 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 470 CONTINUE + 480 CONTINUE + ELSE + INDX = 1 + DO 500 J = 1, N + DO 490 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 490 CONTINUE + 500 CONTINUE + END IF +* + CALL ZHPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 550 + END IF + END IF +* +* Do tests 22 and 23. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 520 J = 1, N + DO 510 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 510 CONTINUE + 520 CONTINUE + ELSE + INDX = 1 + DO 540 J = 1, N + DO 530 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 530 CONTINUE + 540 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF +* +* Do test 24. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 550 CONTINUE +* +* Call ZHBEVD and CHBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 570 J = 1, N + DO 560 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 560 CONTINUE + 570 CONTINUE + ELSE + DO 590 J = 1, N + DO 580 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 580 CONTINUE + 590 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVD(V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do tests 25 and 26. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 610 J = 1, N + DO 600 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 600 CONTINUE + 610 CONTINUE + ELSE + DO 630 J = 1, N + DO 620 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 620 CONTINUE + 630 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL ZHBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, + $ Z, LDU, WORK, LWORK, RWORK, + $ LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do test 27. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 640 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 640 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 650 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 670 J = 1, N + DO 660 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 660 CONTINUE + 670 CONTINUE + ELSE + DO 690 J = 1, N + DO 680 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 680 CONTINUE + 690 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA1, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBEVX(V,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do tests 28 and 29. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 710 J = 1, N + DO 700 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 700 CONTINUE + 710 CONTINUE + ELSE + DO 730 J = 1, N + DO 720 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 720 CONTINUE + 730 CONTINUE + END IF +* + CALL ZHBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do test 30. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 740 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 740 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 750 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 770 J = 1, N + DO 760 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 760 CONTINUE + 770 CONTINUE + ELSE + DO 790 J = 1, N + DO 780 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 780 CONTINUE + 790 CONTINUE + END IF +* + CALL ZHBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVX(V,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do tests 31 and 32. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 810 J = 1, N + DO 800 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 800 CONTINUE + 810 CONTINUE + ELSE + DO 830 J = 1, N + DO 820 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 820 CONTINUE + 830 CONTINUE + END IF + CALL ZHBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do test 33. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 840 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 860 J = 1, N + DO 850 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 850 CONTINUE + 860 CONTINUE + ELSE + DO 880 J = 1, N + DO 870 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 870 CONTINUE + 880 CONTINUE + END IF + CALL ZHBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVX(V,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 930 + END IF + END IF +* +* Do tests 34 and 35. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 900 J = 1, N + DO 890 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 890 CONTINUE + 900 CONTINUE + ELSE + DO 920 J = 1, N + DO 910 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 910 CONTINUE + 920 CONTINUE + END IF + CALL ZHBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF +* +* Do test 36. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 930 CONTINUE +* +* Call ZHEEV +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL ZHEEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do tests 37 and 38 +* + CALL ZHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL ZHEEV_2STAGE( 'N', UPLO, N, A, LDU, D3, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do test 39 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 940 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 940 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 950 CONTINUE +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Call ZHPEV +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 970 J = 1, N + DO 960 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 960 CONTINUE + 970 CONTINUE + ELSE + INDX = 1 + DO 990 J = 1, N + DO 980 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 980 CONTINUE + 990 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEV( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do tests 40 and 41. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEV( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do test 42 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1040 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1040 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1050 CONTINUE +* +* Call ZHBEV +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1070 J = 1, N + DO 1060 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1060 CONTINUE + 1070 CONTINUE + ELSE + DO 1090 J = 1, N + DO 1080 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1080 CONTINUE + 1090 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEV(V,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1140 + END IF + END IF +* +* Do tests 43 and 44. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1110 J = 1, N + DO 1100 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1100 CONTINUE + 1110 CONTINUE + ELSE + DO 1130 J = 1, N + DO 1120 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1120 CONTINUE + 1130 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL ZHBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1140 + END IF + END IF +* + 1140 CONTINUE +* +* Do test 45. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1150 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + CALL ZHEEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do tests 45 and 46 (or ... ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZHEEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do test 47 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1160 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1160 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1170 CONTINUE +* + NTEST = NTEST + 1 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 48 and 49 (or +??) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 50 (or +??) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1180 CONTINUE +* + NTEST = NTEST + 1 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1190 + END IF + END IF +* +* Do tests 51 and 52 (or +??) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF +* +* Do test 52 (or +??) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* +* +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1190 CONTINUE +* + 1200 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'ZST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1210 CONTINUE + 1220 CONTINUE +* +* Summary +* + CALL ALASVM( 'ZST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' ZDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( ' ZDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', KD=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, + $ ')' ) +* + RETURN +* +* End of ZDRVST2STG +* + END diff --git a/lapack-netlib/TESTING/EIG/zdrvsx.f b/lapack-netlib/TESTING/EIG/zdrvsx.f index 742162eb84..ba3ffab6c8 100644 --- a/lapack-netlib/TESTING/EIG/zdrvsx.f +++ b/lapack-netlib/TESTING/EIG/zdrvsx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * NIUNIT, NOUNIT, A, LDA, H, HT, W, WT, WTMP, VS, * LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, * $ NTYPES @@ -26,7 +26,7 @@ * $ VS( LDVS, * ), VS1( LDVS, * ), W( * ), * $ WORK( * ), WT( * ), WTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -420,12 +420,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -435,10 +435,10 @@ SUBROUTINE ZDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES, @@ -914,7 +914,7 @@ SUBROUTINE ZDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ' 1/ulp otherwise', / $ ' 12 = 0 if W same no matter what else computed ', $ '(sort), 1/ulp otherwise', / - $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', + $ ' 13 = 0 if sorting successful, 1/ulp otherwise', $ / ' 14 = 0 if RCONDE same no matter what else computed,', $ ' 1/ulp otherwise', / $ ' 15 = 0 if RCONDv same no matter what else computed,', diff --git a/lapack-netlib/TESTING/EIG/zdrvvx.f b/lapack-netlib/TESTING/EIG/zdrvvx.f index c9ea4e0d89..9492e06230 100644 --- a/lapack-netlib/TESTING/EIG/zdrvvx.f +++ b/lapack-netlib/TESTING/EIG/zdrvvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, NWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, * $ NSIZES, NTYPES, NWORK @@ -30,7 +30,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -446,7 +446,7 @@ *> \verbatim *> INFO is INTEGER *> If 0, then successful exit. -*> If <0, then input paramter -INFO is incorrect. +*> If <0, then input parameter -INFO is incorrect. *> If >0, ZLATMR, CLATMS, CLATME or ZGET23 returned an error *> code, and INFO is its absolute value. *> @@ -480,12 +480,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * @@ -496,10 +496,10 @@ SUBROUTINE ZDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, NWORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT, diff --git a/lapack-netlib/TESTING/EIG/zerrbd.f b/lapack-netlib/TESTING/EIG/zerrbd.f index 17c20fb560..f44ef40982 100644 --- a/lapack-netlib/TESTING/EIG/zerrbd.f +++ b/lapack-netlib/TESTING/EIG/zerrbd.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRBD( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERRBD( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/zerrec.f b/lapack-netlib/TESTING/EIG/zerrec.f index 91a81f3e79..a35a0de2fe 100644 --- a/lapack-netlib/TESTING/EIG/zerrec.f +++ b/lapack-netlib/TESTING/EIG/zerrec.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERREC( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -23,7 +23,7 @@ *> *> ZERREC tests the error exits for the routines for eigen- condition *> estimation for DOUBLE PRECISION matrices: -*> ZTRSYL, CTREXC, CTRSNA and CTRSEN. +*> ZTRSYL, ZTREXC, ZTRSNA and ZTRSEN. *> \endverbatim * * Arguments: @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERREC( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -152,8 +152,8 @@ SUBROUTINE ZERREC( PATH, NUNIT ) INFOT = 1 CALL ZTREXC( 'X', 1, A, 1, B, 1, IFST, ILST, INFO ) CALL CHKXER( 'ZTREXC', INFOT, NOUT, LERR, OK ) - INFOT = 7 - CALL ZTREXC( 'N', 0, A, 1, B, 1, IFST, ILST, INFO ) + INFOT = 2 + CALL ZTREXC( 'N', -1, A, 1, B, 1, IFST, ILST, INFO ) CALL CHKXER( 'ZTREXC', INFOT, NOUT, LERR, OK ) INFOT = 4 ILST = 2 diff --git a/lapack-netlib/TESTING/EIG/zerred.f b/lapack-netlib/TESTING/EIG/zerred.f index 4079647099..00bfbf261c 100644 --- a/lapack-netlib/TESTING/EIG/zerred.f +++ b/lapack-netlib/TESTING/EIG/zerred.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRED( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERRED( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -100,7 +100,7 @@ SUBROUTINE ZERRED( PATH, NUNIT ) $ VT( NMAX, NMAX ), W( 10*NMAX ), X( NMAX ) * .. * .. External Subroutines .. - EXTERNAL CHKXER, ZGEES, ZGEESX, ZGEEV, ZGEEVX, ZGESVJ, + EXTERNAL CHKXER, ZGEES, ZGEESX, ZGEEV, ZGEEVX, ZGESVJ, $ ZGESDD, ZGESVD * .. * .. External Functions .. @@ -441,51 +441,51 @@ SUBROUTINE ZERRED( PATH, NUNIT ) * SRNAMT = 'ZGESVDX' INFOT = 1 - CALL ZGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'X', 'N', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'N', 'X', 'A', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'N', 'N', 'X', 0, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'N', 'N', 'A', -1, 0, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'N', 'N', 'A', 0, -1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL ZGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, + CALL ZGESVDX( 'N', 'N', 'A', 2, 1, A, 1, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, + CALL ZGESVDX( 'N', 'N', 'V', 2, 1, A, 2, -ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL ZGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, + CALL ZGESVDX( 'N', 'N', 'V', 2, 1, A, 2, ONE, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL ZGESVDX( 'N', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 0, 1, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL ZGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, + CALL ZGESVDX( 'V', 'N', 'I', 2, 2, A, 2, ZERO, ZERO, $ 1, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL ZGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, + CALL ZGESVDX( 'V', 'N', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) - INFOT = 16 - CALL ZGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, + INFOT = 17 + CALL ZGESVDX( 'N', 'V', 'A', 2, 2, A, 2, ZERO, ZERO, $ 0, 0, NS, S, U, 1, VT, 1, W, 1, RW, IW, INFO ) CALL CHKXER( 'ZGESVDX', INFOT, NOUT, LERR, OK ) NT = 12 diff --git a/lapack-netlib/TESTING/EIG/zerrgg.f b/lapack-netlib/TESTING/EIG/zerrgg.f index 3366c77165..0e3a861df3 100644 --- a/lapack-netlib/TESTING/EIG/zerrgg.f +++ b/lapack-netlib/TESTING/EIG/zerrgg.f @@ -50,17 +50,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date June 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERRGG( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* June 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,7 +83,7 @@ SUBROUTINE ZERRGG( PATH, NUNIT ) * .. * .. Local Arrays .. LOGICAL BW( NMAX ), SEL( NMAX ) - INTEGER IW( LW ) + INTEGER IW( LW ), IDUM(NMAX) DOUBLE PRECISION LS( NMAX ), R1( NMAX ), R2( NMAX ), $ RCE( NMAX ), RCV( NMAX ), RS( NMAX ), RW( LW ) COMPLEX*16 A( NMAX, NMAX ), ALPHA( NMAX ), @@ -214,7 +214,7 @@ SUBROUTINE ZERRGG( PATH, NUNIT ) $ INFO ) CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) NT = NT + 9 -* +* * ZHGEQZ * SRNAMT = 'ZHGEQZ' @@ -306,57 +306,57 @@ SUBROUTINE ZERRGG( PATH, NUNIT ) SRNAMT = 'ZGGSVD3' INFOT = 1 CALL ZGGSVD3( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGGSVD3( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGGSVD3( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGGSVD3( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGGSVD3( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZGGSVD3( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGGSVD3( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZGGSVD3( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 16 CALL ZGGSVD3( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 18 CALL ZGGSVD3( 'N', 'V', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 2, V, 1, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 2, V, 1, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL ZGGSVD3( 'N', 'N', 'Q', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, - $ 2, R1, R2, U, 2, V, 2, Q, 1, W, RW, IW, LWORK, + $ 2, R1, R2, U, 2, V, 2, Q, 1, W, LWORK, RW, IDUM, $ INFO ) CALL CHKXER( 'ZGGSVD3', INFOT, NOUT, LERR, OK ) NT = NT + 11 @@ -573,56 +573,56 @@ SUBROUTINE ZERRGG( PATH, NUNIT ) INFOT = 7 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ -1, 0, 0, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, -1, A, 1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, -1, A, 1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, -1, A, $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, - $ 1, A, 1, A, 1, A, + $ 1, A, 1, A, 1, RS, $ A, 1, A, 1, A, 1, A, $ -1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) diff --git a/lapack-netlib/TESTING/EIG/zerrhs.f b/lapack-netlib/TESTING/EIG/zerrhs.f index ab36b649cb..4949ceaa56 100644 --- a/lapack-netlib/TESTING/EIG/zerrhs.f +++ b/lapack-netlib/TESTING/EIG/zerrhs.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRHS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERRHS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/EIG/zerrst.f b/lapack-netlib/TESTING/EIG/zerrst.f index a3e992e27c..38fc857935 100644 --- a/lapack-netlib/TESTING/EIG/zerrst.f +++ b/lapack-netlib/TESTING/EIG/zerrst.f @@ -1,20 +1,22 @@ *> \brief \b ZERRST * +* @precisions fortran z -> c +* * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRST( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -25,6 +27,9 @@ *> ZUNGTR, ZUPMTR, ZSTEQR, CSTEIN, ZPTEQR, ZHBTRD, *> ZHEEV, CHEEVX, CHEEVD, ZHBEV, CHBEVX, CHBEVD, *> ZHPEV, CHPEVX, CHPEVD, and ZSTEDC. +*> ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, +*> ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, +*> ZHBEVX_2STAGE, ZHETRD_2STAGE *> \endverbatim * * Arguments: @@ -45,22 +50,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZERRST( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -93,7 +98,10 @@ SUBROUTINE ZERRST( PATH, NUNIT ) EXTERNAL CHKXER, ZHBEV, ZHBEVD, ZHBEVX, ZHBTRD, ZHEEV, $ ZHEEVD, ZHEEVR, ZHEEVX, ZHETRD, ZHPEV, ZHPEVD, $ ZHPEVX, ZHPTRD, ZPTEQR, ZSTEDC, ZSTEIN, ZSTEQR, - $ ZUNGTR, ZUNMTR, ZUPGTR, ZUPMTR + $ ZUNGTR, ZUNMTR, ZUPGTR, ZUPMTR, + $ ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, + $ ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, + $ ZHBEVX_2STAGE, ZHETRD_2STAGE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -151,6 +159,103 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHETRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* ZHETRD_2STAGE +* + SRNAMT = 'ZHETRD_2STAGE' + INFOT = 1 + CALL ZHETRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHETRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* ZHETRD_HE2HB +* + SRNAMT = 'ZHETRD_HE2HB' + INFOT = 1 + CALL ZHETRD_HE2HB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HE2HB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HE2HB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HE2HB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HE2HB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRD_HE2HB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* ZHETRD_HB2ST +* + SRNAMT = 'ZHETRD_HB2ST' + INFOT = 1 + CALL ZHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * ZUNGTR * SRNAMT = 'ZUNGTR' @@ -377,6 +482,63 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHEEVD', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* ZHEEVD_2STAGE +* + SRNAMT = 'ZHEEVD_2STAGE' + INFOT = 1 + CALL ZHEEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3, +* $ RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 0, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 18, IW, 12, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 1, IW, 0, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 25, IW, 11, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * ZHEEV * SRNAMT = 'ZHEEV ' @@ -397,6 +559,29 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHEEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* ZHEEV_2STAGE +* + SRNAMT = 'ZHEEV_2STAGE ' + INFOT = 1 + CALL ZHEEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHEEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEV_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * ZHEEVX * SRNAMT = 'ZHEEVX' @@ -441,6 +626,65 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHEEVX', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* ZHEEVX_2STAGE +* + SRNAMT = 'ZHEEVX_2STAGE' + INFOT = 1 + CALL ZHEEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + INFOT = 4 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHEEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I1, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * ZHEEVR * SRNAMT = 'ZHEEVR' @@ -508,6 +752,90 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHEEVR', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* ZHEEVR_2STAGE +* + SRNAMT = 'ZHEEVR_2STAGE' + N = 1 + INFOT = 1 + CALL ZHEEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHEEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHEEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N-1, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N-1, IW( 2*N-1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 22 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N, IW, 10*N-1, + $ INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * ZHPEVD * SRNAMT = 'ZHPEVD' @@ -646,6 +974,47 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* ZHETRD_HB2ST +* + SRNAMT = 'ZHETRD_HB2ST' + INFOT = 1 + CALL ZHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * ZHBEVD * SRNAMT = 'ZHBEVD' @@ -711,6 +1080,75 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 15 * +* ZHBEVD_2STAGE +* + SRNAMT = 'ZHBEVD_2STAGE' + INFOT = 1 + CALL ZHBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, + $ W, 2, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 0, + $ W, 8, RW, 25, IW, 12, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 1, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 2, RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 2, IW, 12, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 2, IW, 0, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 15 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 25, IW, 2, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * ZHBEV * SRNAMT = 'ZHBEV ' @@ -734,6 +1172,43 @@ SUBROUTINE ZERRST( PATH, NUNIT ) CALL CHKXER( 'ZHBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* ZHBEV_2STAGE +* + SRNAMT = 'ZHBEV_2STAGE ' + INFOT = 1 + CALL ZHBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 0, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * ZHBEVX * SRNAMT = 'ZHBEVX' @@ -781,6 +1256,74 @@ SUBROUTINE ZERRST( PATH, NUNIT ) $ 0, 0.0D0, M, X, Z, 1, W, RW, IW, I3, INFO ) CALL CHKXER( 'ZHBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 11 +* +* ZHBEVX_2STAGE +* + SRNAMT = 'ZHBEVX_2STAGE' + INFOT = 1 + CALL ZHBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 1 + CALL ZHBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 4 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL ZHBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, +* $ 0.0D0, 0.0D0, 0, 0, 0.0D0, +* $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) +* CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/EIG/zget02.f b/lapack-netlib/TESTING/EIG/zget02.f index 5479139319..b157379a89 100644 --- a/lapack-netlib/TESTING/EIG/zget02.f +++ b/lapack-netlib/TESTING/EIG/zget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -133,10 +133,10 @@ SUBROUTINE ZGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/EIG/zget10.f b/lapack-netlib/TESTING/EIG/zget10.f index 53765d4e25..ee7fcbb51a 100644 --- a/lapack-netlib/TESTING/EIG/zget10.f +++ b/lapack-netlib/TESTING/EIG/zget10.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET10( M, N, A, LDA, B, LDB, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, M, N * DOUBLE PRECISION RESULT @@ -18,7 +18,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -87,22 +87,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZGET10( M, N, A, LDA, B, LDB, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, M, N diff --git a/lapack-netlib/TESTING/EIG/zget22.f b/lapack-netlib/TESTING/EIG/zget22.f index 570d25bb06..68e16baaaa 100644 --- a/lapack-netlib/TESTING/EIG/zget22.f +++ b/lapack-netlib/TESTING/EIG/zget22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER TRANSA, TRANSE, TRANSW * INTEGER LDA, LDE, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION RESULT( 2 ), RWORK( * ) * COMPLEX*16 A( LDA, * ), E( LDE, * ), W( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -143,10 +143,10 @@ SUBROUTINE ZGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANSA, TRANSE, TRANSW diff --git a/lapack-netlib/TESTING/EIG/zget23.f b/lapack-netlib/TESTING/EIG/zget23.f index 773cb5714d..39fe152996 100644 --- a/lapack-netlib/TESTING/EIG/zget23.f +++ b/lapack-netlib/TESTING/EIG/zget23.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -13,7 +13,7 @@ * LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, * RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, * WORK, LWORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * CHARACTER BALANC @@ -31,7 +31,7 @@ * $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -352,12 +352,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -368,10 +368,10 @@ SUBROUTINE ZGET23( COMP, ISRT, BALANC, JTYPE, THRESH, ISEED, $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/zget24.f b/lapack-netlib/TESTING/EIG/zget24.f index ea2241304e..1641a018c1 100644 --- a/lapack-netlib/TESTING/EIG/zget24.f +++ b/lapack-netlib/TESTING/EIG/zget24.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * H, HT, W, WT, WTMP, VS, LDVS, VS1, RCDEIN, * RCDVIN, NSLCT, ISLCT, ISRT, RESULT, WORK, * LWORK, RWORK, BWORK, INFO ) -* +* * .. Scalar Arguments .. * LOGICAL COMP * INTEGER INFO, ISRT, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, @@ -27,7 +27,7 @@ * $ VS( LDVS, * ), VS1( LDVS, * ), W( * ), * $ WORK( * ), WT( * ), WTMP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -320,12 +320,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -335,10 +335,10 @@ SUBROUTINE ZGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, $ RCDVIN, NSLCT, ISLCT, ISRT, RESULT, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL COMP diff --git a/lapack-netlib/TESTING/EIG/zget35.f b/lapack-netlib/TESTING/EIG/zget35.f index c4ed5c1f5b..2ea73a2c59 100644 --- a/lapack-netlib/TESTING/EIG/zget35.f +++ b/lapack-netlib/TESTING/EIG/zget35.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET35( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZGET35( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN, NINFO diff --git a/lapack-netlib/TESTING/EIG/zget36.f b/lapack-netlib/TESTING/EIG/zget36.f index f5dff9496c..d5bc06ea91 100644 --- a/lapack-netlib/TESTING/EIG/zget36.f +++ b/lapack-netlib/TESTING/EIG/zget36.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET36( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, LMAX, NIN, NINFO * DOUBLE PRECISION RMAX * .. -* +* * *> \par Purpose: * ============= @@ -73,22 +73,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZGET36( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, LMAX, NIN, NINFO diff --git a/lapack-netlib/TESTING/EIG/zget37.f b/lapack-netlib/TESTING/EIG/zget37.f index 4bc8d3c93a..85aaf79496 100644 --- a/lapack-netlib/TESTING/EIG/zget37.f +++ b/lapack-netlib/TESTING/EIG/zget37.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET37( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * DOUBLE PRECISION RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZGET37( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/zget38.f b/lapack-netlib/TESTING/EIG/zget38.f index 347681fbe6..c88a383bd0 100644 --- a/lapack-netlib/TESTING/EIG/zget38.f +++ b/lapack-netlib/TESTING/EIG/zget38.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET38( RMAX, LMAX, NINFO, KNT, NIN ) -* +* * .. Scalar Arguments .. * INTEGER KNT, NIN * .. @@ -17,7 +17,7 @@ * INTEGER LMAX( 3 ), NINFO( 3 ) * DOUBLE PRECISION RMAX( 3 ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZGET38( RMAX, LMAX, NINFO, KNT, NIN ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KNT, NIN diff --git a/lapack-netlib/TESTING/EIG/zget51.f b/lapack-netlib/TESTING/EIG/zget51.f index 628914ca79..96b1dfae4c 100644 --- a/lapack-netlib/TESTING/EIG/zget51.f +++ b/lapack-netlib/TESTING/EIG/zget51.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER ITYPE, LDA, LDB, LDU, LDV, N * DOUBLE PRECISION RESULT @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -154,10 +154,10 @@ SUBROUTINE ZGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ITYPE, LDA, LDB, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/zget52.f b/lapack-netlib/TESTING/EIG/zget52.f index 8dc4d91f90..75126d33d3 100644 --- a/lapack-netlib/TESTING/EIG/zget52.f +++ b/lapack-netlib/TESTING/EIG/zget52.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * LOGICAL LEFT * INTEGER LDA, LDB, LDE, N @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), E( LDE, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -47,7 +47,7 @@ *> supposed to be normalized so that the maximum "absolute value" *> of its elements is 1, where in this case, "absolute value" *> of a complex value x is |Re(x)| + |Im(x)| ; let us call this -*> maximum "absolute value" norm of a vector v M(v). +*> maximum "absolute value" norm of a vector v M(v). *> If a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate *> vector. The normalization test is: *> @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -162,10 +162,10 @@ SUBROUTINE ZGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHA, BETA, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LEFT diff --git a/lapack-netlib/TESTING/EIG/zget54.f b/lapack-netlib/TESTING/EIG/zget54.f index 2ca0389d3b..106e29074c 100644 --- a/lapack-netlib/TESTING/EIG/zget54.f +++ b/lapack-netlib/TESTING/EIG/zget54.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, * LDV, WORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N * DOUBLE PRECISION RESULT @@ -20,7 +20,7 @@ * $ T( LDT, * ), U( LDU, * ), V( LDV, * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -156,10 +156,10 @@ SUBROUTINE ZGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, $ LDV, WORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N diff --git a/lapack-netlib/TESTING/EIG/zglmts.f b/lapack-netlib/TESTING/EIG/zglmts.f index 469f8d26a4..344ae3a096 100644 --- a/lapack-netlib/TESTING/EIG/zglmts.f +++ b/lapack-netlib/TESTING/EIG/zglmts.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U, * WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * DOUBLE PRECISION RESULT * .. * .. Array Arguments .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -146,10 +146,10 @@ SUBROUTINE ZGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U, $ WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/zgqrts.f b/lapack-netlib/TESTING/EIG/zgqrts.f index 1e00659b68..c963dee93c 100644 --- a/lapack-netlib/TESTING/EIG/zgqrts.f +++ b/lapack-netlib/TESTING/EIG/zgqrts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. @@ -21,7 +21,7 @@ * $ R( LDA, * ), T( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( LWORK ), Z( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -176,10 +176,10 @@ SUBROUTINE ZGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/zgrqts.f b/lapack-netlib/TESTING/EIG/zgrqts.f index 9575ba3f62..3a14737239 100644 --- a/lapack-netlib/TESTING/EIG/zgrqts.f +++ b/lapack-netlib/TESTING/EIG/zgrqts.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, * BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. @@ -21,7 +21,7 @@ * $ R( LDA, * ), T( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( LWORK ), Z( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -176,10 +176,10 @@ SUBROUTINE ZGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T, $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/zgsvts3.f b/lapack-netlib/TESTING/EIG/zgsvts3.f index 8a5c2d4cc5..fa9bb38d94 100644 --- a/lapack-netlib/TESTING/EIG/zgsvts3.f +++ b/lapack-netlib/TESTING/EIG/zgsvts3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, * LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P * .. @@ -22,7 +22,7 @@ * $ BF( LDB, * ), Q( LDQ, * ), R( LDR, * ), * $ U( LDU, * ), V( LDV, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -195,10 +195,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date August 2015 * @@ -209,7 +209,7 @@ SUBROUTINE ZGSVTS3( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V, $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * August 2015 diff --git a/lapack-netlib/TESTING/EIG/zhbt21.f b/lapack-netlib/TESTING/EIG/zhbt21.f index 0933d72671..4cd8ed9f73 100644 --- a/lapack-netlib/TESTING/EIG/zhbt21.f +++ b/lapack-netlib/TESTING/EIG/zhbt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KA, KS, LDA, LDU, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION D( * ), E( * ), RESULT( 2 ), RWORK( * ) * COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -150,10 +150,10 @@ SUBROUTINE ZHBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zhet21.f b/lapack-netlib/TESTING/EIG/zhet21.f index 680d4044bc..32a09741e4 100644 --- a/lapack-netlib/TESTING/EIG/zhet21.f +++ b/lapack-netlib/TESTING/EIG/zhet21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHET21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, * LDV, TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, N @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -211,10 +211,10 @@ SUBROUTINE ZHET21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, $ LDV, TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zhet22.f b/lapack-netlib/TESTING/EIG/zhet22.f index 82137bdd0a..7237f43f7a 100644 --- a/lapack-netlib/TESTING/EIG/zhet22.f +++ b/lapack-netlib/TESTING/EIG/zhet22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHET22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, * V, LDV, TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,12 +146,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -159,10 +159,10 @@ SUBROUTINE ZHET22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, $ V, LDV, TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zhpt21.f b/lapack-netlib/TESTING/EIG/zhpt21.f index a840c164d8..f9268661ac 100644 --- a/lapack-netlib/TESTING/EIG/zhpt21.f +++ b/lapack-netlib/TESTING/EIG/zhpt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, * TAU, WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, KBAND, LDU, N @@ -20,7 +20,7 @@ * COMPLEX*16 AP( * ), TAU( * ), U( LDU, * ), VP( * ), * $ WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -210,12 +210,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -223,10 +223,10 @@ SUBROUTINE ZHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, $ TAU, WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zhst01.f b/lapack-netlib/TESTING/EIG/zhst01.f index da55e2a47f..b98045fab0 100644 --- a/lapack-netlib/TESTING/EIG/zhst01.f +++ b/lapack-netlib/TESTING/EIG/zhst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, * LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), H( LDH, * ), Q( LDQ, * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -140,10 +140,10 @@ SUBROUTINE ZHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, $ LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N diff --git a/lapack-netlib/TESTING/EIG/zlarfy.f b/lapack-netlib/TESTING/EIG/zlarfy.f index 9b9b80b60e..57605731bf 100644 --- a/lapack-netlib/TESTING/EIG/zlarfy.f +++ b/lapack-netlib/TESTING/EIG/zlarfy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCV, LDC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zlarhs.f b/lapack-netlib/TESTING/EIG/zlarhs.f index 6180d632f9..76bd2cb2ae 100644 --- a/lapack-netlib/TESTING/EIG/zlarhs.f +++ b/lapack-netlib/TESTING/EIG/zlarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -209,10 +209,10 @@ SUBROUTINE ZLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/EIG/zlatm4.f b/lapack-netlib/TESTING/EIG/zlatm4.f index d0b39e2be5..429404f2f8 100644 --- a/lapack-netlib/TESTING/EIG/zlatm4.f +++ b/lapack-netlib/TESTING/EIG/zlatm4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATM4( ITYPE, N, NZ1, NZ2, RSIGN, AMAGN, RCOND, * TRIANG, IDIST, ISEED, A, LDA ) -* +* * .. Scalar Arguments .. * LOGICAL RSIGN * INTEGER IDIST, ITYPE, LDA, N, NZ1, NZ2 @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -171,10 +171,10 @@ SUBROUTINE ZLATM4( ITYPE, N, NZ1, NZ2, RSIGN, AMAGN, RCOND, $ TRIANG, IDIST, ISEED, A, LDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL RSIGN diff --git a/lapack-netlib/TESTING/EIG/zlctes.f b/lapack-netlib/TESTING/EIG/zlctes.f index 1306180d8f..4b471b751b 100644 --- a/lapack-netlib/TESTING/EIG/zlctes.f +++ b/lapack-netlib/TESTING/EIG/zlctes.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION ZLCTES( Z, D ) -* +* * .. Scalar Arguments .. * COMPLEX*16 D, Z * .. -* +* * *> \par Purpose: * ============= @@ -25,7 +25,7 @@ *> eigenvalue is negative), and otherwise it returns .FALSE.. *> *> It is used by the test routine ZDRGES to test whether the driver -*> routine ZGGES succesfully sorts eigenvalues. +*> routine ZGGES successfully sorts eigenvalues. *> \endverbatim * * Arguments: @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * * ===================================================================== LOGICAL FUNCTION ZLCTES( Z, D ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. COMPLEX*16 D, Z diff --git a/lapack-netlib/TESTING/EIG/zlctsx.f b/lapack-netlib/TESTING/EIG/zlctsx.f index 11be2dd14e..9f30e61fe1 100644 --- a/lapack-netlib/TESTING/EIG/zlctsx.f +++ b/lapack-netlib/TESTING/EIG/zlctsx.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION ZLCTSX( ALPHA, BETA ) -* +* * .. Scalar Arguments .. * COMPLEX*16 ALPHA, BETA * .. -* +* * *> \par Purpose: * ============= @@ -45,22 +45,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * * ===================================================================== LOGICAL FUNCTION ZLCTSX( ALPHA, BETA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA diff --git a/lapack-netlib/TESTING/EIG/zlsets.f b/lapack-netlib/TESTING/EIG/zlsets.f index 06b11ffd7f..6f324ea80e 100644 --- a/lapack-netlib/TESTING/EIG/zlsets.f +++ b/lapack-netlib/TESTING/EIG/zlsets.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF, * X, WORK, LWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. -* +* * *> \par Purpose: * ============= @@ -138,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -151,10 +151,10 @@ SUBROUTINE ZLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF, $ X, WORK, LWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, P diff --git a/lapack-netlib/TESTING/EIG/zsbmv.f b/lapack-netlib/TESTING/EIG/zsbmv.f index 6b8dbb45bb..6438825507 100644 --- a/lapack-netlib/TESTING/EIG/zsbmv.f +++ b/lapack-netlib/TESTING/EIG/zsbmv.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, K, LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -152,10 +152,10 @@ SUBROUTINE ZSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zsgt01.f b/lapack-netlib/TESTING/EIG/zsgt01.f index b89f8c867c..e512253db6 100644 --- a/lapack-netlib/TESTING/EIG/zsgt01.f +++ b/lapack-netlib/TESTING/EIG/zsgt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, * WORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER ITYPE, LDA, LDB, LDZ, M, N @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), * $ Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -152,10 +152,10 @@ SUBROUTINE ZSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, $ WORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/EIG/zslect.f b/lapack-netlib/TESTING/EIG/zslect.f index a01308db93..519c7764f2 100644 --- a/lapack-netlib/TESTING/EIG/zslect.f +++ b/lapack-netlib/TESTING/EIG/zslect.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION ZSLECT( Z ) -* +* * .. Scalar Arguments .. * COMPLEX*16 Z * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,8 @@ *> *> ZSLECT returns .TRUE. if the eigenvalue Z is to be selected, *> otherwise it returns .FALSE. -*> It is used by ZCHK41 to test if ZGEES succesfully sorts eigenvalues, -*> and by ZCHK43 to test if ZGEESX succesfully sorts eigenvalues. +*> It is used by ZCHK41 to test if ZGEES successfully sorts eigenvalues, +*> and by ZCHK43 to test if ZGEESX successfully sorts eigenvalues. *> *> The common block /SSLCT/ controls how eigenvalues are selected. *> If SELOPT = 0, then ZSLECT return .TRUE. when real(Z) is less than @@ -44,22 +44,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_eig * * ===================================================================== LOGICAL FUNCTION ZSLECT( Z ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. COMPLEX*16 Z diff --git a/lapack-netlib/TESTING/EIG/zstt21.f b/lapack-netlib/TESTING/EIG/zstt21.f index 562a5a2c37..ad1fe5529a 100644 --- a/lapack-netlib/TESTING/EIG/zstt21.f +++ b/lapack-netlib/TESTING/EIG/zstt21.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, * RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, N * .. @@ -19,7 +19,7 @@ * $ SD( * ), SE( * ) * COMPLEX*16 U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -132,10 +132,10 @@ SUBROUTINE ZSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, $ RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, N diff --git a/lapack-netlib/TESTING/EIG/zstt22.f b/lapack-netlib/TESTING/EIG/zstt22.f index 546562f427..c0f684fc37 100644 --- a/lapack-netlib/TESTING/EIG/zstt22.f +++ b/lapack-netlib/TESTING/EIG/zstt22.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, * LDWORK, RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER KBAND, LDU, LDWORK, M, N * .. @@ -19,7 +19,7 @@ * $ SD( * ), SE( * ) * COMPLEX*16 U( LDU, * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -132,12 +132,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -145,10 +145,10 @@ SUBROUTINE ZSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, $ LDWORK, RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KBAND, LDU, LDWORK, M, N diff --git a/lapack-netlib/TESTING/EIG/zunt01.f b/lapack-netlib/TESTING/EIG/zunt01.f index e440463b08..d2d64227f3 100644 --- a/lapack-netlib/TESTING/EIG/zunt01.f +++ b/lapack-netlib/TESTING/EIG/zunt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZUNT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER ROWCOL * INTEGER LDU, LWORK, M, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 U( LDU, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -126,10 +126,10 @@ SUBROUTINE ZUNT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER ROWCOL diff --git a/lapack-netlib/TESTING/EIG/zunt03.f b/lapack-netlib/TESTING/EIG/zunt03.f index fa1dfb8d4a..4560410a30 100644 --- a/lapack-netlib/TESTING/EIG/zunt03.f +++ b/lapack-netlib/TESTING/EIG/zunt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZUNT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, * RWORK, RESULT, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) RC * INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 U( LDU, * ), V( LDV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_eig * @@ -162,10 +162,10 @@ SUBROUTINE ZUNT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK, $ RWORK, RESULT, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) RC diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index 7c36ab3a9e..715f32ec27 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -1,40 +1,42 @@ -set(ALINTST - aladhd.f alaerh.f alaesm.f alahd.f alareq.f +set(ALINTST + aladhd.f alaerh.f alaesm.f alahd.f alareq.f alasum.f alasvm.f chkxer.f icopy.f ilaenv.f xlaenv.f xerbla.f) set(SCLNTST slaord.f) -set(DZLNTST dlaord.f ) - -set(SLINTST schkaa.f - schkeq.f schkgb.f schkge.f schkgt.f - schklq.f schkpb.f schkpo.f schkps.f schkpp.f - schkpt.f schkq3.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schktb.f schktp.f schktr.f - schktz.f - sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f - serrgt.f serrlq.f serrls.f - serrpo.f serrps.f serrql.f serrqp.f serrqr.f - serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f - sgbt01.f sgbt02.f sgbt05.f sgelqs.f sgeqls.f sgeqrs.f - sgerqs.f sget01.f sget02.f - sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f - sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f - slattr.f slavsp.f slavsy.f slavsy_rook.f slqt01.f slqt02.f - slqt03.f spbt01.f spbt02.f spbt05.f spot01.f - spot02.f spot03.f spot05.f spst01.f sppt01.f - sppt02.f sppt03.f sppt05.f sptt01.f sptt02.f - sptt05.f sqlt01.f sqlt02.f sqlt03.f sqpt01.f - sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f - sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f - srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f ssyt01_rook.f - stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f - stpt02.f stpt03.f stpt05.f stpt06.f strt01.f - strt02.f strt03.f strt05.f strt06.f - sgennd.f - sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f) +set(DZLNTST dlaord.f) + +set(SLINTST schkaa.f + schkeq.f schkgb.f schkge.f schkgt.f + schklq.f schkpb.f schkpo.f schkps.f schkpp.f + schkpt.f schkq3.f schkql.f schkqr.f schkrq.f + schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schktb.f schktp.f schktr.f + schktz.f + sdrvgt.f sdrvls.f sdrvpb.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_rk.f sdrvsy_aa.f + serrgt.f serrlq.f serrls.f + serrpo.f serrps.f serrql.f serrqp.f serrqr.f + serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f + sgbt01.f sgbt02.f sgbt05.f sgelqs.f sgeqls.f sgeqrs.f + sgerqs.f sget01.f sget02.f + sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f + sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f + slattr.f slavsp.f slavsy.f slavsy_rook.f slqt01.f slqt02.f + slqt03.f spbt01.f spbt02.f spbt05.f spot01.f + spot02.f spot03.f spot05.f spst01.f sppt01.f + sppt02.f sppt03.f sppt05.f sptt01.f sptt02.f + sptt05.f sqlt01.f sqlt02.f sqlt03.f sqpt01.f + sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f + sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f + srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f + sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f + stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f + stpt02.f stpt03.f stpt05.f stpt06.f strt01.f + strt02.f strt03.f strt05.f strt06.f + sgennd.f + sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f + schklqt.f schklqtp.f schktsqr.f + serrlqt.f serrlqtp.f serrtsqr.f stsqr01.f slqt04.f slqt05.f) if(USEXBLAS) list(APPEND SLINTST sdrvgex.f serrgex.f sdrvgbx.f sdrvpox.f sebchvxx.f) @@ -42,184 +44,192 @@ else() list(APPEND SLINTST sdrvge.f serrge.f sdrvgb.f sdrvpo.f) endif() -set(CLINTST cchkaa.f - cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhe_rook.f cchkhp.f cchklq.f cchkpb.f - cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f - cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f - cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhp.f - cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f - cdrvsp.f cdrvsy.f cdrvsy_rook.f - cerrgt.f cerrhe.f cerrlq.f - cerrls.f cerrps.f cerrql.f cerrqp.f - cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f - cerrvx.f - cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f - cgerqs.f cget01.f cget02.f - cget03.f cget04.f cget07.f cgtt01.f cgtt02.f - cgtt05.f chet01.f chet01_rook.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f - clatsp.f clatsy.f clattb.f clattp.f clattr.f - clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f - clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f - cpot01.f cpot02.f cpot03.f cpot05.f cpst01.f - cppt01.f cppt02.f cppt03.f cppt05.f cptt01.f - cptt02.f cptt05.f cqlt01.f cqlt02.f cqlt03.f - cqpt01.f cqrt01.f cqrt01p.f cqrt02.f cqrt03.f cqrt11.f - cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f - cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f - csbmv.f cspt01.f - cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt02.f csyt03.f - ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f - ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f - ctrt02.f ctrt03.f ctrt05.f ctrt06.f +set(CLINTST cchkaa.f + cchkeq.f cchkgb.f cchkge.f cchkgt.f + cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhp.f cchklq.f cchkpb.f + cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f + cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchktb.f + cchktp.f cchktr.f cchktz.f + cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_rk.f cdrvhe_aa.f cdrvhp.f + cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f + cdrvsp.f cdrvsy.f cdrvsy_rook.f cdrvsy_rk.f cdrvsy_aa.f + cerrgt.f cerrhe.f cerrlq.f + cerrls.f cerrps.f cerrql.f cerrqp.f + cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f + cerrvx.f + cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f + cgerqs.f cget01.f cget02.f + cget03.f cget04.f cget07.f cgtt01.f cgtt02.f + cgtt05.f chet01.f chet01_rook.f chet01_3.f chet01_aa.f + chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f + clatsp.f clatsy.f clattb.f clattp.f clattr.f + clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f + clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f + cpot01.f cpot02.f cpot03.f cpot05.f cpst01.f + cppt01.f cppt02.f cppt03.f cppt05.f cptt01.f + cptt02.f cptt05.f cqlt01.f cqlt02.f cqlt03.f + cqpt01.f cqrt01.f cqrt01p.f cqrt02.f cqrt03.f cqrt11.f + cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f + cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f + csbmv.f cspt01.f + cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt01_3.f csyt01_aa.f csyt02.f csyt03.f + ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f + ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f + ctrt02.f ctrt03.f ctrt05.f ctrt06.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 + cerrlqt.f cerrlqtp.f cerrtsqr.f ctsqr01.f clqt04.f clqt05.f) if(USEXBLAS) - list(APPEND + list(APPEND CLINTST cdrvgex.f cdrvgbx.f cerrgex.f cdrvpox.f cerrpox.f cebchvxx.f) else() list(APPEND CLINTST cdrvge.f cdrvgb.f cerrge.f cdrvpo.f cerrpo.f) endif() -set(DLINTST dchkaa.f - dchkeq.f dchkgb.f dchkge.f dchkgt.f - dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f - dchkpt.f dchkq3.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchktb.f dchktp.f dchktr.f - dchktz.f - ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f - derrgt.f derrlq.f derrls.f - derrps.f derrql.f derrqp.f derrqr.f - derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f - dgbt01.f dgbt02.f dgbt05.f dgelqs.f dgeqls.f dgeqrs.f - dgerqs.f dget01.f dget02.f - dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f - dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f - dlattr.f dlavsp.f dlavsy.f dlavsy_rook.f dlqt01.f dlqt02.f - dlqt03.f dpbt01.f dpbt02.f dpbt05.f dpot01.f - dpot02.f dpot03.f dpot05.f dpst01.f dppt01.f - dppt02.f dppt03.f dppt05.f dptt01.f dptt02.f - dptt05.f dqlt01.f dqlt02.f dqlt03.f dqpt01.f - dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f - dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f - drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f - dspt01.f dsyt01.f dsyt01_rook.f - dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f - dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f - dtrt02.f dtrt03.f dtrt05.f dtrt06.f +set(DLINTST dchkaa.f + dchkeq.f dchkgb.f dchkge.f dchkgt.f + dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f + dchkpt.f dchkq3.f dchkql.f dchkqr.f dchkrq.f + dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchktb.f dchktp.f dchktr.f + dchktz.f + ddrvgt.f ddrvls.f ddrvpb.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_rk.f ddrvsy_aa.f + derrgt.f derrlq.f derrls.f + derrps.f derrql.f derrqp.f derrqr.f + derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f + dgbt01.f dgbt02.f dgbt05.f dgelqs.f dgeqls.f dgeqrs.f + dgerqs.f dget01.f dget02.f + dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f + dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f + dlattr.f dlavsp.f dlavsy.f dlavsy_rook.f dlqt01.f dlqt02.f + dlqt03.f dpbt01.f dpbt02.f dpbt05.f dpot01.f + dpot02.f dpot03.f dpot05.f dpst01.f dppt01.f + dppt02.f dppt03.f dppt05.f dptt01.f dptt02.f + dptt05.f dqlt01.f dqlt02.f dqlt03.f dqpt01.f + dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f + dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f + drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f + dspt01.f dsyt01.f dsyt01_rook.f dsyt01_3.f dsyt01_aa.f + dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f + dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f + dtrt02.f dtrt03.f dtrt05.f dtrt06.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 + derrlqt.f derrlqtp.f derrtsqr.f dtsqr01.f dlqt04.f dlqt05.f) if(USEXBLAS) - list(APPEND - DLINTST ddrvgex.f ddrvgbx.f derrgex.f ddrvpox.f derrpox.f debchvxx.f) + list(APPEND + DLINTST ddrvgex.f ddrvgbx.f derrgex.f ddrvpox.f derrpox.f debchvxx.f) else() list(APPEND - DLINTST ddrvge.f ddrvgb.f derrge.f ddrvpo.f derrpo.f) + DLINTST ddrvge.f ddrvgb.f derrge.f ddrvpo.f derrpo.f) endif() -set(ZLINTST zchkaa.f - zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhe_rook.f zchkhp.f zchklq.f zchkpb.f - zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f - zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f - zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhp.f - zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f - zdrvsp.f zdrvsy.f zdrvsy_rook.f - zerrgt.f zerrhe.f zerrlq.f - zerrls.f zerrps.f zerrql.f zerrqp.f - zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f - zerrvx.f - zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f - zgerqs.f zget01.f zget02.f - zget03.f zget04.f zget07.f zgtt01.f zgtt02.f - zgtt05.f zhet01.f zhet01.f zhet01_rook.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f - zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f - zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f - zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f - zpot01.f zpot02.f zpot03.f zpot05.f zpst01.f - zppt01.f zppt02.f zppt03.f zppt05.f zptt01.f - zptt02.f zptt05.f zqlt01.f zqlt02.f zqlt03.f - zqpt01.f zqrt01.f zqrt01p.f zqrt02.f zqrt03.f zqrt11.f - zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f - zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f - zsbmv.f zspt01.f - zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt02.f zsyt03.f - ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f - ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f - ztrt02.f ztrt03.f ztrt05.f ztrt06.f +set(ZLINTST zchkaa.f + zchkeq.f zchkgb.f zchkge.f zchkgt.f + zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhp.f zchklq.f zchkpb.f + zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f + zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchktb.f + zchktp.f zchktr.f zchktz.f + zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_rk.f zdrvhe_aa.f zdrvhp.f + zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f + zdrvsp.f zdrvsy.f zdrvsy_rook.f zdrvsy_rk.f zdrvsy_aa.f + zerrgt.f zerrhe.f zerrlq.f + zerrls.f zerrps.f zerrql.f zerrqp.f + zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f + zerrvx.f + zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f + zgerqs.f zget01.f zget02.f + zget03.f zget04.f zget07.f zgtt01.f zgtt02.f + zgtt05.f zhet01.f zhet01_rook.f zhet01_3.f zhet01_aa.f + zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f + zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f + zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f + zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f + zpot01.f zpot02.f zpot03.f zpot05.f zpst01.f + zppt01.f zppt02.f zppt03.f zppt05.f zptt01.f + zptt02.f zptt05.f zqlt01.f zqlt02.f zqlt03.f + zqpt01.f zqrt01.f zqrt01p.f zqrt02.f zqrt03.f zqrt11.f + zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f + zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f + zsbmv.f zspt01.f + zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt01_3.f zsyt01_aa.f zsyt02.f zsyt03.f + ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f + ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f + ztrt02.f ztrt03.f ztrt05.f ztrt06.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 + zerrlqt.f zerrlqtp.f zerrtsqr.f ztsqr01.f zlqt04.f zlqt05.f) if(USEXBLAS) list(APPEND - ZLINTST zdrvgex.f zdrvgbx.f zerrgex.f zdrvpox.f zerrpox.f zebchvxx.f) + ZLINTST zdrvgex.f zdrvgbx.f zerrgex.f zdrvpox.f zerrpox.f zebchvxx.f) else() list(APPEND - ZLINTST zdrvge.f zdrvgb.f zerrge.f zdrvpo.f zerrpo.f) + ZLINTST zdrvge.f zdrvgb.f zerrge.f zdrvpo.f zerrpo.f) endif() -set(DSLINTST dchkab.f - ddrvab.f ddrvac.f derrab.f derrac.f dget08.f - alaerh.f alahd.f aladhd.f alareq.f - chkxer.f dlarhs.f dlatb4.f xerbla.f +set(DSLINTST dchkab.f + ddrvab.f ddrvac.f derrab.f derrac.f dget08.f + alaerh.f alahd.f aladhd.f alareq.f + chkxer.f dlarhs.f dlatb4.f xerbla.f dget02.f dpot06.f) -set(ZCLINTST zchkab.f - zdrvab.f zdrvac.f zerrab.f zerrac.f zget08.f - alaerh.f alahd.f aladhd.f alareq.f - chkxer.f zget02.f zlarhs.f zlatb4.f +set(ZCLINTST zchkab.f + zdrvab.f zdrvac.f zerrab.f zerrac.f zget08.f + alaerh.f alahd.f aladhd.f alareq.f + chkxer.f zget02.f zlarhs.f zlatb4.f zsbmv.f xerbla.f zpot06.f zlaipd.f) -set(SLINTSTRFP schkrfp.f sdrvrfp.f sdrvrf1.f sdrvrf2.f sdrvrf3.f sdrvrf4.f serrrfp.f - slatb4.f slarhs.f sget04.f spot01.f spot03.f spot02.f - chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f ) +set(SLINTSTRFP schkrfp.f sdrvrfp.f sdrvrf1.f sdrvrf2.f sdrvrf3.f sdrvrf4.f serrrfp.f + slatb4.f slarhs.f sget04.f spot01.f spot03.f spot02.f + chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f) -set(DLINTSTRFP dchkrfp.f ddrvrfp.f ddrvrf1.f ddrvrf2.f ddrvrf3.f ddrvrf4.f derrrfp.f - dlatb4.f dlarhs.f dget04.f dpot01.f dpot03.f dpot02.f - chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f ) +set(DLINTSTRFP dchkrfp.f ddrvrfp.f ddrvrf1.f ddrvrf2.f ddrvrf3.f ddrvrf4.f derrrfp.f + dlatb4.f dlarhs.f dget04.f dpot01.f dpot03.f dpot02.f + chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f) -set(CLINTSTRFP cchkrfp.f cdrvrfp.f cdrvrf1.f cdrvrf2.f cdrvrf3.f cdrvrf4.f cerrrfp.f - claipd.f clatb4.f clarhs.f csbmv.f cget04.f cpot01.f cpot03.f cpot02.f - chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f ) +set(CLINTSTRFP cchkrfp.f cdrvrfp.f cdrvrf1.f cdrvrf2.f cdrvrf3.f cdrvrf4.f cerrrfp.f + claipd.f clatb4.f clarhs.f csbmv.f cget04.f cpot01.f cpot03.f cpot02.f + chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f) -set(ZLINTSTRFP zchkrfp.f zdrvrfp.f zdrvrf1.f zdrvrf2.f zdrvrf3.f zdrvrf4.f zerrrfp.f - zlatb4.f zlaipd.f zlarhs.f zsbmv.f zget04.f zpot01.f zpot03.f zpot02.f - chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f ) +set(ZLINTSTRFP zchkrfp.f zdrvrfp.f zdrvrf1.f zdrvrf2.f zdrvrf3.f zdrvrf4.f zerrrfp.f + zlatb4.f zlaipd.f zlarhs.f zsbmv.f zget04.f zpot01.f zpot03.f zpot02.f + chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f) -macro(add_lin_executable name ) +macro(add_lin_executable name) add_executable(${name} ${ARGN}) target_link_libraries(${name} tmglib ${LAPACK_LIBRARIES}) -endmacro(add_lin_executable) +endmacro() -IF(BUILD_SINGLE) -add_lin_executable(xlintsts ${ALINTST} ${SCLNTST} ${SLINTST} ${SECOND_SRC} ) -add_lin_executable(xlintstrfs ${SLINTSTRFP} ${SECOND_SRC}) +if(BUILD_SINGLE) + add_lin_executable(xlintsts ${ALINTST} ${SCLNTST} ${SLINTST} ${SECOND_SRC}) + add_lin_executable(xlintstrfs ${SLINTSTRFP} ${SECOND_SRC}) endif() if(BUILD_DOUBLE) -add_lin_executable(xlintstd ${ALINTST} ${DLINTST} ${DZLNTST} ${DSECOND_SRC}) -add_lin_executable(xlintstrfd ${DLINTSTRFP} ${DSECOND_SRC}) + add_lin_executable(xlintstd ${ALINTST} ${DLINTST} ${DZLNTST} ${DSECOND_SRC}) + add_lin_executable(xlintstrfd ${DLINTSTRFP} ${DSECOND_SRC}) endif() -IF(BUILD_SINGLE AND BUILD_DOUBLE) -add_lin_executable(xlintstds ${DSLINTST} ${SECOND_SRC} ${DSECOND_SRC} ) +if(BUILD_SINGLE AND BUILD_DOUBLE) + add_lin_executable(xlintstds ${DSLINTST} ${SECOND_SRC} ${DSECOND_SRC}) endif() if(BUILD_COMPLEX) -add_lin_executable(xlintstc ${ALINTST} ${CLINTST} ${SCLNTST} ${SECOND_SRC} ) -add_lin_executable(xlintstrfc ${CLINTSTRFP} ${SECOND_SRC}) + add_lin_executable(xlintstc ${ALINTST} ${CLINTST} ${SCLNTST} ${SECOND_SRC}) + add_lin_executable(xlintstrfc ${CLINTSTRFP} ${SECOND_SRC}) endif() if(BUILD_COMPLEX16) -add_lin_executable(xlintstz ${ALINTST} ${ZLINTST} ${DZLNTST} ${DSECOND_SRC}) -add_lin_executable(xlintstrfz ${ZLINTSTRFP} ${DSECOND_SRC}) + add_lin_executable(xlintstz ${ALINTST} ${ZLINTST} ${DZLNTST} ${DSECOND_SRC}) + add_lin_executable(xlintstrfz ${ZLINTSTRFP} ${DSECOND_SRC}) endif() -IF(BUILD_COMPLEX AND BUILD_COMPLEX16) -add_lin_executable(xlintstzc ${ZCLINTST} ${SECOND_SRC} ${DSECOND_SRC} ) +if(BUILD_COMPLEX AND BUILD_COMPLEX16) + add_lin_executable(xlintstzc ${ZCLINTST} ${SECOND_SRC} ${DSECOND_SRC}) endif() diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 09d514e5d8..bd188b20b3 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -35,7 +35,7 @@ include ../../make.inc ####################################################################### ifneq ($(strip $(VARLIB)),) - LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB) + LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB) endif @@ -43,18 +43,18 @@ ALINTST = \ aladhd.o alaerh.o alaesm.o alahd.o alareq.o \ alasum.o alasvm.o chkxer.o icopy.o ilaenv.o xlaenv.o xerbla.o -SCLNTST= slaord.o +SCLNTST = slaord.o -DZLNTST= dlaord.o +DZLNTST = dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \ + schksp.o schksy.o schksy_rook.o schksy_rk.o schksy_aa.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_rk.o sdrvsy_aa.o \ serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ @@ -70,11 +70,13 @@ SLINTST = schkaa.o \ sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \ srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \ - sspt01.o ssyt01.o ssyt01_rook.o \ + sspt01.o ssyt01.o ssyt01_rook.o ssyt01_3.o ssyt01_aa.o \ stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \ stpt02.o stpt03.o stpt05.o stpt06.o strt01.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 \ + serrlqt.o serrlqtp.o serrtsqr.o stsqr01.o slqt04.o slqt05.o ifdef USEXBLAS SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \ @@ -86,20 +88,21 @@ endif CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ - cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \ + cchkhe.o cchkhe_rook.o cchkhe_rk.o cchkhe_aa.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ - cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \ + cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o cchksy_aa.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgt.o cdrvhe_rook.o cdrvhp.o \ + cdrvgt.o cdrvhe_rook.o cdrvhe_rk.o cdrvhe_aa.o cdrvhp.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ - cdrvsp.o cdrvsy_rook.o \ + cdrvsp.o cdrvsy_rook.o cdrvsy_rk.o cdrvsy_aa.o \ cerrgt.o cerrlq.o \ cerrls.o cerrps.o cerrql.o cerrqp.o \ cerrqr.o cerrrq.o cerrtr.o cerrtz.o \ cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \ cgerqs.o cget01.o cget02.o \ cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \ - cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ + cgtt05.o chet01.o chet01_rook.o chet01_3.o \ + chet01_aa.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ clatsp.o clatsy.o clattb.o clattp.o clattr.o \ clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ @@ -110,12 +113,14 @@ CLINTST = cchkaa.o \ cqrt12.o cqrt13.o cqrt14.o cqrt15.o cqrt16.o \ cqrt17.o crqt01.o crqt02.o crqt03.o crzt01.o crzt02.o \ csbmv.o cspt01.o \ - cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt02.o csyt03.o \ + cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt01_3.o csyt01_aa.o csyt02.o csyt03.o \ ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \ ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.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 \ + cerrlqt.o cerrlqtp.o cerrtsqr.o ctsqr01.o clqt04.o clqt05.o ifdef USEXBLAS CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o \ @@ -129,10 +134,10 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \ + dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o dchksy_aa.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_rk.o ddrvsy_aa.o \ derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ @@ -145,15 +150,17 @@ DLINTST = dchkaa.o \ dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \ dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \ dptt05.o dqlt01.o dqlt02.o dqlt03.o dqpt01.o \ - dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ + dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \ drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \ - dspt01.o dsyt01.o dsyt01_rook.o \ + dspt01.o dsyt01.o dsyt01_rook.o dsyt01_3.o dsyt01_aa.o \ dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \ dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.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 \ + derrlqt.o derrlqtp.o derrtsqr.o dtsqr01.o dlqt04.o dlqt05.o ifdef USEXBLAS DLINTST += derrvxx.o ddrvgex.o ddrvsyx.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o \ @@ -165,20 +172,21 @@ endif ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ - zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \ + zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ - zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \ + zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o zchksy_aa.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgt.o zdrvhe_rook.o zdrvhp.o \ + zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ - zdrvsp.o zdrvsy_rook.o \ + zdrvsp.o zdrvsy_rook.o zdrvsy_rk.o zdrvsy_aa.o \ zerrgt.o zerrlq.o \ zerrls.o zerrps.o zerrql.o zerrqp.o \ zerrqr.o zerrrq.o zerrtr.o zerrtz.o \ zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \ zgerqs.o zget01.o zget02.o \ zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \ - zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ + zgtt05.o zhet01.o zhet01_rook.o zhet01_3.o \ + zhet01_aa.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \ zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ @@ -189,12 +197,14 @@ ZLINTST = zchkaa.o \ zqrt12.o zqrt13.o zqrt14.o zqrt15.o zqrt16.o \ zqrt17.o zrqt01.o zrqt02.o zrqt03.o zrzt01.o zrzt02.o \ zsbmv.o zspt01.o \ - zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt02.o zsyt03.o \ + zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt01_3.o zsyt01_aa.o zsyt02.o zsyt03.o \ ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \ ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.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 \ + zerrlqt.o zerrlqtp.o zerrtsqr.o ztsqr01.o zlqt04.o zlqt05.o ifdef USEXBLAS ZLINTST += zerrvxx.o zdrvgex.o zdrvsyx.o zdrvgbx.o zerrgex.o zdrvpox.o zdrvhex.o \ @@ -205,114 +215,84 @@ ZLINTST += zerrvx.o zdrvge.o zdrvsy.o zdrvgb.o zerrge.o zdrvpo.o \ endif DSLINTST = dchkab.o \ - ddrvab.o ddrvac.o derrab.o derrac.o dget08.o \ + ddrvab.o ddrvac.o derrab.o derrac.o dget08.o \ alaerh.o alahd.o aladhd.o alareq.o \ chkxer.o dlarhs.o dlatb4.o xerbla.o \ dget02.o dpot06.o ZCLINTST = zchkab.o \ - zdrvab.o zdrvac.o zerrab.o zerrac.o zget08.o \ + zdrvab.o zdrvac.o zerrab.o zerrac.o zget08.o \ alaerh.o alahd.o aladhd.o alareq.o \ chkxer.o zget02.o zlarhs.o zlatb4.o \ zsbmv.o xerbla.o zpot06.o zlaipd.o SLINTSTRFP = schkrfp.o sdrvrfp.o sdrvrf1.o sdrvrf2.o sdrvrf3.o sdrvrf4.o serrrfp.o \ slatb4.o slarhs.o sget04.o spot01.o spot03.o spot02.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 DLINTSTRFP = dchkrfp.o ddrvrfp.o ddrvrf1.o ddrvrf2.o ddrvrf3.o ddrvrf4.o derrrfp.o \ dlatb4.o dlarhs.o dget04.o dpot01.o dpot03.o dpot02.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 CLINTSTRFP = cchkrfp.o cdrvrfp.o cdrvrf1.o cdrvrf2.o cdrvrf3.o cdrvrf4.o cerrrfp.o \ claipd.o clatb4.o clarhs.o csbmv.o cget04.o cpot01.o cpot03.o cpot02.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 ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp.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 -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 single: ../xlintsts -double: ../xlintstd +double: ../xlintstd complex: ../xlintstc -complex16: ../xlintstz +complex16: ../xlintstz proto-single: ../xlintstrfs proto-double: ../xlintstds ../xlintstrfd proto-complex: ../xlintstrfc proto-complex16: ../xlintstzc ../xlintstrfz -xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(SLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - -xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - -xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $^ \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - -xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ - -xlintstds : $(DSLINTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(DSLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -xlintstzc : $(ZCLINTST) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(ZCLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -xlintstrfs : $(SLINTSTRFP) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(SLINTSTRFP) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -xlintstrfd : $(DLINTSTRFP) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(DLINTSTRFP) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -xlintstrfc : $(CLINTSTRFP) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(CLINTSTRFP) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -xlintstrfz : $(ZLINTSTRFP) ../../$(LAPACKLIB) - $(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ - -../xlintsts: xlintsts - mv xlintsts $@ - -../xlintstc: xlintstc - mv xlintstc $@ - -../xlintstz: xlintstz - mv xlintstz $@ - -../xlintstd: xlintstd - mv xlintstd $@ - -../xlintstds: xlintstds - mv xlintstds $@ - -../xlintstzc: xlintstzc - mv xlintstzc $@ - -../xlintstrfs: xlintstrfs - mv xlintstrfs $@ - -../xlintstrfc: xlintstrfc - mv xlintstrfc $@ - -../xlintstrfd: xlintstrfd - mv xlintstrfd $@ - -../xlintstrfz: xlintstrfz - mv xlintstrfz $@ +../xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(ALINTST) $(SCLNTST) $(SLINTST) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + +../xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(ALINTST) $(SCLNTST) $(CLINTST) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + +../xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $^ \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + +../xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(ALINTST) $(DZLNTST) $(ZLINTST) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) + +../xlintstds: $(DSLINTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(DSLINTST) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) + +../xlintstzc: $(ZCLINTST) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(ZCLINTST) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) + +../xlintstrfs: $(SLINTSTRFP) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(SLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) + +../xlintstrfd: $(DLINTSTRFP) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(DLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) + +../xlintstrfc: $(CLINTSTRFP) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(CLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) + +../xlintstrfz: $(ZLINTSTRFP) ../../$(LAPACKLIB) + $(LOADER) $(LOADOPTS) -o $@ $(ZLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(ALINTST): $(FRC) $(SCLNTST): $(FRC) @@ -324,18 +304,20 @@ $(ZLINTST): $(FRC) FRC: @FRC=$(FRC) - + clean: rm -f *.o schkaa.o: schkaa.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< dchkaa.o: dchkaa.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< cchkaa.o: cchkaa.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< zchkaa.o: zchkaa.f - $(FORTRAN) $(DRVOPTS) -c $< -o $@ - -.f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + $(FORTRAN) $(DRVOPTS) -c -o $@ $< + +.f.o: + $(FORTRAN) $(OPTS) -c -o $@ $< + +.NOTPARALLEL: diff --git a/lapack-netlib/TESTING/LIN/aladhd.f b/lapack-netlib/TESTING/LIN/aladhd.f index b2bb2e0389..a31621db2d 100644 --- a/lapack-netlib/TESTING/LIN/aladhd.f +++ b/lapack-netlib/TESTING/LIN/aladhd.f @@ -50,13 +50,25 @@ *> _SY: Symmetric indefinite, *> with partial (Bunch-Kaufman) pivoting *> _SR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _SK: Symmetric indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting +*> _HA: (complex) Hermitian , +*> Assen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting *> _HR: (complex) Hermitian indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _HK: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _HP: (complex) Hermitian indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> The first character must be one of S, D, C, or Z (C or Z only @@ -71,17 +83,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALADHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -255,10 +267,16 @@ SUBROUTINE ALADHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN * * SR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* SK: Symmetric indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' * @@ -275,7 +293,27 @@ SUBROUTINE ALADHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN +* +* HA: Hermitian +* Aasen algorithm + WRITE( IOUNIT, FMT = 9971 )PATH, 'Hermitian' +* + WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) + WRITE( IOUNIT, FMT = 9983 ) +* + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 9974 )1 + WRITE( IOUNIT, FMT = 9980 )2 + WRITE( IOUNIT, FMT = 9979 )3 + WRITE( IOUNIT, FMT = 9977 )4 + WRITE( IOUNIT, FMT = 9978 )5 + WRITE( IOUNIT, FMT = 9976 )6 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) + + + ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. + $ LSAMEN( 2, P2, 'HP' ) ) THEN * * HE: Hermitian indefinite full * with partial (Bunch-Kaufman) pivoting algorithm @@ -300,10 +338,16 @@ SUBROUTINE ALADHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HK' ) ) THEN * * HR: Hermitian indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* HK: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' * @@ -336,6 +380,8 @@ SUBROUTINE ALADHD( IOUNIT, PATH ) $ ' positive definite band matrices' ) 9993 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite tridiagonal' ) + 9971 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices', + $ ', "Aasen" Algorithm' ) 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices', $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) 9991 FORMAT( / 1X, A3, ' drivers: ', A9, diff --git a/lapack-netlib/TESTING/LIN/alaerh.f b/lapack-netlib/TESTING/LIN/alaerh.f index 2f58e85c81..5677940c89 100644 --- a/lapack-netlib/TESTING/LIN/alaerh.f +++ b/lapack-netlib/TESTING/LIN/alaerh.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * N5, IMAT, NFAIL, NERRS, NOUT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * CHARACTER*( * ) SUBNAM @@ -18,7 +18,7 @@ * INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS, * $ NFAIL, NOUT * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup aux_lin * @@ -147,10 +147,10 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, $ N5, IMAT, NFAIL, NERRS, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -489,17 +489,28 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * ELSE IF( LSAMEN( 2, P2, 'SY' ) $ .OR. LSAMEN( 2, P2, 'SR' ) + $ .OR. LSAMEN( 2, P2, 'SK' ) $ .OR. LSAMEN( 2, P2, 'HE' ) - $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN + $ .OR. LSAMEN( 2, P2, 'HR' ) + $ .OR. LSAMEN( 2, P2, 'HK' ) + $ .OR. LSAMEN( 2, P2, 'HA' ) ) THEN * * xSY: symmetric indefinite matrices * with partial (Bunch-Kaufman) pivoting; * xSR: symmetric indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; +* xSK: symmetric indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting, +* new storage format; * xHE: Hermitian indefinite matrices * with partial (Bunch-Kaufman) pivoting. * xHR: Hermitian indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; +* xHK: Hermitian indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting, +* new storage format; +* xHA: Hermitian matrices +* Aasen Algorithm * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN diff --git a/lapack-netlib/TESTING/LIN/alaesm.f b/lapack-netlib/TESTING/LIN/alaesm.f index 3af32da83b..6e01f2490f 100644 --- a/lapack-netlib/TESTING/LIN/alaesm.f +++ b/lapack-netlib/TESTING/LIN/alaesm.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAESM( PATH, OK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL OK * CHARACTER*3 PATH * INTEGER NOUT * .. -* +* * *> \par Purpose: * ============= @@ -51,22 +51,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALAESM( PATH, OK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL OK diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f index 8d56c798ba..8f4cd58dac 100644 --- a/lapack-netlib/TESTING/LIN/alahd.f +++ b/lapack-netlib/TESTING/LIN/alahd.f @@ -50,13 +50,25 @@ *> _SY: Symmetric indefinite, *> with partial (Bunch-Kaufman) pivoting *> _SR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _SK: Symmetric indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting +*> _HA: (complex) Hermitian , +*> with Aasen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting -*> _HR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _HR: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> _HK: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _HP: (complex) Hermitian indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> _TR: Triangular @@ -86,17 +98,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALAHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -302,10 +314,16 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN * * SR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* SK: Symmetric indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9892 )PATH, 'Symmetric' * @@ -354,6 +372,28 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9957 )7 WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN +* +* HA: Hermitian, +* with Assen Algorithm +* + WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' +* + WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) + WRITE( IOUNIT, FMT = 9972 ) +* + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 9953 )1 + WRITE( IOUNIT, FMT = 9961 )2 + WRITE( IOUNIT, FMT = 9960 )3 + WRITE( IOUNIT, FMT = 9960 )4 + WRITE( IOUNIT, FMT = 9959 )5 + WRITE( IOUNIT, FMT = 9958 )6 + WRITE( IOUNIT, FMT = 9956 )7 + WRITE( IOUNIT, FMT = 9957 )8 + WRITE( IOUNIT, FMT = 9955 )9 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN * @@ -377,10 +417,16 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HR' ) ) THEN * -* HR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* HR: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* HK: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9892 )PATH, 'Hermitian' * @@ -633,6 +679,45 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 8020 ) 4 WRITE( IOUNIT, FMT = 8021 ) 5 WRITE( IOUNIT, FMT = 8022 ) 6 +* + ELSE IF( LSAMEN( 2, P2, 'TQ' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8002 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8023 ) 1 + WRITE( IOUNIT, FMT = 8024 ) 2 + WRITE( IOUNIT, FMT = 8025 ) 3 + WRITE( IOUNIT, FMT = 8026 ) 4 + WRITE( IOUNIT, FMT = 8027 ) 5 + WRITE( IOUNIT, FMT = 8028 ) 6 +* + ELSE IF( LSAMEN( 2, P2, 'XQ' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8003 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8029 ) 1 + WRITE( IOUNIT, FMT = 8030 ) 2 + WRITE( IOUNIT, FMT = 8031 ) 3 + WRITE( IOUNIT, FMT = 8032 ) 4 + WRITE( IOUNIT, FMT = 8033 ) 5 + WRITE( IOUNIT, FMT = 8034 ) 6 +* + ELSE IF( LSAMEN( 2, P2, 'TS' ) ) THEN +* +* QRT (triangular-pentagonal) +* + WRITE( IOUNIT, FMT = 8004 ) PATH + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8035 ) 1 + WRITE( IOUNIT, FMT = 8036 ) 2 + WRITE( IOUNIT, FMT = 8037 ) 3 + WRITE( IOUNIT, FMT = 8038 ) 4 + WRITE( IOUNIT, FMT = 8039 ) 5 + WRITE( IOUNIT, FMT = 8040 ) 6 * ELSE * @@ -674,6 +759,11 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) 8000 FORMAT( / 1X, A3, ': QRT factorization for general matrices' ) 8001 FORMAT( / 1X, A3, ': QRT factorization for ', $ 'triangular-pentagonal matrices' ) + 8002 FORMAT( / 1X, A3, ': LQT factorization for general matrices' ) + 8003 FORMAT( / 1X, A3, ': LQT factorization for ', + $ 'triangular-pentagonal matrices' ) + 8004 FORMAT( / 1X, A3, ': TS factorization for ', + $ 'tall-skiny or short-wide matrices' ) * * GE matrix types * @@ -946,7 +1036,8 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRZF):' ) 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6' ) 9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1, - $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD)' ) + $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD, 15-16: ' + $ A1, 'GETSLS)') 9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' ) 9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X, $ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' ) @@ -966,6 +1057,30 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) 8021 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) 8022 FORMAT(3X,I2, $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8023 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' ) + 8024 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' ) + 8025 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8026 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8027 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8028 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8029 FORMAT(3X,I2,': norm( L - A*Q'' ) / ( (M+N) * norm(A) * EPS )' ) + 8030 FORMAT(3X,I2,': norm( I - Q*Q'' ) / ( (M+N) * EPS )' ) + 8031 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8032 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8033 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8034 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + 8035 FORMAT(3X,I2,': norm( R - Q''*A ) / ( (M+N) * norm(A) * EPS )' ) + 8036 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( (M+N) * EPS )' ) + 8037 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) + 8038 FORMAT(3X,I2, + $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') + 8039 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) + 8040 FORMAT(3X,I2, + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/alareq.f b/lapack-netlib/TESTING/LIN/alareq.f index 4bbef51e0c..e1b084debc 100644 --- a/lapack-netlib/TESTING/LIN/alareq.f +++ b/lapack-netlib/TESTING/LIN/alareq.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NIN, NMATS, NOUT, NTYPES @@ -17,7 +17,7 @@ * .. Array Arguments .. * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -78,22 +78,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/alasum.f b/lapack-netlib/TESTING/LIN/alasum.f index 16c9564204..bd5d3af9b9 100644 --- a/lapack-netlib/TESTING/LIN/alasum.f +++ b/lapack-netlib/TESTING/LIN/alasum.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER NFAIL, NOUT, NRUN, NERRS * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/LIN/alasvm.f b/lapack-netlib/TESTING/LIN/alasvm.f index 0594232545..3fcbcca389 100644 --- a/lapack-netlib/TESTING/LIN/alasvm.f +++ b/lapack-netlib/TESTING/LIN/alasvm.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS ) -* +* * .. Scalar Arguments .. * CHARACTER*3 TYPE * INTEGER NFAIL, NOUT, NRUN, NERRS * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 TYPE diff --git a/lapack-netlib/TESTING/LIN/cchkaa.f b/lapack-netlib/TESTING/LIN/cchkaa.f index 2f4a961ade..9724618dbc 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.f +++ b/lapack-netlib/TESTING/LIN/cchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CCHKAA -* +* * *> \par Purpose: * ============= @@ -51,8 +51,11 @@ *> CPT 12 List types on next line if 0 < NTYPES < 12 *> CHE 10 List types on next line if 0 < NTYPES < 10 *> CHR 10 List types on next line if 0 < NTYPES < 10 +*> CHK 10 List types on next line if 0 < NTYPES < 10 +*> CHA 10 List types on next line if 0 < NTYPES < 10 *> CHP 10 List types on next line if 0 < NTYPES < 10 *> CSY 11 List types on next line if 0 < NTYPES < 11 +*> CSK 11 List types on next line if 0 < NTYPES < 11 *> CSR 11 List types on next line if 0 < NTYPES < 11 *> CSP 11 List types on next line if 0 < NTYPES < 11 *> CTR 18 List types on next line if 0 < NTYPES < 18 @@ -97,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== PROGRAM CCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * ===================================================================== * @@ -150,7 +153,7 @@ PROGRAM CCHKAA $ RANKVAL( MAXIN ), PIV( NMAX ) REAL RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ WORK( NMAX, NMAX+MAXRHS+10 ) + $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -159,14 +162,15 @@ PROGRAM CCHKAA * .. * .. External Subroutines .. EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, - $ CCHKHE_ROOK, CCHKHP, CCHKLQ, CCHKPB, CCHKPO, - $ CCHKPS, CCHKPP, CCHKPT, CCHKQ3, CCHKQL, - $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK, - $ CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, - $ CDRVGT, CDRVHE, CDRVHE_ROOK, CDRVHP, CDRVLS, - $ CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, - $ CDRVSY_ROOK, ILAVER, CCHKQRT, CCHKQRTP - + $ 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 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -644,7 +648,7 @@ PROGRAM CCHKAA ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -666,6 +670,60 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* HK: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than HR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKHE_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian matrices, +* Aasen Algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -722,7 +780,7 @@ PROGRAM CCHKAA ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SR: symmetric indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -744,6 +802,58 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SA: symmetric indefinite matrices with Aasen's algorithm, +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKSY_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * @@ -867,7 +977,6 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF - * ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN * @@ -926,7 +1035,6 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF - * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * @@ -939,8 +1047,7 @@ PROGRAM CCHKAA CALL CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ), $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), - $ S( 1 ), S( NMAX+1 ), WORK, RWORK, IWORK, - $ NOUT ) + $ S( 1 ), S( NMAX+1 ), NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF @@ -950,7 +1057,7 @@ PROGRAM CCHKAA * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -961,7 +1068,40 @@ PROGRAM CCHKAA * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL CCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL CCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL CCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/lapack-netlib/TESTING/LIN/cchkeq.f b/lapack-netlib/TESTING/LIN/cchkeq.f index db86afa354..7c79d68f89 100644 --- a/lapack-netlib/TESTING/LIN/cchkeq.f +++ b/lapack-netlib/TESTING/LIN/cchkeq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKEQ( THRESH, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NOUT * REAL THRESH * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CCHKEQ( THRESH, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NOUT diff --git a/lapack-netlib/TESTING/LIN/cchkgb.f b/lapack-netlib/TESTING/LIN/cchkgb.f index a8d2dc04c1..4a3f187a13 100644 --- a/lapack-netlib/TESTING/LIN/cchkgb.f +++ b/lapack-netlib/TESTING/LIN/cchkgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT @@ -25,7 +25,7 @@ * COMPLEX A( * ), AFAC( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -191,10 +191,10 @@ SUBROUTINE CCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkge.f b/lapack-netlib/TESTING/LIN/cchkge.f index c2c5a185f7..3fe22d0ef0 100644 --- a/lapack-netlib/TESTING/LIN/cchkge.f +++ b/lapack-netlib/TESTING/LIN/cchkge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NNS, NOUT @@ -25,7 +25,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -186,10 +186,10 @@ SUBROUTINE CCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkgt.f b/lapack-netlib/TESTING/LIN/cchkgt.f index 13677b45f7..a6780400c9 100644 --- a/lapack-netlib/TESTING/LIN/cchkgt.f +++ b/lapack-netlib/TESTING/LIN/cchkgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -147,10 +147,10 @@ SUBROUTINE CCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkhe_aa.f b/lapack-netlib/TESTING/LIN/cchkhe_aa.f new file mode 100644 index 0000000000..cb1f07b68b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkhe_aa.f @@ -0,0 +1,569 @@ +*> \brief \b CCHKHE_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHE_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHE_AA tests CHETRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKHE_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, CLANHE + EXTERNAL DGET06, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, CERRHE, CGET04, + $ ZHECON, CHERFS, CHET01_AA, CHETRF_AA, ZHETRI2, + $ CHETRS_AA, CLACPY, CLAIPD, CLARHS, CLATB4, + $ CLATMS, CPOT02, ZPOT03, ZPOT05 +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, IMAG, MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate test matrix A. +* +* +* Set the imaginary part of the diagonals. +* + CALL CLAIPD( N, A, LDA+1, 0 ) +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 1, ( NB+1 )*LDA ) + SRNAMT = 'CHETRF_AA' + CALL CHETRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CHETRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHETRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CHET01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CHETRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL CHETRS_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Check error code from CHETRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CHETRS_AA', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of CCHKHE_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/cchkhe_rk.f b/lapack-netlib/TESTING/LIN/cchkhe_rk.f new file mode 100644 index 0000000000..24a4f37850 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkhe_rk.f @@ -0,0 +1,859 @@ +*> \brief \b CCHKHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHE_RK tests CHETRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + REAL RESULT( NTESTS ) + COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANHE, SGET06 + EXTERNAL CLANGE, CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CGESVD, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CPOT02, CPOT03, + $ CHECON_3, CHET01_3, CHETRF_RK, CHETRI_3, + $ CHETRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CHETRF_RK' + CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHETRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CHETRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CHETRI_3' +* +* Another reason that we need to compute the invesrse +* is that CPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL CHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZHETRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = CONJG( BLOCK( 1, 2 ) ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = CONJG( BLOCK( 2, 1 ) ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CHETRS_3' + CALL CHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CHETRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CHECON_3' + CALL CHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CHECON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHECON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CCHKHE_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/cchkhe_rook.f b/lapack-netlib/TESTING/LIN/cchkhe_rook.f index 275451cb77..ace7844f8c 100644 --- a/lapack-netlib/TESTING/LIN/cchkhe_rook.f +++ b/lapack-netlib/TESTING/LIN/cchkhe_rook.f @@ -163,7 +163,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -172,10 +172,10 @@ SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -211,15 +211,14 @@ SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, - $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, - $ NRUN, NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, $ SING_MIN, RCOND, RCONDC, STEMP * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) - INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL RESULT( NTESTS ) COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) * .. diff --git a/lapack-netlib/TESTING/LIN/cchkhp.f b/lapack-netlib/TESTING/LIN/cchkhp.f index 5f41f6610d..d07bfd24ad 100644 --- a/lapack-netlib/TESTING/LIN/cchkhp.f +++ b/lapack-netlib/TESTING/LIN/cchkhp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -164,10 +164,10 @@ SUBROUTINE CCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchklq.f b/lapack-netlib/TESTING/LIN/cchklq.f index 38a915fec8..a407203f06 100644 --- a/lapack-netlib/TESTING/LIN/cchklq.f +++ b/lapack-netlib/TESTING/LIN/cchklq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX A( * ), AC( * ), AF( * ), AL( * ), AQ( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -196,10 +196,10 @@ SUBROUTINE CCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchklqt.f b/lapack-netlib/TESTING/LIN/cchklqt.f new file mode 100644 index 0000000000..8dfd394c64 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b CCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKLQT( 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 +*> +*> CCHKLQT tests CGELQT and CUNMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKLQT( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQT, CLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRLQT( 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 ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test CGELQT and CUNMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL CLQT04( M, N, NB, 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, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/cchklqtp.f b/lapack-netlib/TESTING/LIN/cchklqtp.f new file mode 100644 index 0000000000..1ecc1072d1 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b CCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKLQTP( 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 +*> +*> CCHKLQTP tests CTPLQT and CTPMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKLQTP( 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*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRLQTP, CLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL CLQT05( M, N, L, NB, 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, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKLQTP +* + END diff --git a/lapack-netlib/TESTING/LIN/cchkpb.f b/lapack-netlib/TESTING/LIN/cchkpb.f index f3af6f7cc9..8517168fea 100644 --- a/lapack-netlib/TESTING/LIN/cchkpb.f +++ b/lapack-netlib/TESTING/LIN/cchkpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -168,10 +168,10 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkpo.f b/lapack-netlib/TESTING/LIN/cchkpo.f index 19aa43ffda..93ad9c34fa 100644 --- a/lapack-netlib/TESTING/LIN/cchkpo.f +++ b/lapack-netlib/TESTING/LIN/cchkpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -168,10 +168,10 @@ SUBROUTINE CCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkpp.f b/lapack-netlib/TESTING/LIN/cchkpp.f index 0b73adf5ae..9d7a8b5c69 100644 --- a/lapack-netlib/TESTING/LIN/cchkpp.f +++ b/lapack-netlib/TESTING/LIN/cchkpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -159,10 +159,10 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkps.f b/lapack-netlib/TESTING/LIN/cchkps.f index f268afcd06..cf1da91bf2 100644 --- a/lapack-netlib/TESTING/LIN/cchkps.f +++ b/lapack-netlib/TESTING/LIN/cchkps.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, * THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * REAL THRESH * INTEGER NMAX, NN, NNB, NOUT, NRANK @@ -23,7 +23,7 @@ * INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -154,10 +154,10 @@ SUBROUTINE CCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL THRESH diff --git a/lapack-netlib/TESTING/LIN/cchkpt.f b/lapack-netlib/TESTING/LIN/cchkpt.f index c53bc9d2e0..a1c28af76e 100644 --- a/lapack-netlib/TESTING/LIN/cchkpt.f +++ b/lapack-netlib/TESTING/LIN/cchkpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, D, E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX A( * ), B( * ), E( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -147,10 +147,10 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, D, E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkq3.f b/lapack-netlib/TESTING/LIN/cchkq3.f index 02f178d2fc..10c29e14eb 100644 --- a/lapack-netlib/TESTING/LIN/cchkq3.f +++ b/lapack-netlib/TESTING/LIN/cchkq3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * THRESH, A, COPYA, S, TAU, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NN, NNB, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * REAL S( * ), RWORK( * ) * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -158,10 +158,10 @@ SUBROUTINE CCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ THRESH, A, COPYA, S, TAU, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NN, NNB, NOUT diff --git a/lapack-netlib/TESTING/LIN/cchkql.f b/lapack-netlib/TESTING/LIN/cchkql.f index f2313552a7..12b7ceded6 100644 --- a/lapack-netlib/TESTING/LIN/cchkql.f +++ b/lapack-netlib/TESTING/LIN/cchkql.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX A( * ), AC( * ), AF( * ), AL( * ), AQ( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -196,10 +196,10 @@ SUBROUTINE CCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkqr.f b/lapack-netlib/TESTING/LIN/cchkqr.f index 7be02950f9..7c9ded0122 100644 --- a/lapack-netlib/TESTING/LIN/cchkqr.f +++ b/lapack-netlib/TESTING/LIN/cchkqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -201,10 +201,10 @@ SUBROUTINE CCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchkqrt.f b/lapack-netlib/TESTING/LIN/cchkqrt.f index 407e452a07..6f5552bb38 100644 --- a/lapack-netlib/TESTING/LIN/cchkqrt.f +++ b/lapack-netlib/TESTING/LIN/cchkqrt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== - SUBROUTINE CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -175,7 +175,7 @@ SUBROUTINE CCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, NB = NBVAL( K ) * * Test CGEQRT and CGEMQRT -* +* IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN CALL CQRT04( M, N, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/cchkqrtp.f b/lapack-netlib/TESTING/LIN/cchkqrtp.f index 9bc2c72bf4..3d8dd2a388 100644 --- a/lapack-netlib/TESTING/LIN/cchkqrtp.f +++ b/lapack-netlib/TESTING/LIN/cchkqrtp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== - SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -172,7 +172,7 @@ SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * MINMN = MIN( M, N ) DO L = 0, MINMN, MAX( MINMN, 1 ) -* +* * Do for each possible value of NB * @@ -180,7 +180,7 @@ SUBROUTINE CCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, NB = NBVAL( K ) * * Test CTPQRT and CTPMQRT -* +* IF( (NB.LE.N).AND.(NB.GT.0) ) THEN CALL CQRT05( M, N, L, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/cchkrfp.f b/lapack-netlib/TESTING/LIN/cchkrfp.f index a3fa4b1db9..6e903eb252 100644 --- a/lapack-netlib/TESTING/LIN/cchkrfp.f +++ b/lapack-netlib/TESTING/LIN/cchkrfp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM CCHKRFP -* +* * *> \par Purpose: * ============= @@ -47,10 +47,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -59,7 +59,7 @@ * ===================================================================== PROGRAM CCHKRFP * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -253,7 +253,7 @@ PROGRAM CCHKRFP CALL CDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + S_WORK_CLANHE ) * -* Test the convertion routines: +* Test the conversion routines: * chfttp, ctpthf, ctfttr, ctrttf, ctrttp and ctpttr. * CALL CDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, diff --git a/lapack-netlib/TESTING/LIN/cchkrq.f b/lapack-netlib/TESTING/LIN/cchkrq.f index 79c05cc045..9a42dc1352 100644 --- a/lapack-netlib/TESTING/LIN/cchkrq.f +++ b/lapack-netlib/TESTING/LIN/cchkrq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -201,10 +201,10 @@ SUBROUTINE CCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchksp.f b/lapack-netlib/TESTING/LIN/cchksp.f index cd8b9d90c0..5109ac740e 100644 --- a/lapack-netlib/TESTING/LIN/cchksp.f +++ b/lapack-netlib/TESTING/LIN/cchksp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -164,10 +164,10 @@ SUBROUTINE CCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchksy_aa.f b/lapack-netlib/TESTING/LIN/cchksy_aa.f new file mode 100644 index 0000000000..33bbad192b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchksy_aa.f @@ -0,0 +1,572 @@ +*> \brief \b CCHKSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKSY_AA tests CSYTRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @generated from LIN/dchksy_aa.f, fortran d -> c, Wed Nov 16 21:34:18 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, CLANSY + EXTERNAL DGET06, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGET04, CLACPY, + $ CLARHS, CLATB4, CLATMS, CSYT02, DSYT03, DSYT05, + $ DSYCON, CSYRFS, CSYT01_AA, CSYTRF_AA, + $ DSYTRI2, CSYTRS_AA, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + SRNAMT = 'CSYTRF_AA' + LWORK = MAX( 1, N*NB + N ) + CALL CSYTRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CSYTRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CSYTRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL CSYTRS_AA( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from CSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CSYTRS_AA', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of CCHKSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/cchksy_rk.f b/lapack-netlib/TESTING/LIN/cchksy_rk.f new file mode 100644 index 0000000000..9475bb7538 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchksy_rk.f @@ -0,0 +1,867 @@ +*> \brief \b CCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKSY_RK tests CSYTRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANSY, SGET06 + EXTERNAL CLANGE, CLANSY, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGESVD, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02, + $ CSYT03, CSYCON_3, CSYT01_3, CSYTRF_RK, + $ CSYTRI_3, CSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CSYTRF_RK' + CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that CSYT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from CSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CSYTRS_3' + CALL CSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CSYCON_3' + CALL CSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of CCHKSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/cchksy_rook.f b/lapack-netlib/TESTING/LIN/cchksy_rook.f index 6e7c379366..84802f3b8f 100644 --- a/lapack-netlib/TESTING/LIN/cchksy_rook.f +++ b/lapack-netlib/TESTING/LIN/cchksy_rook.f @@ -163,7 +163,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -172,10 +172,10 @@ SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -211,9 +211,8 @@ SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, - $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, - $ NRUN, NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, $ SING_MIN, RCOND, RCONDC, STEMP * .. diff --git a/lapack-netlib/TESTING/LIN/cchktb.f b/lapack-netlib/TESTING/LIN/cchktb.f index b4af070849..027e3ecd8b 100644 --- a/lapack-netlib/TESTING/LIN/cchktb.f +++ b/lapack-netlib/TESTING/LIN/cchktb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX AB( * ), AINV( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -149,10 +149,10 @@ SUBROUTINE CCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchktp.f b/lapack-netlib/TESTING/LIN/cchktp.f index b3b8ea092d..98c4b080b9 100644 --- a/lapack-netlib/TESTING/LIN/cchktp.f +++ b/lapack-netlib/TESTING/LIN/cchktp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -151,10 +151,10 @@ SUBROUTINE CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchktr.f b/lapack-netlib/TESTING/LIN/cchktr.f index d599a49056..ec731b73d9 100644 --- a/lapack-netlib/TESTING/LIN/cchktr.f +++ b/lapack-netlib/TESTING/LIN/cchktr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, * WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AINV( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -163,10 +163,10 @@ SUBROUTINE CCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, $ WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cchktsqr.f b/lapack-netlib/TESTING/LIN/cchktsqr.f new file mode 100644 index 0000000000..8288916db3 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b CCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKTSQR( 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 +*> +*> CCHKTSQR tests CGEQR and CGEMQR. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CCHKTSQR( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRTSQR, + $ CTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL CERRTSQR( 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL CTSQR01( 'TS', M, N, MB, NB, 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, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL CTSQR01( 'SW', M, N, MB, NB, 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 = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of CCHKQRT +* + END diff --git a/lapack-netlib/TESTING/LIN/cchktz.f b/lapack-netlib/TESTING/LIN/cchktz.f index b2871bf74b..4926773a62 100644 --- a/lapack-netlib/TESTING/LIN/cchktz.f +++ b/lapack-netlib/TESTING/LIN/cchktz.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, * COPYA, S, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NOUT @@ -22,7 +22,7 @@ * REAL S( * ), RWORK( * ) * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -137,10 +137,10 @@ SUBROUTINE CCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvgb.f b/lapack-netlib/TESTING/LIN/cdrvgb.f index 8a76261888..42e26028a4 100644 --- a/lapack-netlib/TESTING/LIN/cdrvgb.f +++ b/lapack-netlib/TESTING/LIN/cdrvgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -172,10 +172,10 @@ SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvgbx.f b/lapack-netlib/TESTING/LIN/cdrvgbx.f index a7d3009d12..b043c10891 100644 --- a/lapack-netlib/TESTING/LIN/cdrvgbx.f +++ b/lapack-netlib/TESTING/LIN/cdrvgbx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -175,10 +175,10 @@ SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvge.f b/lapack-netlib/TESTING/LIN/cdrvge.f index 9fa8e00dff..054e7e84ef 100644 --- a/lapack-netlib/TESTING/LIN/cdrvge.f +++ b/lapack-netlib/TESTING/LIN/cdrvge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -164,10 +164,10 @@ SUBROUTINE CDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvgex.f b/lapack-netlib/TESTING/LIN/cdrvgex.f index 5320205322..51fc848998 100644 --- a/lapack-netlib/TESTING/LIN/cdrvgex.f +++ b/lapack-netlib/TESTING/LIN/cdrvgex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,10 +153,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -167,7 +167,7 @@ SUBROUTINE CDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/cdrvgt.f b/lapack-netlib/TESTING/LIN/cdrvgt.f index 737983f407..8d431efc5f 100644 --- a/lapack-netlib/TESTING/LIN/cdrvgt.f +++ b/lapack-netlib/TESTING/LIN/cdrvgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, * B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -23,7 +23,7 @@ * COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -139,10 +139,10 @@ SUBROUTINE CDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, $ B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvhe_aa.f b/lapack-netlib/TESTING/LIN/cdrvhe_aa.f new file mode 100644 index 0000000000..6f6d758b21 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvhe_aa.f @@ -0,0 +1,485 @@ +*> \brief \b CDRVHE_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVHE_AA tests the driver routine CHESV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL CLANHE, SGET06 + EXTERNAL CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, + $ CGET04, CLACPY, CLARHS, CLATB4, CLATMS, + $ CHESV_AA, CHET01_AA, CPOT02, + $ CHETRF_AA +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CHESV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using CHESV_AA. +* + SRNAMT = 'CHESV_AA ' + CALL CHESV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CHESV_AA . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHESV_AA', INFO, K, + $ UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CHET01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CHESV_AA ', + $ UPLO, N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVHE_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvhe_rk.f b/lapack-netlib/TESTING/LIN/cdrvhe_rk.f new file mode 100644 index 0000000000..f410277b4d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvhe_rk.f @@ -0,0 +1,534 @@ +*> \brief \b CDRVHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVHE_RK tests the driver routines CHESV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANHE + EXTERNAL CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CHESV_RK, + $ CHET01_3, CPOT02, CHETRF_RK, CHETRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CHESV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CHESV_RK. +* + SRNAMT = 'CHESV_RK' + CALL CHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHESV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHESV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CHESV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVHE_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvhex.f b/lapack-netlib/TESTING/LIN/cdrvhex.f index 8a88c0999a..c6604c3922 100644 --- a/lapack-netlib/TESTING/LIN/cdrvhex.f +++ b/lapack-netlib/TESTING/LIN/cdrvhex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ SUBROUTINE CDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/cdrvhp.f b/lapack-netlib/TESTING/LIN/cdrvhp.f index 1e9d0b2302..875c894fe5 100644 --- a/lapack-netlib/TESTING/LIN/cdrvhp.f +++ b/lapack-netlib/TESTING/LIN/cdrvhp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVHP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -157,10 +157,10 @@ SUBROUTINE CDRVHP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvls.f b/lapack-netlib/TESTING/LIN/cdrvls.f index 94f515477a..b9b8e0f4ff 100644 --- a/lapack-netlib/TESTING/LIN/cdrvls.f +++ b/lapack-netlib/TESTING/LIN/cdrvls.f @@ -2,17 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, -* COPYB, C, S, COPYS, WORK, RWORK, IWORK, -* NOUT ) -* +* COPYB, C, S, COPYS, NOUT ) +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -20,20 +19,19 @@ * .. * .. Array Arguments .. * LOGICAL DOTYPE( * ) -* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), * $ NVAL( * ), NXVAL( * ) -* REAL COPYS( * ), RWORK( * ), S( * ) -* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), -* $ WORK( * ) +* REAL COPYS( * ), S( * ) +* COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CDRVLS tests the least squares driver routines CGELS, CGELSS, CGELSY +*> CDRVLS tests the least squares driver routines CGELS, CGETSLS, CGELSS, CGELSY *> and CGELSD. *> \endverbatim * @@ -171,22 +169,6 @@ *> (min(MMAX,NMAX)) *> \endverbatim *> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX array, dimension -*> (MMAX*NMAX + 4*NMAX + MMAX). -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is REAL array, dimension (5*NMAX-1) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (15*NMAX) -*> \endverbatim -*> *> \param[in] NOUT *> \verbatim *> NOUT is INTEGER @@ -196,25 +178,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, - $ COPYB, C, S, COPYS, WORK, RWORK, IWORK, - $ NOUT ) + $ COPYB, C, S, COPYS, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -223,18 +204,17 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) - INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), + INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), $ NVAL( * ), NXVAL( * ) - REAL COPYS( * ), RWORK( * ), S( * ) - COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), - $ WORK( * ) + REAL COPYS( * ), S( * ) + COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, ZERO @@ -246,15 +226,25 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, + INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK, $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NRHS, NROWS, NRUN, RANK + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, + $ MMAX, NMAX, NSMAX, LIWORK, LRWORK, + $ LWORK_CGELS, LWORK_CGETSLS, LWORK_CGELSS, + $ LWORK_CGELSY, LWORK_CGELSD, + $ LRWORK_CGELSY, LRWORK_CGELSS, LRWORK_CGELSD REAL EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. - INTEGER ISEED( 4 ), ISEEDY( 4 ) - REAL RESULT( NTESTS ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY + REAL RESULT( NTESTS ), RWORKQUERY + COMPLEX WORKQUERY +* .. +* .. Allocatable Arrays .. + COMPLEX, ALLOCATABLE :: WORK (:) + REAL, ALLOCATABLE :: RWORK (:) + INTEGER, ALLOCATABLE :: IWORK (:) * .. * .. External Functions .. REAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH @@ -262,12 +252,12 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD, - $ CGELSS, CGELSY, CGEMM, CLACPY, CLARNV, - $ CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY, - $ XLAENV + $ CGELSS, CGELSY, CGEMM, CGETSLS, CLACPY, + $ CLARNV, CQRT13, CQRT15, CQRT16, CSSCAL, + $ SAXPY, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, REAL, SQRT + INTRINSIC MAX, MIN, INT, REAL, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -310,6 +300,77 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO ) $ CALL ALAHD( NOUT, PATH ) INFOT = 0 +* +* Compute maximal workspace needed for all routines +* + NMAX = 0 + MMAX = 0 + NSMAX = 0 + DO I = 1, NM + IF ( MVAL( I ).GT.MMAX ) THEN + MMAX = MVAL( I ) + END IF + ENDDO + DO I = 1, NN + IF ( NVAL( I ).GT.NMAX ) THEN + NMAX = NVAL( I ) + END IF + ENDDO + DO I = 1, NNS + IF ( NSVAL( I ).GT.NSMAX ) THEN + NSMAX = NSVAL( I ) + END IF + ENDDO + M = MMAX + N = NMAX + NRHS = NSMAX + LDA = MAX( 1, M ) + LDB = MAX( 1, M, N ) + MNMIN = MAX( MIN( M, N ), 1 ) +* +* Compute workspace needed for routines +* CQRT14, CQRT17 (two side cases), CQRT15 and CQRT12 +* + LWORK = MAX( ( M+N )*NRHS, + $ ( N+NRHS )*( M+2 ), ( M+NRHS )*( N+2 ), + $ MAX( M+MNMIN, NRHS*MNMIN,2*N+M ), + $ MAX( M*N+4*MNMIN+MAX(M,N), M*N+2*MNMIN+4*N ) ) +* +* Compute workspace needed for CGELS + CALL CGELS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_CGELS = INT( WORKQUERY ) +* Compute workspace needed for CGETSLS + CALL CGETSLS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_CGETSLS = INT( WORKQUERY ) +* Compute workspace needed for CGELSY + CALL CGELSY( M, N, NRHS, A, LDA, B, LDB, IWORKQUERY, + $ RCOND, CRANK, WORKQUERY, -1, RWORK, INFO ) + LWORK_CGELSY = INT( WORKQUERY ) + LRWORK_CGELSY = 2*N +* Compute workspace needed for CGELSS + CALL CGELSS( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1, RWORK, INFO ) + LWORK_CGELSS = INT( WORKQUERY ) + LRWORK_CGELSS = 5*MNMIN +* Compute workspace needed for CGELSD + CALL CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, CRANK, + $ WORKQUERY, -1, RWORKQUERY, IWORKQUERY, INFO ) + LWORK_CGELSD = INT( WORKQUERY ) + LRWORK_CGELSD = INT( RWORKQUERY ) +* Compute LIWORK workspace needed for CGELSY and CGELSD + LIWORK = MAX( 1, N, IWORKQUERY ) +* Compute LRWORK workspace needed for CGELSY, CGELSS and CGELSD + LRWORK = MAX( 1, LRWORK_CGELSY, LRWORK_CGELSS, LRWORK_CGELSD ) +* Compute LWORK workspace needed for all functions + LWORK = MAX( 1, LWORK, LWORK_CGELS, LWORK_CGETSLS, LWORK_CGELSY, + $ LWORK_CGELSS, LWORK_CGELSD ) + LWLSY = LWORK +* + ALLOCATE( WORK( LWORK ) ) + ALLOCATE( IWORK( LIWORK ) ) + ALLOCATE( RWORK( LRWORK ) ) * DO 140 IM = 1, NM M = MVAL( IM ) @@ -317,13 +378,12 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * DO 130 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) * DO 120 INS = 1, NNS NRHS = NSVAL( INS ) - LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 2*N+M ) * DO 110 IRANK = 1, 2 DO 100 ISCALE = 1, 3 @@ -433,6 +493,110 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test CGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL CQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'C' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL CLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL CSCAL( NCOLS*NRHS, + $ ONE / REAL( NCOLS ), WORK, + $ 1 ) + END IF + CALL CGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, CONE, COPYA, LDA, + $ WORK, LDWORK, CZERO, B, LDB ) + CALL CLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL CLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL CLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'CGETSLS ' + CALL CGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL CLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL CQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = CQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = CQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -469,12 +633,6 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, DO 70 J = 1, N IWORK( J ) = 0 70 CONTINUE -* -* Set LWLSY to the adequate value. -* - LWLSY = MNMIN + MAX( 2*MNMIN, NB*( N+1 ), - $ MNMIN+NB*NRHS ) - LWLSY = MAX( 1, LWLSY ) * SRNAMT = 'CGELSY' CALL CGELSY( M, N, NRHS, A, LDA, B, LDB, IWORK, @@ -637,7 +795,7 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * Print information about the tests that did not * pass the threshold. * - DO 80 K = 3, NTESTS + DO 80 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -663,6 +821,13 @@ SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) +* + DEALLOCATE( WORK ) + DEALLOCATE( RWORK ) + DEALLOCATE( IWORK ) RETURN * * End of CDRVLS diff --git a/lapack-netlib/TESTING/LIN/cdrvpb.f b/lapack-netlib/TESTING/LIN/cdrvpb.f index 779d4cf28d..fb43d7f736 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpb.f +++ b/lapack-netlib/TESTING/LIN/cdrvpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -159,10 +159,10 @@ SUBROUTINE CDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvpo.f b/lapack-netlib/TESTING/LIN/cdrvpo.f index 862e3462df..8f484d6de4 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpo.f +++ b/lapack-netlib/TESTING/LIN/cdrvpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -159,10 +159,10 @@ SUBROUTINE CDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvpox.f b/lapack-netlib/TESTING/LIN/cdrvpox.f index b763d6d9bf..cc08095d67 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpox.f +++ b/lapack-netlib/TESTING/LIN/cdrvpox.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * @@ -162,10 +162,10 @@ SUBROUTINE CDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvpp.f b/lapack-netlib/TESTING/LIN/cdrvpp.f index 3fdce2a79e..5e38c18507 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpp.f +++ b/lapack-netlib/TESTING/LIN/cdrvpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -159,10 +159,10 @@ SUBROUTINE CDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvpt.f b/lapack-netlib/TESTING/LIN/cdrvpt.f index c2ec0dfb3b..926f22378a 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpt.f +++ b/lapack-netlib/TESTING/LIN/cdrvpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, * E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -23,7 +23,7 @@ * COMPLEX A( * ), B( * ), E( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -140,10 +140,10 @@ SUBROUTINE CDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, $ E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvrf1.f b/lapack-netlib/TESTING/LIN/cdrvrf1.f index b700503209..eb3949807f 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrf1.f +++ b/lapack-netlib/TESTING/LIN/cdrvrf1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * REAL THRESH @@ -19,7 +19,7 @@ * REAL WORK( * ) * COMPLEX A( LDA, * ), ARF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -164,14 +164,14 @@ SUBROUTINE CDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) EPS = SLAMCH( 'Precision' ) SMALL = SLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL - SMALL = SMALL * LDA * LDA + SMALL = SMALL * LDA * LDA LARGE = LARGE / LDA / LDA * DO 130 IIN = 1, NN * N = NVAL( IIN ) * - DO 120 IIT = 1, 3 + DO 120 IIT = 1, 3 * Nothing to do for N=0 IF ( N .EQ. 0 ) EXIT * @@ -244,7 +244,7 @@ SUBROUTINE CDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'CLANHF', + WRITE( NOUT, FMT = 9997 ) 'CLANHF', + N, IIT, UPLO, CFORM, NORM, RESULT(1) NFAIL = NFAIL + 1 END IF diff --git a/lapack-netlib/TESTING/LIN/cdrvrf2.f b/lapack-netlib/TESTING/LIN/cdrvrf2.f index d902701c28..d1b9c87522 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrf2.f +++ b/lapack-netlib/TESTING/LIN/cdrvrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * .. @@ -17,14 +17,14 @@ * INTEGER NVAL( NN ) * COMPLEX A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CDRVRF2 tests the LAPACK RFP convertion routines. +*> CDRVRF2 tests the LAPACK RFP conversion routines. *> \endverbatim * * Arguments: @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -248,14 +248,14 @@ SUBROUTINE CDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) WRITE( NOUT, FMT = 9996 ) NERRS, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP conversion', + ' routines ***') - 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + 9998 FORMAT( 1X, ' Error in RFP,conversion routines N=',I5, + ' UPLO=''', A1, ''', FORM =''',A1,'''') - 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed ( ', + 9997 FORMAT( 1X, 'All tests for the RFP conversion routines passed ( ', + I5,' tests run)') - 9996 FORMAT( 1X, 'RFP convertion routines: ',I5,' out of ',I5, - + ' error message recorded') + 9996 FORMAT( 1X, 'RFP conversion routines: ',I5,' out of ',I5, + + ' error message recorded') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/cdrvrf3.f b/lapack-netlib/TESTING/LIN/cdrvrf3.f index 538b462ae5..ca798e19a0 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/cdrvrf3.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * + S_WORK_CLANGE, C_WORK_CGEQRF, TAU ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * REAL THRESH @@ -22,7 +22,7 @@ * + B2( LDA, * ) * COMPLEX C_WORK_CGEQRF( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -119,10 +119,10 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + S_WORK_CLANGE, C_WORK_CGEQRF, TAU ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -257,12 +257,12 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, END IF * * Generate A our NA--by--NA triangular -* matrix. +* matrix. * Our test is based on forward error so we * do want A to be well conditionned! To get * a well-conditionned triangular matrix, we * take the R factor of the QR/LQ factorization -* of a random matrix. +* of a random matrix. * DO J = 1, NA DO I = 1, NA @@ -292,7 +292,7 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * * After the QR factorization, the diagonal * of A is made of real numbers, we multiply -* by a random complex number of absolute +* by a random complex number of absolute * value 1.0E+00. * DO J = 1, NA @@ -349,7 +349,7 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'CTFSM', + WRITE( NOUT, FMT = 9997 ) 'CTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, + N, RESULT(1) NFAIL = NFAIL + 1 @@ -372,7 +372,7 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, FMT = 9995 ) 'CTFSM', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', diff --git a/lapack-netlib/TESTING/LIN/cdrvrf4.f b/lapack-netlib/TESTING/LIN/cdrvrf4.f index dc97de4f63..9f33b04b72 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrf4.f +++ b/lapack-netlib/TESTING/LIN/cdrvrf4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * + LDA, S_WORK_CLANGE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDC, NN, NOUT * REAL THRESH @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *), * + CRF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -114,10 +114,10 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + LDA, S_WORK_CLANGE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDC, NN, NOUT @@ -244,7 +244,7 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * * In this case we are TRANS, so A is K-by-N * - DO J = 1,N + DO J = 1,N DO I = 1, K A( I, J) = CLARND( 4, ISEED ) END DO @@ -256,7 +256,7 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, END IF * * -* Generate C1 our N--by--N Hermitian matrix. +* Generate C1 our N--by--N Hermitian matrix. * Make sure C2 has the same upper/lower part, * (the one that we do not touch), so * copy the initial C1 in C2 in it. @@ -311,7 +311,7 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * RESULT(1) = CLANGE( 'I', N, N, C1, LDC, + S_WORK_CLANGE ) - RESULT(1) = RESULT(1) + RESULT(1) = RESULT(1) + / MAX( ABS( ALPHA ) * NORMA * NORMA + + ABS( BETA ) * NORMC, ONE ) + / MAX( N , 1 ) / EPS @@ -321,7 +321,7 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'CHFRK', + WRITE( NOUT, FMT = 9997 ) 'CHFRK', + CFORM, UPLO, TRANS, N, K, RESULT(1) NFAIL = NFAIL + 1 END IF @@ -341,7 +341,7 @@ SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, FMT = 9995 ) 'CHFRK', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CHFRK + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CHFRK + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, diff --git a/lapack-netlib/TESTING/LIN/cdrvrfp.f b/lapack-netlib/TESTING/LIN/cdrvrfp.f index 0752426778..a57688f831 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/cdrvrfp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -14,7 +14,7 @@ * + C_WORK_CLATMS, C_WORK_CPOT02, * + C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE, * + S_WORK_CPOT01, S_WORK_CPOT02, S_WORK_CPOT03 ) -* +* * .. Scalar Arguments .. * INTEGER NN, NNS, NNT, NOUT * REAL THRESH @@ -40,7 +40,7 @@ * REAL S_WORK_CPOT02( * ) * REAL S_WORK_CPOT03( * ) * .. -* +* * *> \par Purpose: * ============= @@ -53,11 +53,11 @@ *> This testing routine follow the same tests as CDRVPO (test for the full *> format Symmetric Positive Definite solver). *> -*> The tests are performed in Full Format, convertion back and forth from +*> The tests are performed in Full Format, conversion back and forth from *> full format to RFP format are performed using the routines CTRTTF and *> CTFTTR. *> -*> First, a specific matrix A of size N is created. There is nine types of +*> First, a specific matrix A of size N is created. There is nine types of *> different matrixes possible. *> 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) *> 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS @@ -227,12 +227,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * @@ -244,10 +244,10 @@ SUBROUTINE CDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE, + S_WORK_CPOT01, S_WORK_CPOT02, S_WORK_CPOT03 ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -521,7 +521,7 @@ SUBROUTINE CDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, * * Form the inverse and compute the residual. * - IF(MOD(N,2).EQ.0)THEN + IF(MOD(N,2).EQ.0)THEN CALL CLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + N+1 ) ELSE diff --git a/lapack-netlib/TESTING/LIN/cdrvsp.f b/lapack-netlib/TESTING/LIN/cdrvsp.f index b346092e34..169ebaa5a2 100644 --- a/lapack-netlib/TESTING/LIN/cdrvsp.f +++ b/lapack-netlib/TESTING/LIN/cdrvsp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -157,10 +157,10 @@ SUBROUTINE CDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvsy_aa.f b/lapack-netlib/TESTING/LIN/cdrvsy_aa.f new file mode 100644 index 0000000000..b1a5f11c46 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvsy_aa.f @@ -0,0 +1,480 @@ +*> \brief \b CDRVSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSY_AA tests the driver routine CSYSV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @generated from LIN/ddrvsy_aa.f, fortran d -> c, Thu Nov 17 12:14:51 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, CLANSY + EXTERNAL DGET06, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, CGET04, CLACPY, + $ CLARHS, CLASET, CLATB4, CLATMS, CSYT02, DSYT05, + $ CSYSV_AA, CSYT01_AA, CSYTRF_AA, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with CLATB4 and generate a test matrix +* with CLATMS. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CSYSV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using CSYSV_AA. +* + SRNAMT = 'CSYSV_AA' + CALL CSYSV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CSYSV_AA . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CSYSV_AA ', INFO, K, + $ UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CSYSV_AA ', + $ UPLO, N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvsy_rk.f b/lapack-netlib/TESTING/LIN/cdrvsy_rk.f new file mode 100644 index 0000000000..ae313c2430 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvsy_rk.f @@ -0,0 +1,542 @@ +*> \brief \b CDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSY_RK tests the driver routines CSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \param[out] AINV +*> +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANSY + EXTERNAL CLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, + $ CSYSV_RK, CSYT01_3, CSYT02, CSYTRF_RK, CSYTRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = CLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CSYSV_RK. +* + SRNAMT = 'CSYSV_RK' + CALL CSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvsyx.f b/lapack-netlib/TESTING/LIN/cdrvsyx.f index 6d9b6a54e6..cc4f754cec 100644 --- a/lapack-netlib/TESTING/LIN/cdrvsyx.f +++ b/lapack-netlib/TESTING/LIN/cdrvsyx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ SUBROUTINE CDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/cebchvxx.f b/lapack-netlib/TESTING/LIN/cebchvxx.f index 283ffe3d42..00f92f4e32 100644 --- a/lapack-netlib/TESTING/LIN/cebchvxx.f +++ b/lapack-netlib/TESTING/LIN/cebchvxx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * diff --git a/lapack-netlib/TESTING/LIN/cerrge.f b/lapack-netlib/TESTING/LIN/cerrge.f index 732c3a4de1..93f26f9dc6 100644 --- a/lapack-netlib/TESTING/LIN/cerrge.f +++ b/lapack-netlib/TESTING/LIN/cerrge.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrgex.f b/lapack-netlib/TESTING/LIN/cerrgex.f index add54d6e0d..02230245b2 100644 --- a/lapack-netlib/TESTING/LIN/cerrgex.f +++ b/lapack-netlib/TESTING/LIN/cerrgex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrgt.f b/lapack-netlib/TESTING/LIN/cerrgt.f index 13a745670d..f95db6706e 100644 --- a/lapack-netlib/TESTING/LIN/cerrgt.f +++ b/lapack-netlib/TESTING/LIN/cerrgt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRGT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRGT( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrhe.f b/lapack-netlib/TESTING/LIN/cerrhe.f index 19a3182f77..535707f0ce 100644 --- a/lapack-netlib/TESTING/LIN/cerrhe.f +++ b/lapack-netlib/TESTING/LIN/cerrhe.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,17 +81,20 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INTEGER IP( NMAX ) REAL R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, - $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI, - $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK, - $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS + EXTERNAL ALAESM, CHECON, CSYCON_3, CHECON_ROOK, CHERFS, + $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF_AA, + $ CHETRF, CHETRF_RK, CHETRF_ROOK, CHETRI, + $ CHETRI_3, CHETRI_3X, CHETRI_ROOK, CHETRI2, + $ CHETRI2X, CHETRS, CHETRS_3, CHETRS_ROOK, + $ CHETRS_AA, CHKXER, CHPCON, CHPRFS, CHPTRF, + $ CHPTRI, CHPTRS * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,22 +121,23 @@ SUBROUTINE CERRHE( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CHETRF * SRNAMT = 'CHETRF' @@ -146,6 +150,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 4 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) * * CHETF2 * @@ -186,6 +196,19 @@ SUBROUTINE CERRHE( PATH, NUNIT ) CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) * +* CHETRI2X +* + SRNAMT = 'CHETRI2X' + INFOT = 1 + CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) +* * CHETRS * SRNAMT = 'CHETRS' @@ -252,12 +275,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 6 CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * CHETRF_ROOK * @@ -271,6 +294,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 4 CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * CHETF2_ROOK * @@ -332,6 +361,164 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 6 CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CHETRF_RK +* + SRNAMT = 'CHETRF_RK' + INFOT = 1 + CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_RK +* + SRNAMT = 'CHETF2_RK' + INFOT = 1 + CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3 +* + SRNAMT = 'CHETRI_3' + INFOT = 1 + CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3X +* + SRNAMT = 'CHETRI_3X' + INFOT = 1 + CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* CHETRS_3 +* + SRNAMT = 'CHETRS_3' + INFOT = 1 + CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) +* +* CHECON_3 +* + SRNAMT = 'CHECON_3' + INFOT = 1 + CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with Aasen's algorithm. +* +* CHETRF_AA +* + SRNAMT = 'CHETRF_AA' + INFOT = 1 + CALL CHETRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_AA', INFOT, NOUT, LERR, OK ) +* +* CHETRS_AA +* + SRNAMT = 'CHETRS_AA' + INFOT = 1 + CALL CHETRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHETRS_AA', INFOT, NOUT, LERR, OK ) * * Test error exits of the routines that use factorization * of a Hermitian indefinite packed matrix with patrial diff --git a/lapack-netlib/TESTING/LIN/cerrhex.f b/lapack-netlib/TESTING/LIN/cerrhex.f index ad0c2147f7..e10a5404fa 100644 --- a/lapack-netlib/TESTING/LIN/cerrhex.f +++ b/lapack-netlib/TESTING/LIN/cerrhex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRHE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -87,18 +87,19 @@ SUBROUTINE CERRHE( PATH, NUNIT ) $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, - $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI, - $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK, - $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS, - $ CHERFSX + EXTERNAL ALAESM, CHECON, CHECON_3, CHECON_ROOK, CHERFS, + $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF, + $ CHETRF_RK, CHETRF_ROOK, CHETRI, CHETRI_3, + $ CHETRI_3X, CHETRI_ROOK, CHETRI2, CHETRI2X, + $ CHETRS, CHETRS_3, CHETRS_ROOK, CHKXER, CHPCON, + $ CHPRFS, CHPTRF, CHPTRI, CHPTRS, CHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -125,23 +126,23 @@ SUBROUTINE CERRHE( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CHETRF * SRNAMT = 'CHETRF' @@ -154,6 +155,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 4 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) * * CHETF2 * @@ -194,6 +201,19 @@ SUBROUTINE CERRHE( PATH, NUNIT ) CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) * +* CHETRI2X +* + SRNAMT = 'CHETRI2X' + INFOT = 1 + CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) +* * CHETRS * SRNAMT = 'CHETRS' @@ -307,12 +327,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * CHETRF_ROOK * @@ -326,6 +346,12 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 4 CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * CHETF2_ROOK * @@ -387,12 +413,121 @@ SUBROUTINE CERRHE( PATH, NUNIT ) INFOT = 6 CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CHETRF_RK +* + SRNAMT = 'CHETRF_RK' + INFOT = 1 + CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_RK +* + SRNAMT = 'CHETF2_RK' + INFOT = 1 + CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3 +* + SRNAMT = 'CHETRI_3' + INFOT = 1 + CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3X +* + SRNAMT = 'CHETRI_3X' + INFOT = 1 + CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* CHETRS_3 +* + SRNAMT = 'CHETRS_3' + INFOT = 1 + CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) +* +* CHECON_3 +* + SRNAMT = 'CHECON_3' + INFOT = 1 + CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * * Test error exits of the routines that use factorization * of a Hermitian indefinite packed matrix with patrial * (Bunch-Kaufman) diagonal pivoting method. -* - ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * * CHPTRF * diff --git a/lapack-netlib/TESTING/LIN/cerrlq.f b/lapack-netlib/TESTING/LIN/cerrlq.f index 5415d3eff1..822380c9ac 100644 --- a/lapack-netlib/TESTING/LIN/cerrlq.f +++ b/lapack-netlib/TESTING/LIN/cerrlq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRLQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRLQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrlqt.f b/lapack-netlib/TESTING/LIN/cerrlqt.f new file mode 100644 index 0000000000..6e2d8b321d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cerrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b CERRLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRLQT tests the error exits for the COMPLEX routines +*> that use the LQT decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRLQT( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CGELQT3, CGELQT, + $ CGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* CGELQT +* + SRNAMT = 'CGELQT' + INFOT = 1 + CALL CGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'CGELQT', INFOT, NOUT, LERR, OK ) +* +* CGELQT3 +* + SRNAMT = 'CGELQT3' + INFOT = 1 + CALL CGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'CGELQT3', INFOT, NOUT, LERR, OK ) +* +* CGEMLQT +* + SRNAMT = 'CGEMLQT' + INFOT = 1 + CALL CGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'CGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/cerrlqtp.f b/lapack-netlib/TESTING/LIN/cerrlqtp.f new file mode 100644 index 0000000000..7786dc1d3a --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cerrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b ZERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRLQTP tests the error exits for the complex routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRLQTP( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CTPLQT2, CTPLQT, + $ CTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* CTPLQT +* + SRNAMT = 'CTPLQT' + INFOT = 1 + CALL CTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'CTPLQT', INFOT, NOUT, LERR, OK ) +* +* CTPLQT2 +* + SRNAMT = 'CTPLQT2' + INFOT = 1 + CALL CTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'CTPLQT2', INFOT, NOUT, LERR, OK ) +* +* CTPMLQT +* + SRNAMT = 'CTPMLQT' + INFOT = 1 + CALL CTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL CTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'CTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/cerrls.f b/lapack-netlib/TESTING/LIN/cerrls.f index 5376fa6bf6..5510b1c5ed 100644 --- a/lapack-netlib/TESTING/LIN/cerrls.f +++ b/lapack-netlib/TESTING/LIN/cerrls.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRLS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRLS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrpo.f b/lapack-netlib/TESTING/LIN/cerrpo.f index a4fe376fd0..19f7afbad9 100644 --- a/lapack-netlib/TESTING/LIN/cerrpo.f +++ b/lapack-netlib/TESTING/LIN/cerrpo.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrpox.f b/lapack-netlib/TESTING/LIN/cerrpox.f index 54af152729..eee3726eb1 100644 --- a/lapack-netlib/TESTING/LIN/cerrpox.f +++ b/lapack-netlib/TESTING/LIN/cerrpox.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrps.f b/lapack-netlib/TESTING/LIN/cerrps.f index 047b6a371b..f9aa3cf140 100644 --- a/lapack-netlib/TESTING/LIN/cerrps.f +++ b/lapack-netlib/TESTING/LIN/cerrps.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRPS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRPS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/cerrql.f b/lapack-netlib/TESTING/LIN/cerrql.f index 4bdb4ddfda..716417b8cd 100644 --- a/lapack-netlib/TESTING/LIN/cerrql.f +++ b/lapack-netlib/TESTING/LIN/cerrql.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRQL( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRQL( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrqp.f b/lapack-netlib/TESTING/LIN/cerrqp.f index 00415c0c17..3ed463ad84 100644 --- a/lapack-netlib/TESTING/LIN/cerrqp.f +++ b/lapack-netlib/TESTING/LIN/cerrqp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRQP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRQP( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrqr.f b/lapack-netlib/TESTING/LIN/cerrqr.f index 70dc705280..e124d0f816 100644 --- a/lapack-netlib/TESTING/LIN/cerrqr.f +++ b/lapack-netlib/TESTING/LIN/cerrqr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRQR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRQR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrqrt.f b/lapack-netlib/TESTING/LIN/cerrqrt.f index d2ebf0c443..f391a9b329 100644 --- a/lapack-netlib/TESTING/LIN/cerrqrt.f +++ b/lapack-netlib/TESTING/LIN/cerrqrt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRQRT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -56,10 +56,10 @@ SUBROUTINE CERRQRT( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE CERRQRT( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CGEQRT2, CGEQRT3, CGEQRT, - $ CGEMQRT + $ CGEMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/LIN/cerrqrtp.f b/lapack-netlib/TESTING/LIN/cerrqrtp.f index 7d4c05db3c..34e2ecd399 100644 --- a/lapack-netlib/TESTING/LIN/cerrqrtp.f +++ b/lapack-netlib/TESTING/LIN/cerrqrtp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRQRTP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -56,10 +56,10 @@ SUBROUTINE CERRQRTP( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE CERRQRTP( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CTPQRT2, CTPQRT, - $ CTPMQRT + $ CTPMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,50 +171,50 @@ SUBROUTINE CERRQRTP( PATH, NUNIT ) * SRNAMT = 'CTPMQRT' INFOT = 1 - CALL CTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL CTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) INFOT = 6 - CALL CTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL CTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL CTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL CTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL CTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL CTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + CALL CTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + CALL CTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL CTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + CALL CTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, $ W, INFO ) CALL CHKXER( 'CTPMQRT', INFOT, NOUT, LERR, OK ) * diff --git a/lapack-netlib/TESTING/LIN/cerrrfp.f b/lapack-netlib/TESTING/LIN/cerrrfp.f index 254dc94bd3..da02a88851 100644 --- a/lapack-netlib/TESTING/LIN/cerrrfp.f +++ b/lapack-netlib/TESTING/LIN/cerrrfp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRRFP( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -40,22 +40,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRRFP( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/cerrrq.f b/lapack-netlib/TESTING/LIN/cerrrq.f index 87987c2dd0..bcacdc3495 100644 --- a/lapack-netlib/TESTING/LIN/cerrrq.f +++ b/lapack-netlib/TESTING/LIN/cerrrq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRRQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRRQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrsy.f b/lapack-netlib/TESTING/LIN/cerrsy.f index f3fb817101..90d6be9aaa 100644 --- a/lapack-netlib/TESTING/LIN/cerrsy.f +++ b/lapack-netlib/TESTING/LIN/cerrsy.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,7 +80,7 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INTEGER IP( NMAX ) REAL R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -88,9 +88,11 @@ SUBROUTINE CERRSY( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI, - $ CSPTRS, CSYCON, CSYCON_ROOK, CSYRFS, CSYTF2, - $ CSYTF2_ROOK, CSYTRF, CSYTRF_ROOK, CSYTRI, - $ CSYTRI_ROOK, CSYTRI2, CSYTRS, CSYTRS_ROOK + $ CSPTRS, CSYCON, CSYCON_3, CSYCON_ROOK, CSYRFS, + $ CSYTF2, CSYTF2_RK, CSYTF2_ROOK, CSYTRF, + $ CSYTRF_RK, CSYTRF_ROOK, CSYTRI, CSYTRI_3, + $ CSYTRI_3X, CSYTRI_ROOK, CSYTRI2, CSYTRI2X, + $ CSYTRS, CSYTRS_3, CSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -117,22 +119,23 @@ SUBROUTINE CERRSY( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E0 + E( J ) = 0.E0 + R1( J ) = 0.E0 + R2( J ) = 0.E0 + W( J ) = 0.E0 + X( J ) = 0.E0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF * SRNAMT = 'CSYTRF' @@ -145,6 +148,12 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 4 CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) * * CSYTF2 * @@ -185,6 +194,19 @@ SUBROUTINE CERRSY( PATH, NUNIT ) CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK ) * +* CSYTRI2X +* + SRNAMT = 'CSYTRI2X' + INFOT = 1 + CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) +* * CSYTRS * SRNAMT = 'CSYTRS' @@ -251,13 +273,13 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 6 CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF_ROOK * SRNAMT = 'CSYTRF_ROOK' @@ -270,6 +292,12 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 4 CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * CSYTF2_ROOK * @@ -332,12 +360,121 @@ SUBROUTINE CERRSY( PATH, NUNIT ) CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CSYTRF_RK +* + SRNAMT = 'CSYTRF_RK' + INFOT = 1 + CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_RK +* + SRNAMT = 'CSYTF2_RK' + INFOT = 1 + CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3 +* + SRNAMT = 'CSYTRI_3' + INFOT = 1 + CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3X +* + SRNAMT = 'CSYTRI_3X' + INFOT = 1 + CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_3 +* + SRNAMT = 'CSYTRS_3' + INFOT = 1 + CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* CSYCON_3 +* + SRNAMT = 'CSYCON_3' + INFOT = 1 + CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSPTRF * SRNAMT = 'CSPTRF' @@ -410,6 +547,56 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 5 CALL CSPCON( 'U', 1, A, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSPCON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with Aasen's algorithm +* +* CSYTRF_AA +* + SRNAMT = 'CSYTRF_AA' + INFOT = 1 + CALL CSYTRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_AA', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_AA +* + SRNAMT = 'CSYTRS_AA' + INFOT = 1 + CALL CSYTRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYTRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYTRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYTRS_AA', INFOT, NOUT, LERR, OK ) +* END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/LIN/cerrsyx.f b/lapack-netlib/TESTING/LIN/cerrsyx.f index 63c83ee5bd..617354fab7 100644 --- a/lapack-netlib/TESTING/LIN/cerrsyx.f +++ b/lapack-netlib/TESTING/LIN/cerrsyx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -86,7 +86,7 @@ SUBROUTINE CERRSY( PATH, NUNIT ) $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -124,23 +124,23 @@ SUBROUTINE CERRSY( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E0 + E( J ) = 0.E0 + R1( J ) = 0.E0 + R2( J ) = 0.E0 + W( J ) = 0.E0 + X( J ) = 0.E0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* + IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF * SRNAMT = 'CSYTRF' @@ -153,6 +153,12 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 4 CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) * * CSYTF2 * @@ -193,6 +199,19 @@ SUBROUTINE CERRSY( PATH, NUNIT ) CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK ) * +* CSYTRI2X +* + SRNAMT = 'CSYTRI2X' + INFOT = 1 + CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) +* * CSYTRS * SRNAMT = 'CSYTRS' @@ -250,7 +269,7 @@ SUBROUTINE CERRSY( PATH, NUNIT ) NPARAMS = 0 SRNAMT = 'CSYRFSX' INFOT = 1 - CALL CSYRFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, + CALL CSYRFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, S, B, 1, X, 1, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) @@ -266,27 +285,27 @@ SUBROUTINE CERRSY( PATH, NUNIT ) $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CSYRFSX( 'U', EQ, 0, -1, A, 1, AF, 1, IP, S, B, 1, X, 1, + CALL CSYRFSX( 'U', EQ, 0, -1, A, 1, AF, 1, IP, S, B, 1, X, 1, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) INFOT = 6 - CALL CSYRFSX( 'U', EQ, 2, 1, A, 1, AF, 2, IP, S, B, 2, X, 2, + CALL CSYRFSX( 'U', EQ, 2, 1, A, 1, AF, 2, IP, S, B, 2, X, 2, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 1, IP, S, B, 2, X, 2, + CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 1, IP, S, B, 2, X, 2, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) INFOT = 12 - CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 1, X, 2, + CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 1, X, 2, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) INFOT = 14 - CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 2, X, 1, + CALL CSYRFSX( 'U', EQ, 2, 1, A, 2, AF, 2, IP, S, B, 2, X, 1, $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, $ PARAMS, W, R, INFO ) CALL CHKXER( 'CSYRFSX', INFOT, NOUT, LERR, OK ) @@ -306,13 +325,13 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 6 CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF_ROOK * SRNAMT = 'CSYTRF_ROOK' @@ -325,6 +344,12 @@ SUBROUTINE CERRSY( PATH, NUNIT ) INFOT = 4 CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * CSYTF2_ROOK * @@ -387,12 +412,121 @@ SUBROUTINE CERRSY( PATH, NUNIT ) CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CSYTRF_RK +* + SRNAMT = 'CSYTRF_RK' + INFOT = 1 + CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_RK +* + SRNAMT = 'CSYTF2_RK' + INFOT = 1 + CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3 +* + SRNAMT = 'CSYTRI_3' + INFOT = 1 + CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3X +* + SRNAMT = 'CSYTRI_3X' + INFOT = 1 + CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_3 +* + SRNAMT = 'CSYTRS_3' + INFOT = 1 + CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* CSYCON_3 +* + SRNAMT = 'CSYCON_3' + INFOT = 1 + CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSPTRF * SRNAMT = 'CSPTRF' diff --git a/lapack-netlib/TESTING/LIN/cerrtr.f b/lapack-netlib/TESTING/LIN/cerrtr.f index 2c07bfec5f..a06c0d7515 100644 --- a/lapack-netlib/TESTING/LIN/cerrtr.f +++ b/lapack-netlib/TESTING/LIN/cerrtr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRTR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRTR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrtsqr.f b/lapack-netlib/TESTING/LIN/cerrtsqr.f new file mode 100644 index 0000000000..b9d6ce3c34 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cerrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b CERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRTSQR tests the error exits for the COMPLEX routines +*> that use the TSQR decomposition of a general matrix. +*> \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 Zenver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CERRTSQR( PATH, NUNIT ) + 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 .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CGEQR, + $ CGEMQR, CGELQ, CGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.E0 / CMPLX( REAL( I+J ), 0.E0 ) + C( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + T( I, J ) = 1.E0 / CMPLX( REAL( I+J ), 0.E0 ) + END DO + W( J ) = 0.E0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* CGEQR +* + SRNAMT = 'CGEQR' + INFOT = 1 + CALL CGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'CGEQR', INFOT, NOUT, LERR, OK ) +* +* CGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'CGEMQR' + NB=1 + INFOT = 1 + CALL CGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMQR( 'R', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGEMQR( 'L', 'N', 2, 1, 1, A, 2, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'CGEMQR', INFOT, NOUT, LERR, OK ) +* +* CGELQ +* + SRNAMT = 'CGELQ' + INFOT = 1 + CALL CGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'CGELQ', INFOT, NOUT, LERR, OK ) +* +* CGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'CGEMLQ' + NB=1 + INFOT = 1 + CALL CGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'CGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRTSQR +* + END diff --git a/lapack-netlib/TESTING/LIN/cerrtz.f b/lapack-netlib/TESTING/LIN/cerrtz.f index b7cc912af4..c6649cf876 100644 --- a/lapack-netlib/TESTING/LIN/cerrtz.f +++ b/lapack-netlib/TESTING/LIN/cerrtz.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRTZ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRTZ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/cerrvx.f b/lapack-netlib/TESTING/LIN/cerrvx.f index 52ca890d1c..2bddd2b845 100644 --- a/lapack-netlib/TESTING/LIN/cerrvx.f +++ b/lapack-netlib/TESTING/LIN/cerrvx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,7 +82,7 @@ SUBROUTINE CERRVX( PATH, NUNIT ) REAL C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), $ RF( NMAX ), RW( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -90,10 +90,11 @@ SUBROUTINE CERRVX( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, - $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, - $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSV_ROOK, CSYSVX + $ CHESV, CHESV_RK ,CHESV_ROOK, CHESVX, CHKXER, + $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, + $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, + $ CSYSV, CSYSV_AA, CSYSV_RK, CSYSV_ROOK, + $ CSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -120,13 +121,14 @@ SUBROUTINE CERRVX( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -591,6 +593,12 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) * * CHESVX * @@ -636,19 +644,78 @@ SUBROUTINE CERRVX( PATH, NUNIT ) * * CHESV_ROOK * - SRNAMT = 'CHESV_ROOK' - INFOT = 1 - CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* CHESV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CHESV_RK' + INFOT = 1 + CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* CHESV_AASEN +* + SRNAMT = 'CHESV_AA' + INFOT = 1 + CALL CHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -713,6 +780,12 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) * * CSYSVX * @@ -771,6 +844,47 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* CSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CSYSV_RK' + INFOT = 1 + CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cerrvxx.f b/lapack-netlib/TESTING/LIN/cerrvxx.f index 6134bf3398..33bad4f9f1 100644 --- a/lapack-netlib/TESTING/LIN/cerrvxx.f +++ b/lapack-netlib/TESTING/LIN/cerrvxx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -85,7 +85,7 @@ SUBROUTINE CERRVX( PATH, NUNIT ) $ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -93,11 +93,11 @@ SUBROUTINE CERRVX( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, - $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, - $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSV_ROOK, CSYSVX, CGESVXX, CPOSVXX, CSYSVXX, - $ CHESVXX, CGBSVXX + $ CHESV, CHESV_RK, CHESV_ROOK, CHESVX, CHKXER, + $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, + $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, + $ CSYSV, CSYSV_RK, CSYSV_ROOK, CSYSVX, CGESVXX, + $ CPOSVXX, CSYSVXX, CHESVXX, CGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -124,13 +124,14 @@ SUBROUTINE CERRVX( PATH, NUNIT ) A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -804,6 +805,12 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) * * CHESVX * @@ -907,19 +914,60 @@ SUBROUTINE CERRVX( PATH, NUNIT ) * * CHESV_ROOK * - SRNAMT = 'CHESV_ROOK' - INFOT = 1 - CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* CHESV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CHESV_RK' + INFOT = 1 + CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -984,6 +1032,12 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) * * CSYSVX * @@ -1110,6 +1164,47 @@ SUBROUTINE CERRVX( PATH, NUNIT ) INFOT = 8 CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* CSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CSYSV_RK' + INFOT = 1 + CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cgbt01.f b/lapack-netlib/TESTING/LIN/cgbt01.f index 748ba15335..947ca3f732 100644 --- a/lapack-netlib/TESTING/LIN/cgbt01.f +++ b/lapack-netlib/TESTING/LIN/cgbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KL, KU, LDA, LDAFAC, M, N * REAL RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KL, KU, LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/cgbt02.f b/lapack-netlib/TESTING/LIN/cgbt02.f index 1335f134bc..b478fff2db 100644 --- a/lapack-netlib/TESTING/LIN/cgbt02.f +++ b/lapack-netlib/TESTING/LIN/cgbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, * LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -139,10 +139,10 @@ SUBROUTINE CGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, $ LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cgbt05.f b/lapack-netlib/TESTING/LIN/cgbt05.f index d97d94eb58..a6cfe3a093 100644 --- a/lapack-netlib/TESTING/LIN/cgbt05.f +++ b/lapack-netlib/TESTING/LIN/cgbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -176,10 +176,10 @@ SUBROUTINE CGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cgelqs.f b/lapack-netlib/TESTING/LIN/cgelqs.f index 91d00dd693..ee08c9b62d 100644 --- a/lapack-netlib/TESTING/LIN/cgelqs.f +++ b/lapack-netlib/TESTING/LIN/cgelqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -121,10 +121,10 @@ SUBROUTINE CGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cgennd.f b/lapack-netlib/TESTING/LIN/cgennd.f index 6a35dc59b8..5b8fefa7dd 100644 --- a/lapack-netlib/TESTING/LIN/cgennd.f +++ b/lapack-netlib/TESTING/LIN/cgennd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION CGENND (M, N, A, LDA) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== LOGICAL FUNCTION CGENND (M, N, A, LDA) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/TESTING/LIN/cgeqls.f b/lapack-netlib/TESTING/LIN/cgeqls.f index e8c1503c2a..b1d36107cb 100644 --- a/lapack-netlib/TESTING/LIN/cgeqls.f +++ b/lapack-netlib/TESTING/LIN/cgeqls.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -122,10 +122,10 @@ SUBROUTINE CGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cgeqrs.f b/lapack-netlib/TESTING/LIN/cgeqrs.f index 165a2cb9a8..76982924c3 100644 --- a/lapack-netlib/TESTING/LIN/cgeqrs.f +++ b/lapack-netlib/TESTING/LIN/cgeqrs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -121,10 +121,10 @@ SUBROUTINE CGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cgerqs.f b/lapack-netlib/TESTING/LIN/cgerqs.f index 00b3cc40e8..5603ed4786 100644 --- a/lapack-netlib/TESTING/LIN/cgerqs.f +++ b/lapack-netlib/TESTING/LIN/cgerqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -122,10 +122,10 @@ SUBROUTINE CGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cget01.f b/lapack-netlib/TESTING/LIN/cget01.f index 4196342b8b..ef84e3fad4 100644 --- a/lapack-netlib/TESTING/LIN/cget01.f +++ b/lapack-netlib/TESTING/LIN/cget01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAFAC, M, N * REAL RESID @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -108,10 +108,10 @@ SUBROUTINE CGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAFAC, M, N @@ -177,7 +177,7 @@ SUBROUTINE CGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, IF( K+1.LE.M ) THEN CALL CSCAL( M-K, T, AFAC( K+1, K ), 1 ) CALL CGEMV( 'No transpose', M-K, K-1, CONE, - $ AFAC( K+1, 1 ), LDAFAC, AFAC( 1, K ), 1, + $ AFAC( K+1, 1 ), LDAFAC, AFAC( 1, K ), 1, $ CONE, AFAC( K+1, K ), 1 ) END IF * diff --git a/lapack-netlib/TESTING/LIN/cget02.f b/lapack-netlib/TESTING/LIN/cget02.f index 0a26a3d63f..8fe4164588 100644 --- a/lapack-netlib/TESTING/LIN/cget02.f +++ b/lapack-netlib/TESTING/LIN/cget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -133,10 +133,10 @@ SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cget03.f b/lapack-netlib/TESTING/LIN/cget03.f index 5457d1b2e3..d08c51250c 100644 --- a/lapack-netlib/TESTING/LIN/cget03.f +++ b/lapack-netlib/TESTING/LIN/cget03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, * RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAINV, LDWORK, N * REAL RCOND, RESID @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -110,10 +110,10 @@ SUBROUTINE CGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, $ RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAINV, LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/cget04.f b/lapack-netlib/TESTING/LIN/cget04.f index 4a9d052443..a4c8c25af9 100644 --- a/lapack-netlib/TESTING/LIN/cget04.f +++ b/lapack-netlib/TESTING/LIN/cget04.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDXACT, N, NRHS * REAL RCOND, RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cget07.f b/lapack-netlib/TESTING/LIN/cget07.f index 2b2479cf8b..f64f6dd8c9 100644 --- a/lapack-netlib/TESTING/LIN/cget07.f +++ b/lapack-netlib/TESTING/LIN/cget07.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, CHKFERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CHKFERR @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -166,10 +166,10 @@ SUBROUTINE CGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cgtt01.f b/lapack-netlib/TESTING/LIN/cgtt01.f index 4bc800b80b..425c8c805a 100644 --- a/lapack-netlib/TESTING/LIN/cgtt01.f +++ b/lapack-netlib/TESTING/LIN/cgtt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, * LDWORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDWORK, N * REAL RESID @@ -21,7 +21,7 @@ * COMPLEX D( * ), DF( * ), DL( * ), DLF( * ), DU( * ), * $ DU2( * ), DUF( * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -134,10 +134,10 @@ SUBROUTINE CGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, $ LDWORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/cgtt02.f b/lapack-netlib/TESTING/LIN/cgtt02.f index 3071e20632..658cca323a 100644 --- a/lapack-netlib/TESTING/LIN/cgtt02.f +++ b/lapack-netlib/TESTING/LIN/cgtt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -124,10 +124,10 @@ SUBROUTINE CGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cgtt05.f b/lapack-netlib/TESTING/LIN/cgtt05.f index 1996ccfa40..9e6722e961 100644 --- a/lapack-netlib/TESTING/LIN/cgtt05.f +++ b/lapack-netlib/TESTING/LIN/cgtt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -165,10 +165,10 @@ SUBROUTINE CGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/chet01_3.f b/lapack-netlib/TESTING/LIN/chet01_3.f new file mode 100644 index 0000000000..3e08c094a0 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/chet01_3.f @@ -0,0 +1,264 @@ +*> \brief \b CHET01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHET01_3 reconstructs a Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by CHETRF_RK +*> (or CHETRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CHETRF_RK (or CHETRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANHE, SLAMCH + EXTERNAL LSAME, CLANHE, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVHE_ROOK, CSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG, REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO J = 1, N + IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + END DO +* +* 2) Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call CLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVHE_RK again to multiply by U (or L ). +* + CALL CLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + END DO + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + END DO + ELSE + DO J = 1, N + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + DO I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS + END IF +* +* b) Convert to factor of L (or U) +* + CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of CHET01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/chet01_aa.f b/lapack-netlib/TESTING/LIN/chet01_aa.f new file mode 100644 index 0000000000..3301a317ca --- /dev/null +++ b/lapack-netlib/TESTING/LIN/chet01_aa.f @@ -0,0 +1,269 @@ +*> \brief \b CHET01_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHET01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, +* C, LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHET01_AA reconstructs a hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The original hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by CHETRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CHETRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is COMPLEX +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CHET01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, CLANHE + EXTERNAL LSAME, SLAMCH, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVHE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL CLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL CLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL CLACGV( N-1, C( 2, 1 ), LDC+1 ) + ELSE + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL CLACGV( N-1, C( 1, 2 ), LDC+1 ) + ENDIF +* +* Call CTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Left', UPLO, 'Conjugate transpose', 'Unit', + $ N-1, N, CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), + $ LDC ) + ELSE + CALL CTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call CTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL CTRMM( 'Right', UPLO, 'Conjugate transpose', 'Unit', N, + $ N-1, CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), + $ LDC ) + END IF + ENDIF +* +* Apply hermitian pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of CHET01_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/chkxer.f b/lapack-netlib/TESTING/LIN/chkxer.f index 85f0cb1528..86a44e38f8 100644 --- a/lapack-netlib/TESTING/LIN/chkxer.f +++ b/lapack-netlib/TESTING/LIN/chkxer.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) -* +* * .. Scalar Arguments .. * LOGICAL LERR, OK * CHARACTER*(*) SRNAMT @@ -26,12 +26,12 @@ * END IF * LERR = .FALSE. * RETURN -* +* * 9999 FORMAT( ' *** Illegal value of parameter number ', I2, * $ ' not detected by ', A6, ' ***' ) -* +* * End of CHKXER. -* +* * END * *> \par Purpose: @@ -47,12 +47,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -62,7 +62,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * -- LAPACK test routine (input) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/LIN/chpt01.f b/lapack-netlib/TESTING/LIN/chpt01.f index 898a57c435..ecb0bebcd9 100644 --- a/lapack-netlib/TESTING/LIN/chpt01.f +++ b/lapack-netlib/TESTING/LIN/chpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), AFAC( * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CHPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/clahilb.f b/lapack-netlib/TESTING/LIN/clahilb.f index 95b437214c..0ce9eb1b51 100644 --- a/lapack-netlib/TESTING/LIN/clahilb.f +++ b/lapack-netlib/TESTING/LIN/clahilb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, +* SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, * INFO, PATH) -* +* * .. Scalar Arguments .. * INTEGER T, N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. @@ -18,7 +18,7 @@ * COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -121,23 +121,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== - SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, + SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, $ INFO, PATH) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER T, N, NRHS, LDA, LDX, LDB, INFO @@ -165,10 +165,10 @@ SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) * * d's are generated from random permuation 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 D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), $ (-.5,-.5),(.5,-.5),(.5,.5)/ DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), @@ -250,14 +250,14 @@ SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) $ * (N +J -1) END DO -* +* * If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* IF ( LSAMEN( 2, C2, 'SY' ) ) THEN DO J = 1, NRHS DO I = 1, N - X(I, J) = + X(I, J) = $ INVD1(MOD(J,SIZE_D)+1) * - $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ ((WORK(I)*WORK(J)) / (I + J - 1)) $ * INVD1(MOD(I,SIZE_D)+1) END DO END DO @@ -272,4 +272,4 @@ SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, END DO END IF END - + diff --git a/lapack-netlib/TESTING/LIN/claipd.f b/lapack-netlib/TESTING/LIN/claipd.f index 7d041f3531..acc0c5b940 100644 --- a/lapack-netlib/TESTING/LIN/claipd.f +++ b/lapack-netlib/TESTING/LIN/claipd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAIPD( N, A, INDA, VINDA ) -* +* * .. Scalar Arguments .. * INTEGER INDA, N, VINDA * .. * .. Array Arguments .. * COMPLEX A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,22 +71,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CLAIPD( N, A, INDA, VINDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INDA, N, VINDA diff --git a/lapack-netlib/TESTING/LIN/claptm.f b/lapack-netlib/TESTING/LIN/claptm.f index 48f94dadb6..74eb32853b 100644 --- a/lapack-netlib/TESTING/LIN/claptm.f +++ b/lapack-netlib/TESTING/LIN/claptm.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, * LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL D( * ) * COMPLEX B( LDB, * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -129,10 +129,10 @@ SUBROUTINE CLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, $ LDB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/clarhs.f b/lapack-netlib/TESTING/LIN/clarhs.f index 4bf27d7bdb..ddf5706a58 100644 --- a/lapack-netlib/TESTING/LIN/clarhs.f +++ b/lapack-netlib/TESTING/LIN/clarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -209,10 +209,10 @@ SUBROUTINE CLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/LIN/clatb4.f b/lapack-netlib/TESTING/LIN/clatb4.f index f98cf24f98..a87491db94 100644 --- a/lapack-netlib/TESTING/LIN/clatb4.f +++ b/lapack-netlib/TESTING/LIN/clatb4.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KL, KU, M, MODE, N * REAL ANORM, CNDNUM * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex_lin * @@ -121,10 +121,10 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, TYPE @@ -340,12 +340,10 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ANORM = ONE END IF * - ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR. - $ LSAMEN( 2, C2, 'HE' ) .OR. LSAMEN( 2, C2, 'HP' ) .OR. - $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * -* xPO, xPP, xHE, xHP, xSY, xSP: Set parameters to generate a -* symmetric or Hermitian matrix. +* xPO, xPP: Set parameters to generate a +* symmetric or Hermitian positive definite matrix. * * Set TYPE, the type of matrix to be generated. * @@ -377,6 +375,43 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'HE' ) .OR. LSAMEN( 2, C2, 'HP' ) .OR. + $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN +* +* xHE, xHP, xSY, xSP: Set parameters to generate a +* symmetric or Hermitian matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/clatb5.f b/lapack-netlib/TESTING/LIN/clatb5.f index 883eb6ba09..f6a0b5acee 100644 --- a/lapack-netlib/TESTING/LIN/clatb5.f +++ b/lapack-netlib/TESTING/LIN/clatb5.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * REAL ANORM, CNDNUM * INTEGER IMAT, KL, KU, MODE, N * CHARACTER DIST, TYPE * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -114,10 +114,10 @@ SUBROUTINE CLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ANORM, CNDNUM diff --git a/lapack-netlib/TESTING/LIN/clatsp.f b/lapack-netlib/TESTING/LIN/clatsp.f index e474197582..8d6df94df5 100644 --- a/lapack-netlib/TESTING/LIN/clatsp.f +++ b/lapack-netlib/TESTING/LIN/clatsp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATSP( UPLO, N, X, ISEED ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -18,7 +18,7 @@ * INTEGER ISEED( * ) * COMPLEX X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CLATSP( UPLO, N, X, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/clatsy.f b/lapack-netlib/TESTING/LIN/clatsy.f index a4553a6234..4a4260b05b 100644 --- a/lapack-netlib/TESTING/LIN/clatsy.f +++ b/lapack-netlib/TESTING/LIN/clatsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATSY( UPLO, N, X, LDX, ISEED ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDX, N @@ -18,7 +18,7 @@ * INTEGER ISEED( * ) * COMPLEX X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CLATSY( UPLO, N, X, LDX, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/clattb.f b/lapack-netlib/TESTING/LIN/clattb.f index ba186deb2f..4127f8189b 100644 --- a/lapack-netlib/TESTING/LIN/clattb.f +++ b/lapack-netlib/TESTING/LIN/clattb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, * LDAB, B, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, KD, LDAB, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX AB( LDAB, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -141,10 +141,10 @@ SUBROUTINE CLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, $ LDAB, B, WORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clattp.f b/lapack-netlib/TESTING/LIN/clattp.f index 14da642c75..e118520dce 100644 --- a/lapack-netlib/TESTING/LIN/clattp.f +++ b/lapack-netlib/TESTING/LIN/clattp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX AP( * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -131,10 +131,10 @@ SUBROUTINE CLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, $ RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clattr.f b/lapack-netlib/TESTING/LIN/clattr.f index 55503e50b1..d959692f82 100644 --- a/lapack-netlib/TESTING/LIN/clattr.f +++ b/lapack-netlib/TESTING/LIN/clattr.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, LDA, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -138,10 +138,10 @@ SUBROUTINE CLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, $ WORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clavhp.f b/lapack-netlib/TESTING/LIN/clavhp.f index b57731dcc9..1d0176cbc7 100644 --- a/lapack-netlib/TESTING/LIN/clavhp.f +++ b/lapack-netlib/TESTING/LIN/clavhp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -131,10 +131,10 @@ SUBROUTINE CLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clavsp.f b/lapack-netlib/TESTING/LIN/clavsp.f index 1fe2cedc93..311f0b4e12 100644 --- a/lapack-netlib/TESTING/LIN/clavsp.f +++ b/lapack-netlib/TESTING/LIN/clavsp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -131,10 +131,10 @@ SUBROUTINE CLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clqt01.f b/lapack-netlib/TESTING/LIN/clqt01.f index 63a9ecec35..a62de24a8f 100644 --- a/lapack-netlib/TESTING/LIN/clqt01.f +++ b/lapack-netlib/TESTING/LIN/clqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/clqt02.f b/lapack-netlib/TESTING/LIN/clqt02.f index f556723659..9b0c86eeca 100644 --- a/lapack-netlib/TESTING/LIN/clqt02.f +++ b/lapack-netlib/TESTING/LIN/clqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -135,10 +135,10 @@ SUBROUTINE CLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/clqt03.f b/lapack-netlib/TESTING/LIN/clqt03.f index 0f8f2b3b74..22c299a08c 100644 --- a/lapack-netlib/TESTING/LIN/clqt03.f +++ b/lapack-netlib/TESTING/LIN/clqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/clqt04.f b/lapack-netlib/TESTING/LIN/clqt04.f new file mode 100644 index 0000000000..7581fe5fad --- /dev/null +++ b/lapack-netlib/TESTING/LIN/clqt04.f @@ -0,0 +1,262 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLQT04 tests CGELQT and CGEMLQT. +*> \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] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CLQT04(M,N,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0) + PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK, LDT + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH + REAL CLANGE, CLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL CLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL CLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL CGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N ) + CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy L +* + CALL CLASET( 'Full', LL, N, CZERO, CZERO, L, LL ) + CALL CLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = CLANGE( '1', M, N, A, M, RWORK ) + RESID = CLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', N, N, CZERO, ONE, L, LL ) + CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), L, LL) + RESID = CLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/lapack-netlib/TESTING/LIN/clqt05.f b/lapack-netlib/TESTING/LIN/clqt05.f new file mode 100644 index 0000000000..e6595a782d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/clqt05.f @@ -0,0 +1,289 @@ +*> \brief \b CLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CQRT05 tests CTPLQT and CTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE CLQT05(M,N,L,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH + REAL CLANGE, CLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL CLASET( 'Full', M, N2, CZERO, CZERO, A, M ) + CALL CLASET( 'Full', NB, M, CZERO, CZERO, T, NB ) + DO J=1,M + CALL CLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL CLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL CLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL CLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL CTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL CLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 ) + CALL CGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL CLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 ) + CALL CLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*C| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = CLANGE( '1', M, N2, A, M, RWORK ) + RESID = CLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL CLASET( 'Full', N2, N2, CZERO, ONE, R, N2 ) + CALL CHERK( 'U', 'N', N2, N2, REAL(-ONE), Q, N2, REAL(ONE), + $ R, N2 ) + RESID = CLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL CLASET( 'Full', N2, M, CZERO, ONE, C, N2 ) + DO J=1,M + CALL CLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = CLANGE( '1', N2, M, C, N2, RWORK) + CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL CTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL CGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = CLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL CLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL CTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL CGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = CLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL CLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = CLANGE( '1', M, N2, D, M, RWORK) + CALL CLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL CTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL CGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = CLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL CTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL CGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = CLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/cpbt01.f b/lapack-netlib/TESTING/LIN/cpbt01.f index cefbcdd23b..6b0e140e7a 100644 --- a/lapack-netlib/TESTING/LIN/cpbt01.f +++ b/lapack-netlib/TESTING/LIN/cpbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDAFAC, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -120,10 +120,10 @@ SUBROUTINE CPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpbt02.f b/lapack-netlib/TESTING/LIN/cpbt02.f index 3413aa03e4..35d22eecd5 100644 --- a/lapack-netlib/TESTING/LIN/cpbt02.f +++ b/lapack-netlib/TESTING/LIN/cpbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpbt05.f b/lapack-netlib/TESTING/LIN/cpbt05.f index 2c41fe21c0..afe67695ad 100644 --- a/lapack-netlib/TESTING/LIN/cpbt05.f +++ b/lapack-netlib/TESTING/LIN/cpbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -171,10 +171,10 @@ SUBROUTINE CPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpot01.f b/lapack-netlib/TESTING/LIN/cpot01.f index 25764e8f2f..4de30b46b6 100644 --- a/lapack-netlib/TESTING/LIN/cpot01.f +++ b/lapack-netlib/TESTING/LIN/cpot01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, N @@ -19,7 +19,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpot02.f b/lapack-netlib/TESTING/LIN/cpot02.f index 57fb556f01..3c9657650a 100644 --- a/lapack-netlib/TESTING/LIN/cpot02.f +++ b/lapack-netlib/TESTING/LIN/cpot02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -127,10 +127,10 @@ SUBROUTINE CPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpot03.f b/lapack-netlib/TESTING/LIN/cpot03.f index fe45e0d163..9faee7466c 100644 --- a/lapack-netlib/TESTING/LIN/cpot03.f +++ b/lapack-netlib/TESTING/LIN/cpot03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpot05.f b/lapack-netlib/TESTING/LIN/cpot05.f index 3bec0258f7..438d73c3bf 100644 --- a/lapack-netlib/TESTING/LIN/cpot05.f +++ b/lapack-netlib/TESTING/LIN/cpot05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -165,10 +165,10 @@ SUBROUTINE CPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cppt01.f b/lapack-netlib/TESTING/LIN/cppt01.f index 5ebefb68f8..c75c085ddc 100644 --- a/lapack-netlib/TESTING/LIN/cppt01.f +++ b/lapack-netlib/TESTING/LIN/cppt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPPT01( UPLO, N, A, AFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -19,7 +19,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), AFAC( * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CPPT01( UPLO, N, A, AFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cppt02.f b/lapack-netlib/TESTING/LIN/cppt02.f index 6e27e1b582..29336a6764 100644 --- a/lapack-netlib/TESTING/LIN/cppt02.f +++ b/lapack-netlib/TESTING/LIN/cppt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -123,10 +123,10 @@ SUBROUTINE CPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cppt03.f b/lapack-netlib/TESTING/LIN/cppt03.f index 8c18d523ee..175ced1739 100644 --- a/lapack-netlib/TESTING/LIN/cppt03.f +++ b/lapack-netlib/TESTING/LIN/cppt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDWORK, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), AINV( * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -110,10 +110,10 @@ SUBROUTINE CPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cppt05.f b/lapack-netlib/TESTING/LIN/cppt05.f index 4ac25de3a6..1e279bf35f 100644 --- a/lapack-netlib/TESTING/LIN/cppt05.f +++ b/lapack-netlib/TESTING/LIN/cppt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX AP( * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -157,10 +157,10 @@ SUBROUTINE CPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cpst01.f b/lapack-netlib/TESTING/LIN/cpst01.f index d5d54f6dda..d446c01239 100644 --- a/lapack-netlib/TESTING/LIN/cpst01.f +++ b/lapack-netlib/TESTING/LIN/cpst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, * PIV, RWORK, RESID, RANK ) -* +* * .. Scalar Arguments .. * REAL RESID * INTEGER LDA, LDAFAC, LDPERM, N, RANK @@ -22,7 +22,7 @@ * REAL RWORK( * ) * INTEGER PIV( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, $ PIV, RWORK, RESID, RANK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL RESID diff --git a/lapack-netlib/TESTING/LIN/cptt01.f b/lapack-netlib/TESTING/LIN/cptt01.f index d37bc108e5..b3a242b284 100644 --- a/lapack-netlib/TESTING/LIN/cptt01.f +++ b/lapack-netlib/TESTING/LIN/cptt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPTT01( N, D, E, DF, EF, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER N * REAL RESID @@ -18,7 +18,7 @@ * REAL D( * ), DF( * ) * COMPLEX E( * ), EF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -80,22 +80,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CPTT01( N, D, E, DF, EF, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/TESTING/LIN/cptt02.f b/lapack-netlib/TESTING/LIN/cptt02.f index 2d947a98a0..c86ab097f3 100644 --- a/lapack-netlib/TESTING/LIN/cptt02.f +++ b/lapack-netlib/TESTING/LIN/cptt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPTT02( UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * REAL D( * ) * COMPLEX B( LDB, * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CPTT02( UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cptt05.f b/lapack-netlib/TESTING/LIN/cptt05.f index 133ca51ce6..88ae655bf5 100644 --- a/lapack-netlib/TESTING/LIN/cptt05.f +++ b/lapack-netlib/TESTING/LIN/cptt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, * FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, LDXACT, N, NRHS * .. @@ -19,7 +19,7 @@ * COMPLEX B( LDB, * ), E( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -150,10 +150,10 @@ SUBROUTINE CPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, $ FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/cqlt01.f b/lapack-netlib/TESTING/LIN/cqlt01.f index e2f497b733..884f9c200b 100644 --- a/lapack-netlib/TESTING/LIN/cqlt01.f +++ b/lapack-netlib/TESTING/LIN/cqlt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqlt02.f b/lapack-netlib/TESTING/LIN/cqlt02.f index 5cfa042f60..42af6b9e13 100644 --- a/lapack-netlib/TESTING/LIN/cqlt02.f +++ b/lapack-netlib/TESTING/LIN/cqlt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqlt03.f b/lapack-netlib/TESTING/LIN/cqlt03.f index cc06746753..ef1ff2cec7 100644 --- a/lapack-netlib/TESTING/LIN/cqlt03.f +++ b/lapack-netlib/TESTING/LIN/cqlt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqpt01.f b/lapack-netlib/TESTING/LIN/cqpt01.f index 3e60214988..aa9ff4d91a 100644 --- a/lapack-netlib/TESTING/LIN/cqpt01.f +++ b/lapack-netlib/TESTING/LIN/cqpt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -120,10 +120,10 @@ REAL FUNCTION CQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt01.f b/lapack-netlib/TESTING/LIN/cqrt01.f index b5cdbac265..6f7420b19e 100644 --- a/lapack-netlib/TESTING/LIN/cqrt01.f +++ b/lapack-netlib/TESTING/LIN/cqrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt01p.f b/lapack-netlib/TESTING/LIN/cqrt01p.f index d9a4069576..814c22dbff 100644 --- a/lapack-netlib/TESTING/LIN/cqrt01p.f +++ b/lapack-netlib/TESTING/LIN/cqrt01p.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt02.f b/lapack-netlib/TESTING/LIN/cqrt02.f index 94b775a969..39f0f3e1a7 100644 --- a/lapack-netlib/TESTING/LIN/cqrt02.f +++ b/lapack-netlib/TESTING/LIN/cqrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -135,10 +135,10 @@ SUBROUTINE CQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt03.f b/lapack-netlib/TESTING/LIN/cqrt03.f index 9293f9f98c..03d7077ab4 100644 --- a/lapack-netlib/TESTING/LIN/cqrt03.f +++ b/lapack-netlib/TESTING/LIN/cqrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt04.f b/lapack-netlib/TESTING/LIN/cqrt04.f index e3715a9fd4..1b289417d6 100644 --- a/lapack-netlib/TESTING/LIN/cqrt04.f +++ b/lapack-netlib/TESTING/LIN/cqrt04.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT04(M,N,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER M, N, NB, LDT * .. Return values .. * REAL RESULT(6) -* +* * *> \par Purpose: * ============= @@ -54,17 +54,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -74,7 +74,7 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -87,10 +87,11 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * ===================================================================== * * .. -* .. Local allocatable arrays +* .. Local allocatable arrays COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) + REAL, ALLOCATABLE :: RWORK(:) * * .. Parameters .. REAL ZERO @@ -105,17 +106,17 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - REAL SLAMCH + REAL SLAMCH REAL CLANGE, CLANSY LOGICAL LSAME EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN * .. * .. Data statements .. - DATA ISEED / 1988, 1989, 1990, 1991 / -* + DATA ISEED / 1988, 1989, 1990, 1991 / +* EPS = SLAMCH( 'Epsilon' ) K = MIN(M,N) L = MAX(M,N) @@ -123,8 +124,8 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * * Dynamically allocate local arrays * - ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), - $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), $ D(N,M), DF(N,M) ) * * Put random numbers into A and copy to AF @@ -142,7 +143,7 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * Generate the m-by-m matrix Q * CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M ) - CALL CGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, + CALL CGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, $ WORK, INFO ) * * Copy R @@ -178,7 +179,7 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * * Apply Q to C as Q*C * - CALL CGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + CALL CGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |Q*C - Q*C| / |C| @@ -197,7 +198,7 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * * Apply Q to C as QT*C * - CALL CGEMQRT( 'L', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + CALL CGEMQRT( 'L', 'C', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |QT*C - QT*C| / |C| @@ -208,7 +209,7 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -220,8 +221,8 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * * Apply Q to D as D*Q * - CALL CGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL CGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*Q - D*Q| / |D| * @@ -239,8 +240,8 @@ SUBROUTINE CQRT04(M,N,NB,RESULT) * * Apply Q to D as D*QT * - CALL CGEMQRT( 'R', 'C', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL CGEMQRT( 'R', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/cqrt05.f b/lapack-netlib/TESTING/LIN/cqrt05.f index 256045af62..b6ce21da7a 100644 --- a/lapack-netlib/TESTING/LIN/cqrt05.f +++ b/lapack-netlib/TESTING/LIN/cqrt05.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT05(M,N,L,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER LWORK, M, N, L, NB, LDT * .. Return values .. * REAL RESULT(6) -* +* * *> \par Purpose: * ============= @@ -45,7 +45,7 @@ *> The number of rows of the upper trapezoidal part the *> lower test matrix. 0 <= L <= M. *> \endverbatim -*> +*> *> \param[in] NB *> \verbatim *> NB is INTEGER @@ -61,17 +61,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -81,7 +81,7 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -92,12 +92,13 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) REAL RESULT(6) * * ===================================================================== -* +* * .. -* .. Local allocatable arrays +* .. Local allocatable arrays COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) + REAL, ALLOCATABLE :: RWORK(:) * * .. Parameters .. REAL ZERO @@ -112,14 +113,14 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - REAL SLAMCH + REAL SLAMCH REAL CLANGE, CLANSY LOGICAL LSAME EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME * .. * .. Data statements .. DATA ISEED / 1988, 1989, 1990, 1991 / -* +* EPS = SLAMCH( 'Epsilon' ) K = N M2 = M+N @@ -133,7 +134,7 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) * Dynamically allocate all arrays * ALLOCATE(A(M2,N),AF(M2,N),Q(M2,M2),R(M2,M2),RWORK(M2), - $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), + $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), $ D(N,M2),DF(N,M2) ) * * Put random stuff into A @@ -188,7 +189,7 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) * Compute |I - Q'*Q| and store in RESULT(2) * CALL CLASET( 'Full', M2, M2, CZERO, ONE, R, M2 ) - CALL CHERK( 'U', 'C', M2, M2, REAL(-ONE), Q, M2, REAL(ONE), + CALL CHERK( 'U', 'C', M2, M2, REAL(-ONE), Q, M2, REAL(ONE), $ R, M2 ) RESID = CLANSY( '1', 'Upper', M2, R, M2, RWORK ) RESULT( 2 ) = RESID / (EPS*MAX(1,M2)) @@ -223,7 +224,7 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) * Apply Q to C as QT*C * CALL CTPMQRT( 'L','C',M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,M2, - $ CF(NP1,1),M2,WORK,INFO) + $ CF(NP1,1),M2,WORK,INFO) * * Compute |QT*C - QT*C| / |C| * @@ -233,7 +234,7 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M2)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -265,8 +266,8 @@ SUBROUTINE CQRT05(M,N,L,NB,RESULT) * Apply Q to D as D*QT * CALL CTPMQRT('R','C',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N, - $ DF(1,NP1),N,WORK,INFO) - + $ DF(1,NP1),N,WORK,INFO) + * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/cqrt11.f b/lapack-netlib/TESTING/LIN/cqrt11.f index 07e007f4d3..7445059a43 100644 --- a/lapack-netlib/TESTING/LIN/cqrt11.f +++ b/lapack-netlib/TESTING/LIN/cqrt11.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CQRT11( M, K, A, LDA, TAU, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M * .. * .. Array Arguments .. * COMPLEX A( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== REAL FUNCTION CQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M diff --git a/lapack-netlib/TESTING/LIN/cqrt12.f b/lapack-netlib/TESTING/LIN/cqrt12.f index 181c27f0c0..5659d2b364 100644 --- a/lapack-netlib/TESTING/LIN/cqrt12.f +++ b/lapack-netlib/TESTING/LIN/cqrt12.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK, * RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * REAL RWORK( * ), S( * ) * COMPLEX A( LDA, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -97,10 +97,10 @@ REAL FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK, $ RWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/cqrt13.f b/lapack-netlib/TESTING/LIN/cqrt13.f index be9130fbc8..3368858bec 100644 --- a/lapack-netlib/TESTING/LIN/cqrt13.f +++ b/lapack-netlib/TESTING/LIN/cqrt13.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, SCALE * REAL NORMA @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, SCALE diff --git a/lapack-netlib/TESTING/LIN/cqrt14.f b/lapack-netlib/TESTING/LIN/cqrt14.f index 5428d38465..b2a31e99d0 100644 --- a/lapack-netlib/TESTING/LIN/cqrt14.f +++ b/lapack-netlib/TESTING/LIN/cqrt14.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CQRT14( TRANS, M, N, NRHS, A, LDA, X, * LDX, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDX, LWORK, M, N, NRHS @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -116,10 +116,10 @@ REAL FUNCTION CQRT14( TRANS, M, N, NRHS, A, LDA, X, $ LDX, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cqrt15.f b/lapack-netlib/TESTING/LIN/cqrt15.f index a86662a9fa..d01f3a7caf 100644 --- a/lapack-netlib/TESTING/LIN/cqrt15.f +++ b/lapack-netlib/TESTING/LIN/cqrt15.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, * RANK, NORMA, NORMB, ISEED, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE * REAL NORMA, NORMB @@ -20,7 +20,7 @@ * REAL S( * ) * COMPLEX A( LDA, * ), B( LDB, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -149,10 +149,10 @@ SUBROUTINE CQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, $ RANK, NORMA, NORMB, ISEED, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE diff --git a/lapack-netlib/TESTING/LIN/cqrt16.f b/lapack-netlib/TESTING/LIN/cqrt16.f index 701e1f4656..84ee5f4265 100644 --- a/lapack-netlib/TESTING/LIN/cqrt16.f +++ b/lapack-netlib/TESTING/LIN/cqrt16.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -133,10 +133,10 @@ SUBROUTINE CQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/cqrt17.f b/lapack-netlib/TESTING/LIN/cqrt17.f index 1e16df9c77..1fe28d6fe2 100644 --- a/lapack-netlib/TESTING/LIN/cqrt17.f +++ b/lapack-netlib/TESTING/LIN/cqrt17.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CQRT17( TRANS, IRESID, M, N, NRHS, A, * LDA, X, LDX, B, LDB, C, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), C( LDB, * ), * $ WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_lin * @@ -150,10 +150,10 @@ REAL FUNCTION CQRT17( TRANS, IRESID, M, N, NRHS, A, $ LDA, X, LDX, B, LDB, C, WORK, LWORK ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -172,8 +172,7 @@ REAL FUNCTION CQRT17( TRANS, IRESID, M, N, NRHS, A, * .. * .. Local Scalars .. INTEGER INFO, ISCL, NCOLS, NROWS - REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX, - $ SMLNUM + REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, SMLNUM * .. * .. Local Arrays .. REAL RWORK( 1 ) diff --git a/lapack-netlib/TESTING/LIN/crqt01.f b/lapack-netlib/TESTING/LIN/crqt01.f index 03548898ba..f80361c5e4 100644 --- a/lapack-netlib/TESTING/LIN/crqt01.f +++ b/lapack-netlib/TESTING/LIN/crqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/crqt02.f b/lapack-netlib/TESTING/LIN/crqt02.f index a59e752d72..d9501e5462 100644 --- a/lapack-netlib/TESTING/LIN/crqt02.f +++ b/lapack-netlib/TESTING/LIN/crqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/crqt03.f b/lapack-netlib/TESTING/LIN/crqt03.f index d8e6c04635..92f5cbe5c2 100644 --- a/lapack-netlib/TESTING/LIN/crqt03.f +++ b/lapack-netlib/TESTING/LIN/crqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -136,10 +136,10 @@ SUBROUTINE CRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/crzt01.f b/lapack-netlib/TESTING/LIN/crzt01.f index c93fe21cb3..73141982a1 100644 --- a/lapack-netlib/TESTING/LIN/crzt01.f +++ b/lapack-netlib/TESTING/LIN/crzt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CRZT01( M, N, A, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -85,12 +85,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -98,10 +98,10 @@ REAL FUNCTION CRZT01( M, N, A, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/crzt02.f b/lapack-netlib/TESTING/LIN/crzt02.f index 953f1791d2..53a69457c4 100644 --- a/lapack-netlib/TESTING/LIN/crzt02.f +++ b/lapack-netlib/TESTING/LIN/crzt02.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION CRZT02( M, N, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX AF( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -91,10 +91,10 @@ REAL FUNCTION CRZT02( M, N, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/csbmv.f b/lapack-netlib/TESTING/LIN/csbmv.f index ae5f3ea4fe..776de784a1 100644 --- a/lapack-netlib/TESTING/LIN/csbmv.f +++ b/lapack-netlib/TESTING/LIN/csbmv.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, K, LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -152,10 +152,10 @@ SUBROUTINE CSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cspt01.f b/lapack-netlib/TESTING/LIN/cspt01.f index c373f90708..5be698121e 100644 --- a/lapack-netlib/TESTING/LIN/cspt01.f +++ b/lapack-netlib/TESTING/LIN/cspt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), AFAC( * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cspt02.f b/lapack-netlib/TESTING/LIN/cspt02.f index 758d5e18c4..263c07bdce 100644 --- a/lapack-netlib/TESTING/LIN/cspt02.f +++ b/lapack-netlib/TESTING/LIN/cspt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -123,10 +123,10 @@ SUBROUTINE CSPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/cspt03.f b/lapack-netlib/TESTING/LIN/cspt03.f index 154584b760..b15dad966c 100644 --- a/lapack-netlib/TESTING/LIN/cspt03.f +++ b/lapack-netlib/TESTING/LIN/cspt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDW, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( * ), AINV( * ), WORK( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -110,10 +110,10 @@ SUBROUTINE CSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/csyt01_3.f b/lapack-netlib/TESTING/LIN/csyt01_3.f new file mode 100644 index 0000000000..9d4ed77ad1 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/csyt01_3.f @@ -0,0 +1,253 @@ +*> \brief \b CSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by CSYTRF_RK +*> (or CSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF_RK (or CSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, CLANSY + EXTERNAL LSAME, SLAMCH, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVSY_ROOK, CSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVSY_ROOK again to multiply by U (or L ). +* + CALL CLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of CSYT01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/csyt01_aa.f b/lapack-netlib/TESTING/LIN/csyt01_aa.f new file mode 100644 index 0000000000..3d35a42b99 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/csyt01_aa.f @@ -0,0 +1,265 @@ +*> \brief \b CSYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYT01 reconstructs a hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by CSYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @generated from LIN/dsyt01_aa.f, fortran d -> c, Thu Nov 17 13:01:50 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) + REAL RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = 0.0E+0, CONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, CLANSY + EXTERNAL LSAME, SLAMCH, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVSY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL CLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL CLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF +* +* Call CTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL CTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call CTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL CTRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF + ENDIF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of CSYT01 +* + END diff --git a/lapack-netlib/TESTING/LIN/csyt02.f b/lapack-netlib/TESTING/LIN/csyt02.f index 86d39eb23b..4707b3863c 100644 --- a/lapack-netlib/TESTING/LIN/csyt02.f +++ b/lapack-netlib/TESTING/LIN/csyt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -127,10 +127,10 @@ SUBROUTINE CSYT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/csyt03.f b/lapack-netlib/TESTING/LIN/csyt03.f index dd9298c627..92ed42502e 100644 --- a/lapack-netlib/TESTING/LIN/csyt03.f +++ b/lapack-netlib/TESTING/LIN/csyt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/ctbt02.f b/lapack-netlib/TESTING/LIN/ctbt02.f index 576dbc3bc8..adf12192bb 100644 --- a/lapack-netlib/TESTING/LIN/ctbt02.f +++ b/lapack-netlib/TESTING/LIN/ctbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, * LDX, B, LDB, WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -161,10 +161,10 @@ SUBROUTINE CTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, $ LDX, B, LDB, WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctbt03.f b/lapack-netlib/TESTING/LIN/ctbt03.f index afb63a70dd..404847b584 100644 --- a/lapack-netlib/TESTING/LIN/ctbt03.f +++ b/lapack-netlib/TESTING/LIN/ctbt03.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, * SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -22,7 +22,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -177,10 +177,10 @@ SUBROUTINE CTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, $ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctbt05.f b/lapack-netlib/TESTING/LIN/ctbt05.f index fdd9745eee..d3d23424b9 100644 --- a/lapack-netlib/TESTING/LIN/ctbt05.f +++ b/lapack-netlib/TESTING/LIN/ctbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -189,10 +189,10 @@ SUBROUTINE CTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctbt06.f b/lapack-netlib/TESTING/LIN/ctbt06.f index 0692b8d346..0f40ec92d4 100644 --- a/lapack-netlib/TESTING/LIN/ctbt06.f +++ b/lapack-netlib/TESTING/LIN/ctbt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, * RWORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER KD, LDAB, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, $ RWORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctpt01.f b/lapack-netlib/TESTING/LIN/ctpt01.f index 40a2c2ca0d..1c3ecccb76 100644 --- a/lapack-netlib/TESTING/LIN/ctpt01.f +++ b/lapack-netlib/TESTING/LIN/ctpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -19,7 +19,7 @@ * REAL RWORK( * ) * COMPLEX AINVP( * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctpt02.f b/lapack-netlib/TESTING/LIN/ctpt02.f index 9216ab623f..afdd3a1536 100644 --- a/lapack-netlib/TESTING/LIN/ctpt02.f +++ b/lapack-netlib/TESTING/LIN/ctpt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, * WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -149,10 +149,10 @@ SUBROUTINE CTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, $ WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctpt03.f b/lapack-netlib/TESTING/LIN/ctpt03.f index da1c916b9c..f038478ccf 100644 --- a/lapack-netlib/TESTING/LIN/ctpt03.f +++ b/lapack-netlib/TESTING/LIN/ctpt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, * TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL CNORM( * ) * COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -162,10 +162,10 @@ SUBROUTINE CTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, $ TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctpt05.f b/lapack-netlib/TESTING/LIN/ctpt05.f index 80d0dbf79f..49d17d90d6 100644 --- a/lapack-netlib/TESTING/LIN/ctpt05.f +++ b/lapack-netlib/TESTING/LIN/ctpt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX AP( * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -175,10 +175,10 @@ SUBROUTINE CTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctpt06.f b/lapack-netlib/TESTING/LIN/ctpt06.f index a6a06c774f..803c18f1c9 100644 --- a/lapack-netlib/TESTING/LIN/ctpt06.f +++ b/lapack-netlib/TESTING/LIN/ctpt06.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -19,7 +19,7 @@ * REAL RWORK( * ) * COMPLEX AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctrt01.f b/lapack-netlib/TESTING/LIN/ctrt01.f index a0fed9cff7..6bd59e7650 100644 --- a/lapack-netlib/TESTING/LIN/ctrt01.f +++ b/lapack-netlib/TESTING/LIN/ctrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, LDAINV, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AINV( LDAINV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -125,10 +125,10 @@ SUBROUTINE CTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctrt02.f b/lapack-netlib/TESTING/LIN/ctrt02.f index 19dd230a65..205d12d8e1 100644 --- a/lapack-netlib/TESTING/LIN/ctrt02.f +++ b/lapack-netlib/TESTING/LIN/ctrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, * LDB, WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -157,10 +157,10 @@ SUBROUTINE CTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, $ LDB, WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctrt03.f b/lapack-netlib/TESTING/LIN/ctrt03.f index 69d6684799..3196f6a2df 100644 --- a/lapack-netlib/TESTING/LIN/ctrt03.f +++ b/lapack-netlib/TESTING/LIN/ctrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, * CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -171,10 +171,10 @@ SUBROUTINE CTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, $ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctrt05.f b/lapack-netlib/TESTING/LIN/ctrt05.f index 515c7aabb1..7f05f9c9f1 100644 --- a/lapack-netlib/TESTING/LIN/ctrt05.f +++ b/lapack-netlib/TESTING/LIN/ctrt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -182,10 +182,10 @@ SUBROUTINE CTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctrt06.f b/lapack-netlib/TESTING/LIN/ctrt06.f index e11db59711..7dff470386 100644 --- a/lapack-netlib/TESTING/LIN/ctrt06.f +++ b/lapack-netlib/TESTING/LIN/ctrt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, * RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, N @@ -20,7 +20,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_lin * @@ -122,10 +122,10 @@ SUBROUTINE CTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, $ RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ctsqr01.f b/lapack-netlib/TESTING/LIN/ctsqr01.f new file mode 100644 index 0000000000..a3bd9ebc98 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ctsqr01.f @@ -0,0 +1,462 @@ +*> \brief \b CTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \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] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +* ===================================================================== + SUBROUTINE CTSQR01(TSSW, M, N, MB, NB, RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + REAL ZERO + COMPLEX ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, TSIZE, MNB + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) + COMPLEX TQUERY( 5 ), WORKQUERY +* .. +* .. External Functions .. + REAL SLAMCH, CLANGE, CLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB +* +* 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), LQ(L,N) ) +* +* 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 ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + CALL CGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL CGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'CGEQR' + CALL CGEQR( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M ) + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'N', M, M, K, AF, M, T, TSIZE, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M ) + CALL CLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, 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 +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', M, M, CZERO, ONE, R, M ) + CALL CHERK( 'U', 'C', M, M, REAL(-ONE), Q, M, REAL(ONE), R, M ) + RESID = CLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL CGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, 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 QT*C +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'L', 'C', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, 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 +* + srnamt = 'CGEMQR' + CALL CGEMQR( 'R', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL CGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, 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 +* + CALL CGEMQR( 'R', 'C', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL CGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + CALL CGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, + $ WORKQUERY, -1, INFO ) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'CGELQ' + CALL CGELQ( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N ) + srnamt = 'CGEMLQ' + CALL CGEMLQ( 'R', 'N', N, N, K, AF, M, T, TSIZE, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, LQ, L ) + CALL CLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = CLANGE( '1', M, N, A, M, RWORK ) + RESID = CLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL CLASET( 'Full', N, N, CZERO, ONE, LQ, L ) + CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), LQ, L) + RESID = CLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL CGEMLQ( 'L', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL CLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL CGEMLQ( 'L', 'C', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL CGEMLQ( 'R', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL CLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL CGEMLQ( 'R', 'C', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = CLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/dchkaa.f b/lapack-netlib/TESTING/LIN/dchkaa.f index 9e5c5b15d3..4be10b3660 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.f +++ b/lapack-netlib/TESTING/LIN/dchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DCHKAA -* +* * *> \par Purpose: * ============= @@ -51,6 +51,8 @@ *> DPT 12 List types on next line if 0 < NTYPES < 12 *> DSY 10 List types on next line if 0 < NTYPES < 10 *> DSR 10 List types on next line if 0 < NTYPES < 10 +*> DSK 10 List types on next line if 0 < NTYPES < 10 +*> DSA 10 List types on next line if 0 < NTYPES < 10 *> DSP 10 List types on next line if 0 < NTYPES < 10 *> DTR 18 List types on next line if 0 < NTYPES < 18 *> DTP 18 List types on next line if 0 < NTYPES < 18 @@ -94,10 +96,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -106,7 +108,7 @@ * ===================================================================== PROGRAM DCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * April 2012 @@ -146,8 +148,8 @@ PROGRAM DCHKAA $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ), - $ WORK( NMAX, NMAX+MAXRHS+30 ) + $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ), + $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -158,10 +160,13 @@ PROGRAM DCHKAA EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3, $ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, - $ DCHKSY_ROOK, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, - $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, - $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, - $ ILAVER, DCHKQRT, DCHKQRTP + $ 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 + * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -640,8 +645,8 @@ PROGRAM DCHKAA * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * -* SR: symmetric indefinite matrices with Rook pivoting, -* with rook (bounded Bunch-Kaufman) pivoting algorithm +* SR: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -663,6 +668,61 @@ PROGRAM DCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SA: symmetric indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKSY_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL DDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * @@ -847,7 +907,7 @@ PROGRAM DCHKAA CALL DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ), $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ RWORK, RWORK( NMAX+1 ), WORK, IWORK, NOUT ) + $ RWORK, RWORK( NMAX+1 ), NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF @@ -862,13 +922,13 @@ PROGRAM DCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF -* +* ELSE IF( LSAMEN( 2, C2, 'QT' ) ) THEN * * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -879,7 +939,40 @@ PROGRAM DCHKAA * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL DCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL DCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL DCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/lapack-netlib/TESTING/LIN/dchkab.f b/lapack-netlib/TESTING/LIN/dchkab.f index 9d01bcd920..dddc25acd8 100644 --- a/lapack-netlib/TESTING/LIN/dchkab.f +++ b/lapack-netlib/TESTING/LIN/dchkab.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DCHKAB -* +* * *> \par Purpose: * ============= @@ -32,7 +32,7 @@ *> 2 Values of NRHS (number of right hand sides) *> 20.0 Threshold value of test ratio *> T Put T to test the LAPACK routines -*> T Put T to test the error exits +*> T Put T to test the error exits *> DGE 11 List types on next line if 0 < NTYPES < 11 *> DPO 9 List types on next line if 0 < NTYPES < 9 *> \endverbatim @@ -61,10 +61,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -73,7 +73,7 @@ * ===================================================================== PROGRAM DCHKAB * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -101,7 +101,7 @@ PROGRAM DCHKAB CHARACTER*3 PATH CHARACTER*10 INTSTR CHARACTER*72 ALINE - INTEGER I, IC, K, LDA, NM, NMATS, + INTEGER I, IC, K, LDA, NM, NMATS, $ NNS, NRHS, NTYPES, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THRESH @@ -307,7 +307,7 @@ PROGRAM DCHKAB ELSE WRITE( NOUT, FMT = 9989 )'DSGESV' END IF -* +* ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN * * PO: positive definite matrices @@ -323,7 +323,7 @@ PROGRAM DCHKAB IF( TSTDRV ) THEN CALL DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, $ THRESH, LDA, A( 1, 1 ), A( 1, 2 ), - $ B( 1, 1 ), B( 1, 2 ), + $ B( 1, 1 ), B( 1, 2 ), $ WORK, RWORK, SWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -351,7 +351,7 @@ PROGRAM DCHKAB $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) - 9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV', + 9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV', $ ' routines ', $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, $ / / ' The following parameter values will be used:' ) diff --git a/lapack-netlib/TESTING/LIN/dchkeq.f b/lapack-netlib/TESTING/LIN/dchkeq.f index 94577fdbe4..89e1419936 100644 --- a/lapack-netlib/TESTING/LIN/dchkeq.f +++ b/lapack-netlib/TESTING/LIN/dchkeq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKEQ( THRESH, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NOUT * DOUBLE PRECISION THRESH * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DCHKEQ( THRESH, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NOUT diff --git a/lapack-netlib/TESTING/LIN/dchkgb.f b/lapack-netlib/TESTING/LIN/dchkgb.f index 611388892e..4ae408bd3c 100644 --- a/lapack-netlib/TESTING/LIN/dchkgb.f +++ b/lapack-netlib/TESTING/LIN/dchkgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -191,10 +191,10 @@ SUBROUTINE DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkge.f b/lapack-netlib/TESTING/LIN/dchkge.f index 35a93d3dbe..075b563a52 100644 --- a/lapack-netlib/TESTING/LIN/dchkge.f +++ b/lapack-netlib/TESTING/LIN/dchkge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -171,12 +171,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -185,10 +185,10 @@ SUBROUTINE DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkgt.f b/lapack-netlib/TESTING/LIN/dchkgt.f index 24b625606b..2d7e8baf4b 100644 --- a/lapack-netlib/TESTING/LIN/dchkgt.f +++ b/lapack-netlib/TESTING/LIN/dchkgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -22,7 +22,7 @@ * DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -146,10 +146,10 @@ SUBROUTINE DCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchklq.f b/lapack-netlib/TESTING/LIN/dchklq.f index c8cfc8fc64..b63d0361fa 100644 --- a/lapack-netlib/TESTING/LIN/dchklq.f +++ b/lapack-netlib/TESTING/LIN/dchklq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -196,10 +196,10 @@ SUBROUTINE DCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchklqt.f b/lapack-netlib/TESTING/LIN/dchklqt.f new file mode 100644 index 0000000000..66eef0fd7e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b DCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKLQT( 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 +*> +*> DCHKLQT tests DGELQT and DGEMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKLQT( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQT, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRLQT( 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 ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DGELQT and DGEMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL DLQT04( M, N, NB, 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, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/dchklqtp.f b/lapack-netlib/TESTING/LIN/dchklqtp.f new file mode 100644 index 0000000000..42ebc963a1 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b DCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKLQTP( 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 +*> +*> DCHKLQTP tests DTPLQT and DTPMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKLQTP( 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*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL DLQT05( M, N, L, NB, 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, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKQRTP +* + END diff --git a/lapack-netlib/TESTING/LIN/dchkpb.f b/lapack-netlib/TESTING/LIN/dchkpb.f index 8286f3ea5c..a8557e5dee 100644 --- a/lapack-netlib/TESTING/LIN/dchkpb.f +++ b/lapack-netlib/TESTING/LIN/dchkpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -172,10 +172,10 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkpo.f b/lapack-netlib/TESTING/LIN/dchkpo.f index f7bbcfb05a..3ce48f3222 100644 --- a/lapack-netlib/TESTING/LIN/dchkpo.f +++ b/lapack-netlib/TESTING/LIN/dchkpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -172,10 +172,10 @@ SUBROUTINE DCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkpp.f b/lapack-netlib/TESTING/LIN/dchkpp.f index 3362f1b85c..b19b766ffd 100644 --- a/lapack-netlib/TESTING/LIN/dchkpp.f +++ b/lapack-netlib/TESTING/LIN/dchkpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -163,10 +163,10 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkps.f b/lapack-netlib/TESTING/LIN/dchkps.f index c07320f746..e1463bc970 100644 --- a/lapack-netlib/TESTING/LIN/dchkps.f +++ b/lapack-netlib/TESTING/LIN/dchkps.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, * THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION THRESH * INTEGER NMAX, NN, NNB, NOUT, NRANK @@ -23,7 +23,7 @@ * INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -154,10 +154,10 @@ SUBROUTINE DCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION THRESH diff --git a/lapack-netlib/TESTING/LIN/dchkpt.f b/lapack-netlib/TESTING/LIN/dchkpt.f index df50a62ada..6cde318166 100644 --- a/lapack-netlib/TESTING/LIN/dchkpt.f +++ b/lapack-netlib/TESTING/LIN/dchkpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, D, E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -22,7 +22,7 @@ * DOUBLE PRECISION A( * ), B( * ), D( * ), E( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -146,10 +146,10 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, D, E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkq3.f b/lapack-netlib/TESTING/LIN/dchkq3.f index 2170e2b21f..c275ee039e 100644 --- a/lapack-netlib/TESTING/LIN/dchkq3.f +++ b/lapack-netlib/TESTING/LIN/dchkq3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * THRESH, A, COPYA, S, TAU, WORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NN, NNB, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), COPYA( * ), S( * ), * $ TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -153,10 +153,10 @@ SUBROUTINE DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ THRESH, A, COPYA, S, TAU, WORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NN, NNB, NOUT diff --git a/lapack-netlib/TESTING/LIN/dchkql.f b/lapack-netlib/TESTING/LIN/dchkql.f index c35ca5c529..878d874d2a 100644 --- a/lapack-netlib/TESTING/LIN/dchkql.f +++ b/lapack-netlib/TESTING/LIN/dchkql.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -196,10 +196,10 @@ SUBROUTINE DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchkqr.f b/lapack-netlib/TESTING/LIN/dchkqr.f index b4a1642e2c..4ba27a93db 100644 --- a/lapack-netlib/TESTING/LIN/dchkqr.f +++ b/lapack-netlib/TESTING/LIN/dchkqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -201,10 +201,10 @@ SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -248,7 +248,7 @@ SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02, - $ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, + $ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, $ DQRT01P, DQRT02, DQRT03, XLAENV * .. * .. Intrinsic Functions .. diff --git a/lapack-netlib/TESTING/LIN/dchkqrt.f b/lapack-netlib/TESTING/LIN/dchkqrt.f index a4825a2fcf..c74e789645 100644 --- a/lapack-netlib/TESTING/LIN/dchkqrt.f +++ b/lapack-netlib/TESTING/LIN/dchkqrt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== - SUBROUTINE DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -175,7 +175,7 @@ SUBROUTINE DCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, NB = NBVAL( K ) * * Test DGEQRT and DGEMQRT -* +* IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN CALL DQRT04( M, N, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/dchkqrtp.f b/lapack-netlib/TESTING/LIN/dchkqrtp.f index fdb31f2482..716dbcd84b 100644 --- a/lapack-netlib/TESTING/LIN/dchkqrtp.f +++ b/lapack-netlib/TESTING/LIN/dchkqrtp.f @@ -2,13 +2,13 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) * * .. Scalar Arguments .. @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== - SUBROUTINE DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -172,14 +172,14 @@ SUBROUTINE DCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * MINMN = MIN( M, N ) DO L = 0, MINMN, MAX( MINMN, 1 ) -* +* * Do for each possible value of NB * DO K = 1, NNB NB = NBVAL( K ) * * Test DTPQRT and DTPMQRT -* +* IF( (NB.LE.N).AND.(NB.GT.0) ) THEN CALL DQRT05( M, N, L, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/dchkrfp.f b/lapack-netlib/TESTING/LIN/dchkrfp.f index 718a246f89..d6c50fba30 100644 --- a/lapack-netlib/TESTING/LIN/dchkrfp.f +++ b/lapack-netlib/TESTING/LIN/dchkrfp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM DCHKRFP -* +* * *> \par Purpose: * ============= @@ -47,10 +47,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -59,7 +59,7 @@ * ===================================================================== PROGRAM DCHKRFP * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -252,7 +252,7 @@ PROGRAM DCHKRFP CALL DDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + D_WORK_DLANSY ) * -* Test the convertion routines: +* Test the conversion routines: * dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. * CALL DDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, diff --git a/lapack-netlib/TESTING/LIN/dchkrq.f b/lapack-netlib/TESTING/LIN/dchkrq.f index da553d603e..d820a91dd9 100644 --- a/lapack-netlib/TESTING/LIN/dchkrq.f +++ b/lapack-netlib/TESTING/LIN/dchkrq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -201,10 +201,10 @@ SUBROUTINE DCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchksp.f b/lapack-netlib/TESTING/LIN/dchksp.f index 96b5442f3a..6334a05104 100644 --- a/lapack-netlib/TESTING/LIN/dchksp.f +++ b/lapack-netlib/TESTING/LIN/dchksp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -163,10 +163,10 @@ SUBROUTINE DCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchksy_aa.f b/lapack-netlib/TESTING/LIN/dchksy_aa.f new file mode 100644 index 0000000000..53d7db6e84 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchksy_aa.f @@ -0,0 +1,569 @@ +*> \brief \b DCHKSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKSY_AA tests DSYTRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANSY + EXTERNAL DGET06, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, + $ DSYCON, DSYRFS, DSYT01_AA, DSYTRF_AA, + $ DSYTRI2, DSYTRS_AA, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + SRNAMT = 'DSYTRF_AA' + LWORK = MAX( 1, N*NB + N ) + CALL DSYTRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from DSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYTRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL DSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL DSYTRS_AA( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from DSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DSYTRS_AA', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of DCHKSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/dchksy_rk.f b/lapack-netlib/TESTING/LIN/dchksy_rk.f new file mode 100644 index 0000000000..2b5d7adecf --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchksy_rk.f @@ -0,0 +1,846 @@ +*> \brief \b DCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DCHKSY_RK tests DSYTRF_RK, -TRI_3, -TRS_3, and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION BLOCK( 2, 2 ), DDUMMY( 1 ), RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANGE, DLANSY + EXTERNAL DGET06, DLANGE, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGESVD, DGET04, + $ DLACPY, DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, + $ DSYCON_3, DSYT01_3, DSYTRF_RK, DSYTRI_3, + $ DSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DSYTRF_RK' + CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'DSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'DSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that DPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from DSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = DLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = DLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = DLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = DLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ DDUMMY, 1, DDUMMY, 1, + $ WORK, 10, INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ DDUMMY, 1, DDUMMY, 1, + $ WORK, 10, INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS_3' + CALL DSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from DSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'DSYCON_3' + CALL DSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from DSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare to values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of DCHKSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/dchksy_rook.f b/lapack-netlib/TESTING/LIN/dchksy_rook.f index 822bdcc5d9..0c001669cd 100644 --- a/lapack-netlib/TESTING/LIN/dchksy_rook.f +++ b/lapack-netlib/TESTING/LIN/dchksy_rook.f @@ -162,7 +162,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -171,10 +171,10 @@ SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -205,15 +205,14 @@ SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, - $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, - $ NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, $ SING_MIN, RCOND, RCONDC * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) - INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION BLOCK( 2, 2 ), DDUMMY( 1 ), RESULT( NTESTS ) * .. * .. External Functions .. diff --git a/lapack-netlib/TESTING/LIN/dchktb.f b/lapack-netlib/TESTING/LIN/dchktb.f index a90d588c91..af50bf3229 100644 --- a/lapack-netlib/TESTING/LIN/dchktb.f +++ b/lapack-netlib/TESTING/LIN/dchktb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION AB( * ), AINV( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -155,10 +155,10 @@ SUBROUTINE DCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchktp.f b/lapack-netlib/TESTING/LIN/dchktp.f index e3a7db84e9..58f78697fb 100644 --- a/lapack-netlib/TESTING/LIN/dchktp.f +++ b/lapack-netlib/TESTING/LIN/dchktp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION AINVP( * ), AP( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -157,10 +157,10 @@ SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchktr.f b/lapack-netlib/TESTING/LIN/dchktr.f index cc2554c012..5c0cd83b92 100644 --- a/lapack-netlib/TESTING/LIN/dchktr.f +++ b/lapack-netlib/TESTING/LIN/dchktr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, * WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AINV( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -167,10 +167,10 @@ SUBROUTINE DCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, $ WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/dchktsqr.f b/lapack-netlib/TESTING/LIN/dchktsqr.f new file mode 100644 index 0000000000..c4b1f01bd2 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b DCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKTSQR( 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 +*> +*> DCHKTSQR tests DGETSQR and DORMTSQR. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKTSQR( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR, + $ DTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL DERRTSQR( 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL DTSQR01( 'TS', M, N, MB, NB, 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, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test DGEQR and DGEMQR +* + CALL DTSQR01( 'SW', M, N, MB, NB, 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 = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of DCHKQRT +* + END diff --git a/lapack-netlib/TESTING/LIN/dchktz.f b/lapack-netlib/TESTING/LIN/dchktz.f index a674636219..8a60d05412 100644 --- a/lapack-netlib/TESTING/LIN/dchktz.f +++ b/lapack-netlib/TESTING/LIN/dchktz.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, * COPYA, S, TAU, WORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NOUT @@ -22,7 +22,7 @@ * DOUBLE PRECISION A( * ), COPYA( * ), S( * ), * $ TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -132,10 +132,10 @@ SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, TAU, WORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvab.f b/lapack-netlib/TESTING/LIN/ddrvab.f index 437255f95d..646bbff0d2 100644 --- a/lapack-netlib/TESTING/LIN/ddrvab.f +++ b/lapack-netlib/TESTING/LIN/ddrvab.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, * NSVAL, THRESH, NMAX, A, AFAC, B, * X, WORK, RWORK, SWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NMAX, NNS, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -151,10 +151,10 @@ SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, $ NSVAL, THRESH, NMAX, A, AFAC, B, $ X, WORK, RWORK, SWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NMAX, NNS, NOUT @@ -211,7 +211,7 @@ SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA ISEEDY / 2006, 2007, 2008, 2009 / + DATA ISEEDY / 2006, 2007, 2008, 2009 / * .. * .. Executable Statements .. * @@ -319,7 +319,7 @@ SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, CALL DLACPY( 'Full', M, N, AFAC, LDA, A, LDA ) ENDIF * -* Check error code from DSGESV. This should be the same as +* Check error code from DSGESV. This should be the same as * the one of DGETRF. * IF( INFO.NE.IZERO ) THEN @@ -353,7 +353,7 @@ SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, * Print information about the tests that did not * pass the testing. * -* If iterative refinement has been used and claimed to +* If iterative refinement has been used and claimed to * be successful (ITER>0), we want * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1 * @@ -423,7 +423,7 @@ SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, $ 14X, '11. Scaled near overflow', / 4X, $ '6. Last column zero' ) 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', - $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', + $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', $ / 4x, 'or norm_1( B - A * X ) / ', $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' ) RETURN diff --git a/lapack-netlib/TESTING/LIN/ddrvac.f b/lapack-netlib/TESTING/LIN/ddrvac.f index 2b056bd03a..ee710dbf24 100644 --- a/lapack-netlib/TESTING/LIN/ddrvac.f +++ b/lapack-netlib/TESTING/LIN/ddrvac.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * A, AFAC, B, X, WORK, * RWORK, SWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NMAX, NM, NNS, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -130,12 +130,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -144,10 +144,10 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, $ A, AFAC, B, X, WORK, $ RWORK, SWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NMAX, NM, NNS, NOUT @@ -176,7 +176,7 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, - $ IZERO, KL, KU, LDA, MODE, N, + $ IZERO, KL, KU, LDA, MODE, N, $ NERRS, NFAIL, NIMAT, NRHS, NRUN DOUBLE PRECISION ANORM, CNDNUM * .. @@ -194,7 +194,7 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * .. * .. External Subroutines .. EXTERNAL ALAERH, DLACPY, - $ DLARHS, DLASET, DLATB4, DLATMS, + $ DLARHS, DLASET, DLATB4, DLATMS, $ DPOT06, DSPOSV * .. * .. Intrinsic Functions .. @@ -331,7 +331,7 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, SRNAMT = 'DSPOSV ' KASE = KASE + 1 * - CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA) + CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA) * CALL DSPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, $ WORK, SWORK, ITER, INFO ) @@ -372,7 +372,7 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * Print information about the tests that did not * pass the testing. * -* If iterative refinement has been used and claimed to +* If iterative refinement has been used and claimed to * be successful (ITER>0), we want * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 * @@ -450,7 +450,7 @@ SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', $ / 4x, 'or norm_1( B - A * X ) / ', $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DPOTRF' ) - + RETURN * * End of DDRVAC diff --git a/lapack-netlib/TESTING/LIN/ddrvgb.f b/lapack-netlib/TESTING/LIN/ddrvgb.f index d97857dd47..7758a5978e 100644 --- a/lapack-netlib/TESTING/LIN/ddrvgb.f +++ b/lapack-netlib/TESTING/LIN/ddrvgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ RWORK( * ), S( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -172,10 +172,10 @@ SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvgbx.f b/lapack-netlib/TESTING/LIN/ddrvgbx.f index ad0b1f6f05..4c76b44af4 100644 --- a/lapack-netlib/TESTING/LIN/ddrvgbx.f +++ b/lapack-netlib/TESTING/LIN/ddrvgbx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ RWORK( * ), S( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -175,10 +175,10 @@ SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvge.f b/lapack-netlib/TESTING/LIN/ddrvge.f index efb592acf3..a4209138df 100644 --- a/lapack-netlib/TESTING/LIN/ddrvge.f +++ b/lapack-netlib/TESTING/LIN/ddrvge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -164,10 +164,10 @@ SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvgex.f b/lapack-netlib/TESTING/LIN/ddrvgex.f index 98099ed873..228e886e94 100644 --- a/lapack-netlib/TESTING/LIN/ddrvgex.f +++ b/lapack-netlib/TESTING/LIN/ddrvgex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,10 +153,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -167,7 +167,7 @@ SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/ddrvgt.f b/lapack-netlib/TESTING/LIN/ddrvgt.f index 81d7dcf78a..6da10336b1 100644 --- a/lapack-netlib/TESTING/LIN/ddrvgt.f +++ b/lapack-netlib/TESTING/LIN/ddrvgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, * B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -22,7 +22,7 @@ * DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -139,10 +139,10 @@ SUBROUTINE DDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, $ B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvls.f b/lapack-netlib/TESTING/LIN/ddrvls.f index 8f35caba42..5d190e1189 100644 --- a/lapack-netlib/TESTING/LIN/ddrvls.f +++ b/lapack-netlib/TESTING/LIN/ddrvls.f @@ -2,16 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, -* COPYB, C, S, COPYS, WORK, IWORK, NOUT ) -* +* COPYB, C, S, COPYS, NOUT ) +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -19,19 +19,19 @@ * .. * .. Array Arguments .. * LOGICAL DOTYPE( * ) -* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), * $ NVAL( * ), NXVAL( * ) * DOUBLE PRECISION A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), -* $ COPYS( * ), S( * ), WORK( * ) +* $ COPYS( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSY, +*> DDRVLS tests the least squares driver routines DGELS, DGETSLS, DGELSS, DGELSY, *> and DGELSD. *> \endverbatim * @@ -46,14 +46,14 @@ *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. *> The matrix of type j is generated as follows: *> j=1: A = U*D*V where U and V are random orthogonal matrices -*> and D has random entries (> 0.1) taken from a uniform +*> and D has random entries (> 0.1) taken from a uniform *> distribution (0,1). A is full rank. *> j=2: The same of 1, but A is scaled up. *> j=3: The same of 1, but A is scaled down. *> j=4: A = U*D*V where U and V are random orthogonal matrices *> and D has 3*min(M,N)/4 random entries (> 0.1) taken *> from a uniform distribution (0,1) and the remaining -*> entries set to 0. A is rank-deficient. +*> entries set to 0. A is rank-deficient. *> j=5: The same of 4, but A is scaled up. *> j=6: The same of 5, but A is scaled down. *> \endverbatim @@ -169,17 +169,6 @@ *> (min(MMAX,NMAX)) *> \endverbatim *> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension (MMAX*NMAX + 4*NMAX + MMAX). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (15*NMAX) -*> \endverbatim -*> *> \param[in] NOUT *> \verbatim *> NOUT is INTEGER @@ -189,24 +178,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, - $ COPYB, C, S, COPYS, WORK, IWORK, NOUT ) + $ COPYB, C, S, COPYS, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -215,17 +204,17 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) - INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), + INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), $ NVAL( * ), NXVAL( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), - $ COPYS( * ), S( * ), WORK( * ) + $ COPYS( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, TWO, ZERO @@ -234,15 +223,22 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, - $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, - $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK + INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK, + $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, + $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, + $ MMAX, NMAX, NSMAX, LIWORK, + $ LWORK_DGELS, LWORK_DGETSLS, LWORK_DGELSS, + $ LWORK_DGELSY, LWORK_DGELSD DOUBLE PRECISION EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. - INTEGER ISEED( 4 ), ISEEDY( 4 ) - DOUBLE PRECISION RESULT( NTESTS ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY + DOUBLE PRECISION RESULT( NTESTS ), WORKQUERY +* .. +* .. Allocatable Arrays .. + DOUBLE PRECISION, ALLOCATABLE :: WORK (:) + INTEGER, ALLOCATABLE :: IWORK (:) * .. * .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH, DQRT12, DQRT14, DQRT17 @@ -301,6 +297,71 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, INFOT = 0 CALL XLAENV( 2, 2 ) CALL XLAENV( 9, SMLSIZ ) +* +* Compute maximal workspace needed for all routines +* + NMAX = 0 + MMAX = 0 + NSMAX = 0 + DO I = 1, NM + IF ( MVAL( I ).GT.MMAX ) THEN + MMAX = MVAL( I ) + END IF + ENDDO + DO I = 1, NN + IF ( NVAL( I ).GT.NMAX ) THEN + NMAX = NVAL( I ) + END IF + ENDDO + DO I = 1, NNS + IF ( NSVAL( I ).GT.NSMAX ) THEN + NSMAX = NSVAL( I ) + END IF + ENDDO + M = MMAX + N = NMAX + NRHS = NSMAX + LDA = MAX( 1, M ) + LDB = MAX( 1, M, N ) + MNMIN = MAX( MIN( M, N ), 1 ) +* +* Compute workspace needed for routines +* DQRT14, DQRT17 (two side cases), DQRT15 and DQRT12 +* + LWORK = MAX( ( M+N )*NRHS, + $ ( N+NRHS )*( M+2 ), ( M+NRHS )*( N+2 ), + $ MAX( M+MNMIN, NRHS*MNMIN,2*N+M ), + $ MAX( M*N+4*MNMIN+MAX(M,N), M*N+2*MNMIN+4*N ) ) +* +* Compute workspace needed for DGELS + CALL DGELS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_DGELS = INT ( WORKQUERY ) +* Compute workspace needed for DGETSLS + CALL DGETSLS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_DGETSLS = INT( WORKQUERY ) +* Compute workspace needed for DGELSY + CALL DGELSY( M, N, NRHS, A, LDA, B, LDB, IWORKQUERY, + $ RCOND, CRANK, WORKQUERY, -1, INFO ) + LWORK_DGELSY = INT( WORKQUERY ) +* Compute workspace needed for DGELSS + CALL DGELSS( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1 , INFO ) + LWORK_DGELSS = INT( WORKQUERY ) +* Compute workspace needed for DGELSD + CALL DGELSD( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1, IWORKQUERY, INFO ) + LWORK_DGELSD = INT( WORKQUERY ) +* Compute LIWORK workspace needed for DGELSY and DGELSD + LIWORK = MAX( 1, N, IWORKQUERY ) +* Compute LWORK workspace needed for all functions + LWORK = MAX( 1, LWORK, LWORK_DGELS, LWORK_DGETSLS, LWORK_DGELSY, + $ LWORK_DGELSS, LWORK_DGELSD ) + LWLSY = LWORK +* + ALLOCATE( WORK( LWORK ) ) + ALLOCATE( IWORK( LIWORK ) ) * DO 150 IM = 1, NM M = MVAL( IM ) @@ -308,16 +369,12 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * DO 140 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) * DO 130 INS = 1, NNS NRHS = NSVAL( INS ) - NLVL = MAX( INT( LOG( MAX( ONE, DBLE( MNMIN ) ) / - $ DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 ) - LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+ - $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 ) * DO 120 IRANK = 1, 2 DO 110 ISCALE = 1, 3 @@ -426,6 +483,110 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test DGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL DQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'T' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL DLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL DSCAL( NCOLS*NRHS, + $ ONE / DBLE( NCOLS ), WORK, + $ 1 ) + END IF + CALL DGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, ONE, COPYA, LDA, + $ WORK, LDWORK, ZERO, B, LDB ) + CALL DLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL DLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL DLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'DGETSLS ' + CALL DGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL DLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL DQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = DQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = DQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -458,11 +619,6 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, DO 70 J = 1, N IWORK( J ) = 0 70 CONTINUE -* -* Set LWLSY to the adequate value. -* - LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ), - $ 2*MNMIN+NB*NRHS ) * CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B, @@ -628,7 +784,7 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * Print information about the tests that did not * pass the threshold. * - DO 90 K = 3, NTESTS + DO 90 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -637,7 +793,7 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -654,6 +810,12 @@ SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) +* + DEALLOCATE( WORK ) + DEALLOCATE( IWORK ) RETURN * * End of DDRVLS diff --git a/lapack-netlib/TESTING/LIN/ddrvpb.f b/lapack-netlib/TESTING/LIN/ddrvpb.f index b44ae38546..6b5695faf3 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpb.f +++ b/lapack-netlib/TESTING/LIN/ddrvpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -164,10 +164,10 @@ SUBROUTINE DDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvpo.f b/lapack-netlib/TESTING/LIN/ddrvpo.f index 92a71edeca..2caddcea9d 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpo.f +++ b/lapack-netlib/TESTING/LIN/ddrvpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -164,10 +164,10 @@ SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvpox.f b/lapack-netlib/TESTING/LIN/ddrvpox.f index a3ab104833..e093bbaa77 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpox.f +++ b/lapack-netlib/TESTING/LIN/ddrvpox.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup double_lin * @@ -167,10 +167,10 @@ SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvpp.f b/lapack-netlib/TESTING/LIN/ddrvpp.f index aa549c198e..dac2e2e591 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpp.f +++ b/lapack-netlib/TESTING/LIN/ddrvpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -167,10 +167,10 @@ SUBROUTINE DDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvpt.f b/lapack-netlib/TESTING/LIN/ddrvpt.f index 5cf5aa6cc9..eec5c74907 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpt.f +++ b/lapack-netlib/TESTING/LIN/ddrvpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, * E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -22,7 +22,7 @@ * DOUBLE PRECISION A( * ), B( * ), D( * ), E( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -140,10 +140,10 @@ SUBROUTINE DDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, $ E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvrf1.f b/lapack-netlib/TESTING/LIN/ddrvrf1.f index d5a20e9a6c..dfb1941a65 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrf1.f +++ b/lapack-netlib/TESTING/LIN/ddrvrf1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * DOUBLE PRECISION THRESH @@ -18,7 +18,7 @@ * INTEGER NVAL( NN ) * DOUBLE PRECISION A( LDA, * ), ARF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -82,22 +82,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -161,7 +161,7 @@ SUBROUTINE DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) EPS = DLAMCH( 'Precision' ) SMALL = DLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL - SMALL = SMALL * LDA * LDA + SMALL = SMALL * LDA * LDA LARGE = LARGE / LDA / LDA * DO 130 IIN = 1, NN @@ -241,7 +241,7 @@ SUBROUTINE DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'DLANSF', + WRITE( NOUT, FMT = 9997 ) 'DLANSF', + N, IIT, UPLO, CFORM, NORM, RESULT(1) NFAIL = NFAIL + 1 END IF diff --git a/lapack-netlib/TESTING/LIN/ddrvrf2.f b/lapack-netlib/TESTING/LIN/ddrvrf2.f index 4509b3cacd..3d38ca0426 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrf2.f +++ b/lapack-netlib/TESTING/LIN/ddrvrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * .. @@ -17,14 +17,14 @@ * INTEGER NVAL( NN ) * DOUBLE PRECISION A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> DDRVRF2 tests the LAPACK RFP convertion routines. +*> DDRVRF2 tests the LAPACK RFP conversion routines. *> \endverbatim * * Arguments: @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -248,14 +248,14 @@ SUBROUTINE DDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) WRITE( NOUT, FMT = 9996 ) NERRS, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP conversion', + ' routines ***') - 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + 9998 FORMAT( 1X, ' Error in RFP,conversion routines N=',I5, + ' UPLO=''', A1, ''', FORM =''',A1,'''') - 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed ( ', + 9997 FORMAT( 1X, 'All tests for the RFP conversion routines passed ( ', + I5,' tests run)') - 9996 FORMAT( 1X, 'RFP convertion routines: ',I5,' out of ',I5, - + ' error message recorded') + 9996 FORMAT( 1X, 'RFP conversion routines: ',I5,' out of ',I5, + + ' error message recorded') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/ddrvrf3.f b/lapack-netlib/TESTING/LIN/ddrvrf3.f index 26e59d1fe0..c00aac1a79 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrf3.f +++ b/lapack-netlib/TESTING/LIN/ddrvrf3.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * + D_WORK_DLANGE, D_WORK_DGEQRF, TAU ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * DOUBLE PRECISION THRESH @@ -21,7 +21,7 @@ * + B2( LDA, * ), D_WORK_DGEQRF( * ), * + D_WORK_DLANGE( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -118,10 +118,10 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + D_WORK_DLANGE, D_WORK_DGEQRF, TAU ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -253,12 +253,12 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, END IF * * Generate A our NA--by--NA triangular -* matrix. +* matrix. * Our test is based on forward error so we * do want A to be well conditionned! To get * a well-conditionned triangular matrix, we * take the R factor of the QR/LQ factorization -* of a random matrix. +* of a random matrix. * DO J = 1, NA DO I = 1, NA @@ -336,7 +336,7 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'DTFSM', + WRITE( NOUT, FMT = 9997 ) 'DTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, + N, RESULT(1) NFAIL = NFAIL + 1 @@ -359,7 +359,7 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, FMT = 9995 ) 'DTFSM', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DTFSM + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DTFSM + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', diff --git a/lapack-netlib/TESTING/LIN/ddrvrf4.f b/lapack-netlib/TESTING/LIN/ddrvrf4.f index 62a20d483e..02b0bbaf72 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrf4.f +++ b/lapack-netlib/TESTING/LIN/ddrvrf4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * + LDA, D_WORK_DLANGE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDC, NN, NOUT * DOUBLE PRECISION THRESH @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), C1( LDC, * ), C2( LDC, *), * + CRF( * ), D_WORK_DLANGE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -118,10 +118,10 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + LDA, D_WORK_DLANGE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDC, NN, NOUT @@ -242,12 +242,12 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, NORMA = DLANGE( 'I', N, K, A, LDA, + D_WORK_DLANGE ) * - + ELSE * * In this case we are TRANS, so A is K-by-N * - DO J = 1,N + DO J = 1,N DO I = 1, K A( I, J) = DLARND( 2, ISEED ) END DO @@ -258,7 +258,7 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * END IF * -* Generate C1 our N--by--N symmetric matrix. +* Generate C1 our N--by--N symmetric matrix. * Make sure C2 has the same upper/lower part, * (the one that we do not touch), so * copy the initial C1 in C2 in it. @@ -313,7 +313,7 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * RESULT(1) = DLANGE( 'I', N, N, C1, LDC, + D_WORK_DLANGE ) - RESULT(1) = RESULT(1) + RESULT(1) = RESULT(1) + / MAX( ABS( ALPHA ) * NORMA + + ABS( BETA ) , ONE ) + / MAX( N , 1 ) / EPS @@ -323,7 +323,7 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'DSFRK', + WRITE( NOUT, FMT = 9997 ) 'DSFRK', + CFORM, UPLO, TRANS, N, K, RESULT(1) NFAIL = NFAIL + 1 END IF @@ -343,7 +343,7 @@ SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, FMT = 9995 ) 'DSFRK', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DSFRK + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DSFRK + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, diff --git a/lapack-netlib/TESTING/LIN/ddrvrfp.f b/lapack-netlib/TESTING/LIN/ddrvrfp.f index 5f44006b90..d67cf67131 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrfp.f +++ b/lapack-netlib/TESTING/LIN/ddrvrfp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -14,7 +14,7 @@ * + D_WORK_DLATMS, D_WORK_DPOT01, D_TEMP_DPOT02, * + D_TEMP_DPOT03, D_WORK_DLANSY, * + D_WORK_DPOT02, D_WORK_DPOT03 ) -* +* * .. Scalar Arguments .. * INTEGER NN, NNS, NNT, NOUT * DOUBLE PRECISION THRESH @@ -39,7 +39,7 @@ * DOUBLE PRECISION D_WORK_DPOT02( * ) * DOUBLE PRECISION D_WORK_DPOT03( * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,11 +52,11 @@ *> This testing routine follow the same tests as DDRVPO (test for the full *> format Symmetric Positive Definite solver). *> -*> The tests are performed in Full Format, convertion back and forth from +*> The tests are performed in Full Format, conversion back and forth from *> full format to RFP format are performed using the routines DTRTTF and *> DTFTTR. *> -*> First, a specific matrix A of size N is created. There is nine types of +*> First, a specific matrix A of size N is created. There is nine types of *> different matrixes possible. *> 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) *> 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS @@ -226,12 +226,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup double_lin * @@ -243,10 +243,10 @@ SUBROUTINE DDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + D_TEMP_DPOT03, D_WORK_DLANSY, + D_WORK_DPOT02, D_WORK_DPOT03 ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -515,7 +515,7 @@ SUBROUTINE DDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, * * Form the inverse and compute the residual. * - IF(MOD(N,2).EQ.0)THEN + IF(MOD(N,2).EQ.0)THEN CALL DLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + N+1 ) ELSE @@ -550,7 +550,7 @@ SUBROUTINE DDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + RESULT( 3 ) ) * * Check solution from generated exact solution. - + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + RESULT( 4 ) ) NT = 4 diff --git a/lapack-netlib/TESTING/LIN/ddrvsp.f b/lapack-netlib/TESTING/LIN/ddrvsp.f index a96c6ab8b6..a7c2316141 100644 --- a/lapack-netlib/TESTING/LIN/ddrvsp.f +++ b/lapack-netlib/TESTING/LIN/ddrvsp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -156,10 +156,10 @@ SUBROUTINE DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvsy_aa.f b/lapack-netlib/TESTING/LIN/ddrvsy_aa.f new file mode 100644 index 0000000000..af39303e1d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ddrvsy_aa.f @@ -0,0 +1,476 @@ +*> \brief \b DDRVSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVSY_AA tests the driver routine DSYSV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANSY + EXTERNAL DGET06, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05, + $ DSYSV_AA, DSYT01_AA, DSYTRF_AA, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with DLATB4 and generate a test matrix +* with DLATMS. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DSYSV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using DSYSV_AA. +* + SRNAMT = 'DSYSV_AA' + CALL DSYSV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from DSYSV_AA . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYSV_AA ', INFO, K, + $ UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'DSYSV_AA ', + $ UPLO, N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of DDRVSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/ddrvsy_rk.f b/lapack-netlib/TESTING/LIN/ddrvsy_rk.f new file mode 100644 index 0000000000..92811ce938 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ddrvsy_rk.f @@ -0,0 +1,531 @@ +*> \brief \b DDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DDRVSY_RK tests the driver routines DSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT02, DSYSV_RK, + $ DSYT01_3, DSYTRF_RK, DSYTRI_3, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* DSYSV_RK. +* + SRNAMT = 'DSYSV_RK' + CALL DSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'DSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of DDRVSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/ddrvsyx.f b/lapack-netlib/TESTING/LIN/ddrvsyx.f index b09699bf73..ab2b541d7d 100644 --- a/lapack-netlib/TESTING/LIN/ddrvsyx.f +++ b/lapack-netlib/TESTING/LIN/ddrvsyx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -156,10 +156,10 @@ SUBROUTINE DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/debchvxx.f b/lapack-netlib/TESTING/LIN/debchvxx.f index 6e954b8d52..aef2b5ccfc 100644 --- a/lapack-netlib/TESTING/LIN/debchvxx.f +++ b/lapack-netlib/TESTING/LIN/debchvxx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * diff --git a/lapack-netlib/TESTING/LIN/derrab.f b/lapack-netlib/TESTING/LIN/derrab.f index 605cd52667..dd2662635a 100644 --- a/lapack-netlib/TESTING/LIN/derrab.f +++ b/lapack-netlib/TESTING/LIN/derrab.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRAB( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -35,22 +35,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRAB( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/derrac.f b/lapack-netlib/TESTING/LIN/derrac.f index 75ef2049ae..4ab5e899b5 100644 --- a/lapack-netlib/TESTING/LIN/derrac.f +++ b/lapack-netlib/TESTING/LIN/derrac.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRAC( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -35,22 +35,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRAC( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/derrge.f b/lapack-netlib/TESTING/LIN/derrge.f index d9ddf13fcb..027801ddde 100644 --- a/lapack-netlib/TESTING/LIN/derrge.f +++ b/lapack-netlib/TESTING/LIN/derrge.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrgex.f b/lapack-netlib/TESTING/LIN/derrgex.f index 8a286ef9be..20f05fa4a9 100644 --- a/lapack-netlib/TESTING/LIN/derrgex.f +++ b/lapack-netlib/TESTING/LIN/derrgex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrgt.f b/lapack-netlib/TESTING/LIN/derrgt.f index 5b12f9e85c..75b466a486 100644 --- a/lapack-netlib/TESTING/LIN/derrgt.f +++ b/lapack-netlib/TESTING/LIN/derrgt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRGT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRGT( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrlq.f b/lapack-netlib/TESTING/LIN/derrlq.f index 9a5d41abf9..ba297f5cf1 100644 --- a/lapack-netlib/TESTING/LIN/derrlq.f +++ b/lapack-netlib/TESTING/LIN/derrlq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRLQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRLQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrlqt.f b/lapack-netlib/TESTING/LIN/derrlqt.f new file mode 100644 index 0000000000..68ff8c545d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/derrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b DERLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQT tests the error exits for the DOUBLE PRECISION routines +*> that use the LQT decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRLQT( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGELQT3, DGELQT, + $ DGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* DGELQT +* + SRNAMT = 'DGELQT' + INFOT = 1 + CALL DGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'DGELQT', INFOT, NOUT, LERR, OK ) +* +* DGELQT3 +* + SRNAMT = 'DGELQT3' + INFOT = 1 + CALL DGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'DGELQT3', INFOT, NOUT, LERR, OK ) +* +* DGEMLQT +* + SRNAMT = 'DGEMLQT' + INFOT = 1 + CALL DGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'DGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/derrlqtp.f b/lapack-netlib/TESTING/LIN/derrlqtp.f new file mode 100644 index 0000000000..16129540aa --- /dev/null +++ b/lapack-netlib/TESTING/LIN/derrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b DERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQTP tests the error exits for the REAL routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRLQTP( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DTPLQT2, DTPLQT, + $ DTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* DTPLQT +* + SRNAMT = 'DTPLQT' + INFOT = 1 + CALL DTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'DTPLQT', INFOT, NOUT, LERR, OK ) +* +* DTPLQT2 +* + SRNAMT = 'DTPLQT2' + INFOT = 1 + CALL DTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'DTPLQT2', INFOT, NOUT, LERR, OK ) +* +* DTPMLQT +* + SRNAMT = 'DTPMLQT' + INFOT = 1 + CALL DTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL DTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'DTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/derrls.f b/lapack-netlib/TESTING/LIN/derrls.f index a21f75554b..1be8830ba8 100644 --- a/lapack-netlib/TESTING/LIN/derrls.f +++ b/lapack-netlib/TESTING/LIN/derrls.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRLS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRLS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrpo.f b/lapack-netlib/TESTING/LIN/derrpo.f index e600d9ead8..6d613764a1 100644 --- a/lapack-netlib/TESTING/LIN/derrpo.f +++ b/lapack-netlib/TESTING/LIN/derrpo.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrpox.f b/lapack-netlib/TESTING/LIN/derrpox.f index 7c7405a2dc..88d0c7e3a0 100644 --- a/lapack-netlib/TESTING/LIN/derrpox.f +++ b/lapack-netlib/TESTING/LIN/derrpox.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrps.f b/lapack-netlib/TESTING/LIN/derrps.f index 91e1e4b1d4..4d2bf3e83a 100644 --- a/lapack-netlib/TESTING/LIN/derrps.f +++ b/lapack-netlib/TESTING/LIN/derrps.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRPS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRPS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/derrql.f b/lapack-netlib/TESTING/LIN/derrql.f index b4177c5e33..477c3ef1cf 100644 --- a/lapack-netlib/TESTING/LIN/derrql.f +++ b/lapack-netlib/TESTING/LIN/derrql.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRQL( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRQL( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrqp.f b/lapack-netlib/TESTING/LIN/derrqp.f index f3d79cfa93..4f438feab9 100644 --- a/lapack-netlib/TESTING/LIN/derrqp.f +++ b/lapack-netlib/TESTING/LIN/derrqp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRQP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRQP( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrqr.f b/lapack-netlib/TESTING/LIN/derrqr.f index ee3472ffbf..e1fe51cad9 100644 --- a/lapack-netlib/TESTING/LIN/derrqr.f +++ b/lapack-netlib/TESTING/LIN/derrqr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRQR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRQR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrqrt.f b/lapack-netlib/TESTING/LIN/derrqrt.f index d7f30694b3..660e2ef531 100644 --- a/lapack-netlib/TESTING/LIN/derrqrt.f +++ b/lapack-netlib/TESTING/LIN/derrqrt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRQRT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -56,10 +56,10 @@ SUBROUTINE DERRQRT( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE DERRQRT( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DGEQRT2, DGEQRT3, DGEQRT, - $ DGEMQRT + $ DGEMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/LIN/derrqrtp.f b/lapack-netlib/TESTING/LIN/derrqrtp.f index 3e74e66684..83be5aa3e3 100644 --- a/lapack-netlib/TESTING/LIN/derrqrtp.f +++ b/lapack-netlib/TESTING/LIN/derrqrtp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRQRTP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -56,10 +56,10 @@ SUBROUTINE DERRQRTP( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE DERRQRTP( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DTPQRT2, DTPQRT, - $ DTPMQRT + $ DTPMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,50 +171,50 @@ SUBROUTINE DERRQRTP( PATH, NUNIT ) * SRNAMT = 'DTPMQRT' INFOT = 1 - CALL DTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL DTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) INFOT = 6 - CALL DTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL DTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL DTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL DTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL DTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL DTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + CALL DTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL DTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + CALL DTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL DTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + CALL DTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, $ W, INFO ) CALL CHKXER( 'DTPMQRT', INFOT, NOUT, LERR, OK ) * diff --git a/lapack-netlib/TESTING/LIN/derrrfp.f b/lapack-netlib/TESTING/LIN/derrrfp.f index a97b53d7e1..8db8ebf0a5 100644 --- a/lapack-netlib/TESTING/LIN/derrrfp.f +++ b/lapack-netlib/TESTING/LIN/derrrfp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRRFP( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -40,22 +40,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRRFP( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/derrrq.f b/lapack-netlib/TESTING/LIN/derrrq.f index 0eed147140..d594a74bc4 100644 --- a/lapack-netlib/TESTING/LIN/derrrq.f +++ b/lapack-netlib/TESTING/LIN/derrrq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRRQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRRQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrsy.f b/lapack-netlib/TESTING/LIN/derrsy.f index d537a62cfb..d7d00fa9ef 100644 --- a/lapack-netlib/TESTING/LIN/derrsy.f +++ b/lapack-netlib/TESTING/LIN/derrsy.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -79,7 +79,8 @@ SUBROUTINE DERRSY( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ) + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -87,9 +88,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, - $ DSPTRS, DSYCON, DSYCON_ROOK, DSYRFS, DSYTF2, - $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI, - $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK + $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS, + $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF, + $ DSYTRF_RK, DSYTRF_ROOK, DSYTRF_AA, DSYTRI, + $ DSYTRI_3, DSYTRI_3X, DSYTRI_ROOK, DSYTRI2, + $ DSYTRI2X, DSYTRS, DSYTRS_3, DSYTRS_ROOK, + $ DSYTRS_AA * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -117,6 +121,7 @@ SUBROUTINE DERRSY( PATH, NUNIT ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -146,6 +151,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 4 CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) * * DSYTF2 * @@ -186,6 +197,19 @@ SUBROUTINE DERRSY( PATH, NUNIT ) CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) * +* DSYTRI2X +* + SRNAMT = 'DSYTRI2X' + INFOT = 1 + CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) +* * DSYTRS * SRNAMT = 'DSYTRS' @@ -271,6 +295,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 4 CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * DSYTF2_ROOK * @@ -332,6 +362,168 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 6 CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* DSYTRF_RK +* + SRNAMT = 'DSYTRF_RK' + INFOT = 1 + CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_RK +* + SRNAMT = 'DSYTF2_RK' + INFOT = 1 + CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3 +* + SRNAMT = 'DSYTRI_3' + INFOT = 1 + CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3X +* + SRNAMT = 'DSYTRI_3X' + INFOT = 1 + CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_3 +* + SRNAMT = 'DSYTRS_3' + INFOT = 1 + CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* DSYCON_3 +* + SRNAMT = 'DSYCON_3' + INFOT = 1 + CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with Aasen's algorithm. +* +* DSYTRF_AA +* + SRNAMT = 'DSYTRF_AA' + INFOT = 1 + CALL DSYTRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'DSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_AA', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_AA +* + SRNAMT = 'DSYTRS_AA' + INFOT = 1 + CALL DSYTRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRS_AA( 'U', 0, 1, A, 2, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRS_AA( 'U', 0, 1, A, 2, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/derrsyx.f b/lapack-netlib/TESTING/LIN/derrsyx.f index 8bd2886eb8..0634209e5c 100644 --- a/lapack-netlib/TESTING/LIN/derrsyx.f +++ b/lapack-netlib/TESTING/LIN/derrsyx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,8 +83,8 @@ SUBROUTINE DERRSY( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ), - $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) * .. * .. External Functions .. @@ -92,11 +92,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, DSPCON, DSYCON_ROOK, DSPRFS, - $ DSPTRF, DSPTRI, DSPTRS, DSYCON, DSYRFS, DSYTF2, - $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI, - $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK, - $ DSYRFSX + EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, + $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS, + $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF, + $ DSYTRF_RK, DSYTRF_ROOK, DSYTRI, DSYTRI_3, + $ DSYTRI_3X, DSYTRI_ROOK, DSYTRI2, DSYTRI2X, + $ DSYTRS, DSYTRS_3, DSYTRS_ROOK, DSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -124,6 +125,7 @@ SUBROUTINE DERRSY( PATH, NUNIT ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -154,6 +156,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 4 CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) * * DSYTF2 * @@ -194,6 +202,19 @@ SUBROUTINE DERRSY( PATH, NUNIT ) CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) * +* DSYTRI2X +* + SRNAMT = 'DSYTRI2X' + INFOT = 1 + CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) +* * DSYTRS * SRNAMT = 'DSYTRS' @@ -326,6 +347,12 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 4 CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * DSYTF2_ROOK * @@ -387,6 +414,119 @@ SUBROUTINE DERRSY( PATH, NUNIT ) INFOT = 6 CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* DSYTRF_RK +* + SRNAMT = 'DSYTRF_RK' + INFOT = 1 + CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_RK +* + SRNAMT = 'DSYTF2_RK' + INFOT = 1 + CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3 +* + SRNAMT = 'DSYTRI_3' + INFOT = 1 + CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3X +* + SRNAMT = 'DSYTRI_3X' + INFOT = 1 + CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_3 +* + SRNAMT = 'DSYTRS_3' + INFOT = 1 + CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* DSYCON_3 +* + SRNAMT = 'DSYCON_3' + INFOT = 1 + CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/derrtr.f b/lapack-netlib/TESTING/LIN/derrtr.f index bf2071c8b8..f709ba7e65 100644 --- a/lapack-netlib/TESTING/LIN/derrtr.f +++ b/lapack-netlib/TESTING/LIN/derrtr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRTR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRTR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrtsqr.f b/lapack-netlib/TESTING/LIN/derrtsqr.f new file mode 100644 index 0000000000..c8ad302571 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/derrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b DERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRTSQR tests the error exits for the DOUBLE PRECISION routines +*> that use the TSQR decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRTSQR( PATH, NUNIT ) + 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 .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGEQR, + $ DGEMQR, DGELQ, DGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* DGEQR +* + SRNAMT = 'DGEQR' + INFOT = 1 + CALL DGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'DGEQR', INFOT, NOUT, LERR, OK ) +* +* DGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'DGEMQR' + NB=1 + INFOT = 1 + CALL DGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMQR( 'R', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DGEMQR( 'L', 'N', 2, 1, 1, A, 2, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'DGEMQR', INFOT, NOUT, LERR, OK ) +* +* DGELQ +* + SRNAMT = 'DGELQ' + INFOT = 1 + CALL DGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'DGELQ', INFOT, NOUT, LERR, OK ) +* +* DGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'DGEMLQ' + NB=1 + INFOT = 1 + CALL DGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'DGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRTSQR +* + END diff --git a/lapack-netlib/TESTING/LIN/derrtz.f b/lapack-netlib/TESTING/LIN/derrtz.f index 072c006e4f..1980d1fa05 100644 --- a/lapack-netlib/TESTING/LIN/derrtz.f +++ b/lapack-netlib/TESTING/LIN/derrtz.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRTZ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRTZ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/derrvx.f b/lapack-netlib/TESTING/LIN/derrvx.f index ea9a7d0d5a..58f270c62a 100644 --- a/lapack-netlib/TESTING/LIN/derrvx.f +++ b/lapack-netlib/TESTING/LIN/derrvx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- -* April 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ SUBROUTINE DERRVX( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -91,7 +91,7 @@ SUBROUTINE DERRVX( PATH, NUNIT ) EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSV_ROOK, DSYSVX + $ DSYSV_AA, DSYSV_RK, DSYSV_ROOK, DSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,13 +118,14 @@ SUBROUTINE DERRVX( PATH, NUNIT ) A( I, J ) = 1.D0 / DBLE( I+J ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE - B( J ) = 0.D0 - R1( J ) = 0.D0 - R2( J ) = 0.D0 - W( J ) = 0.D0 - X( J ) = 0.D0 - C( J ) = 0.D0 - R( J ) = 0.D0 + B( J ) = 0.D+0 + E( J ) = 0.D+0 + R1( J ) = 0.D+0 + R2( J ) = 0.D+0 + W( J ) = 0.D+0 + X( J ) = 0.D+0 + C( J ) = 0.D+0 + R( J ) = 0.D+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -583,9 +584,18 @@ SUBROUTINE DERRVX( PATH, NUNIT ) INFOT = 3 CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) * * DSYSVX * @@ -641,9 +651,71 @@ SUBROUTINE DERRVX( PATH, NUNIT ) INFOT = 3 CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* DSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'DSYSV_RK' + INFOT = 1 + CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* DSYSV_AA +* + SRNAMT = 'DSYSV_AA' + INFOT = 1 + CALL DSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/derrvxx.f b/lapack-netlib/TESTING/LIN/derrvxx.f index ef4029e7d8..6e96b32bd4 100644 --- a/lapack-netlib/TESTING/LIN/derrvxx.f +++ b/lapack-netlib/TESTING/LIN/derrvxx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,9 +82,10 @@ SUBROUTINE DERRVX( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), - $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,7 +95,8 @@ SUBROUTINE DERRVX( PATH, NUNIT ) EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSVX, DGESVXX, DSYSVXX, DPOSVXX, DGBSVXX + $ DSYSV_RK, DSYSV_ROOK, DSYSVX, DGESVXX, DSYSVXX, + $ DPOSVXX, DGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -121,13 +123,14 @@ SUBROUTINE DERRVX( PATH, NUNIT ) A( I, J ) = 1.D0 / DBLE( I+J ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE - B( J ) = 0.D0 - R1( J ) = 0.D0 - R2( J ) = 0.D0 - W( J ) = 0.D0 - X( J ) = 0.D0 - C( J ) = 0.D0 - R( J ) = 0.D0 + B( J ) = 0.D+0 + E( J ) = 0.D+0 + R1( J ) = 0.D+0 + R2( J ) = 0.D+0 + W( J ) = 0.D+0 + X( J ) = 0.D+0 + C( J ) = 0.D+0 + R( J ) = 0.D+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -795,9 +798,18 @@ SUBROUTINE DERRVX( PATH, NUNIT ) INFOT = 3 CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) * * DSYSVX * @@ -906,6 +918,68 @@ SUBROUTINE DERRVX( PATH, NUNIT ) $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO ) CALL CHKXER( 'DSYSVXX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* DSYSV_ROOK +* + SRNAMT = 'DSYSV_ROOK' + INFOT = 1 + CALL DSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* DSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'DSYSV_RK' + INFOT = 1 + CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/dgbt01.f b/lapack-netlib/TESTING/LIN/dgbt01.f index 90211b6d13..2515733f59 100644 --- a/lapack-netlib/TESTING/LIN/dgbt01.f +++ b/lapack-netlib/TESTING/LIN/dgbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KL, KU, LDA, LDAFAC, M, N * DOUBLE PRECISION RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KL, KU, LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/dgbt02.f b/lapack-netlib/TESTING/LIN/dgbt02.f index 3d1f8690b6..bc11ba7d4e 100644 --- a/lapack-netlib/TESTING/LIN/dgbt02.f +++ b/lapack-netlib/TESTING/LIN/dgbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, * LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -139,10 +139,10 @@ SUBROUTINE DGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, $ LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dgbt05.f b/lapack-netlib/TESTING/LIN/dgbt05.f index 831526f201..1333abb9a7 100644 --- a/lapack-netlib/TESTING/LIN/dgbt05.f +++ b/lapack-netlib/TESTING/LIN/dgbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -176,10 +176,10 @@ SUBROUTINE DGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dgelqs.f b/lapack-netlib/TESTING/LIN/dgelqs.f index aa1d45443b..46683ef12f 100644 --- a/lapack-netlib/TESTING/LIN/dgelqs.f +++ b/lapack-netlib/TESTING/LIN/dgelqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -121,10 +121,10 @@ SUBROUTINE DGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dgennd.f b/lapack-netlib/TESTING/LIN/dgennd.f index c475f31d7e..986775af42 100644 --- a/lapack-netlib/TESTING/LIN/dgennd.f +++ b/lapack-netlib/TESTING/LIN/dgennd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION DGENND (M, N, A, LDA) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== LOGICAL FUNCTION DGENND (M, N, A, LDA) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/TESTING/LIN/dgeqls.f b/lapack-netlib/TESTING/LIN/dgeqls.f index cc5a4dbf5f..1ca418f1b2 100644 --- a/lapack-netlib/TESTING/LIN/dgeqls.f +++ b/lapack-netlib/TESTING/LIN/dgeqls.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -122,10 +122,10 @@ SUBROUTINE DGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dgeqrs.f b/lapack-netlib/TESTING/LIN/dgeqrs.f index d1ccb9de50..83fddf4e1d 100644 --- a/lapack-netlib/TESTING/LIN/dgeqrs.f +++ b/lapack-netlib/TESTING/LIN/dgeqrs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -121,10 +121,10 @@ SUBROUTINE DGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dgerqs.f b/lapack-netlib/TESTING/LIN/dgerqs.f index 7daaeb72af..d3ea086fab 100644 --- a/lapack-netlib/TESTING/LIN/dgerqs.f +++ b/lapack-netlib/TESTING/LIN/dgerqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -122,10 +122,10 @@ SUBROUTINE DGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dget01.f b/lapack-netlib/TESTING/LIN/dget01.f index 4f2544d22b..88ed763b34 100644 --- a/lapack-netlib/TESTING/LIN/dget01.f +++ b/lapack-netlib/TESTING/LIN/dget01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAFAC, M, N * DOUBLE PRECISION RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -107,10 +107,10 @@ SUBROUTINE DGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/dget02.f b/lapack-netlib/TESTING/LIN/dget02.f index 6e3f181019..7b641b3b31 100644 --- a/lapack-netlib/TESTING/LIN/dget02.f +++ b/lapack-netlib/TESTING/LIN/dget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -133,10 +133,10 @@ SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dget03.f b/lapack-netlib/TESTING/LIN/dget03.f index afc1d72479..5b04c81ed5 100644 --- a/lapack-netlib/TESTING/LIN/dget03.f +++ b/lapack-netlib/TESTING/LIN/dget03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, * RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAINV, LDWORK, N * DOUBLE PRECISION RCOND, RESID @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -109,10 +109,10 @@ SUBROUTINE DGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, $ RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAINV, LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/dget04.f b/lapack-netlib/TESTING/LIN/dget04.f index 7f059c93a2..a5663f621b 100644 --- a/lapack-netlib/TESTING/LIN/dget04.f +++ b/lapack-netlib/TESTING/LIN/dget04.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDXACT, N, NRHS * DOUBLE PRECISION RCOND, RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dget06.f b/lapack-netlib/TESTING/LIN/dget06.f index 7ad082e166..a056e12581 100644 --- a/lapack-netlib/TESTING/LIN/dget06.f +++ b/lapack-netlib/TESTING/LIN/dget06.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DGET06( RCOND, RCONDC ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION RCOND, RCONDC * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== DOUBLE PRECISION FUNCTION DGET06( RCOND, RCONDC ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION RCOND, RCONDC diff --git a/lapack-netlib/TESTING/LIN/dget07.f b/lapack-netlib/TESTING/LIN/dget07.f index bf0e02f173..cd56c0ffe8 100644 --- a/lapack-netlib/TESTING/LIN/dget07.f +++ b/lapack-netlib/TESTING/LIN/dget07.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, CHKFERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CHKFERR @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -165,10 +165,10 @@ SUBROUTINE DGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dget08.f b/lapack-netlib/TESTING/LIN/dget08.f index bd5e5c0725..731b3924d0 100644 --- a/lapack-netlib/TESTING/LIN/dget08.f +++ b/lapack-netlib/TESTING/LIN/dget08.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGET08( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -133,10 +133,10 @@ SUBROUTINE DGET08( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dgtt01.f b/lapack-netlib/TESTING/LIN/dgtt01.f index b869d5ec63..29f4b25740 100644 --- a/lapack-netlib/TESTING/LIN/dgtt01.f +++ b/lapack-netlib/TESTING/LIN/dgtt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, * LDWORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDWORK, N * DOUBLE PRECISION RESID @@ -21,7 +21,7 @@ * $ DU2( * ), DUF( * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -134,10 +134,10 @@ SUBROUTINE DGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, $ LDWORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/dgtt02.f b/lapack-netlib/TESTING/LIN/dgtt02.f index 0b54502abe..956f0f7618 100644 --- a/lapack-netlib/TESTING/LIN/dgtt02.f +++ b/lapack-netlib/TESTING/LIN/dgtt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -124,10 +124,10 @@ SUBROUTINE DGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dgtt05.f b/lapack-netlib/TESTING/LIN/dgtt05.f index 02b46c342b..c39081f9e2 100644 --- a/lapack-netlib/TESTING/LIN/dgtt05.f +++ b/lapack-netlib/TESTING/LIN/dgtt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ DU( * ), FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -165,10 +165,10 @@ SUBROUTINE DGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dlahilb.f b/lapack-netlib/TESTING/LIN/dlahilb.f index 2f909dd4d4..a1989d578d 100644 --- a/lapack-netlib/TESTING/LIN/dlahilb.f +++ b/lapack-netlib/TESTING/LIN/dlahilb.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. * DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) * .. -* +* * *> \par Purpose: * ============= @@ -26,8 +26,8 @@ *> NRHS right-hand sides in B and solutions in X such that A*X=B. *> *> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all -*> entries are integers. The right-hand sides are the first NRHS -*> columns of M * the identity matrix, and the solutions are the +*> entries are integers. The right-hand sides are the first NRHS +*> columns of M * the identity matrix, and the solutions are the *> first NRHS columns of the inverse Hilbert matrix. *> *> The condition number of the Hilbert matrix grows exponentially with @@ -36,7 +36,7 @@ *> generated exactly without extra precision. Precision is exhausted *> when the largest entry in the inverse Hilbert matrix is greater than *> 2 to the power of the number of bits in the fraction of the data type -*> used plus one, which is 24 for single precision. +*> used plus one, which is 24 for single precision. *> *> In single, the generated solution is exact for N <= 6 and has *> small componentwise error for 7 <= N <= 11. @@ -50,7 +50,7 @@ *> N is INTEGER *> The dimension of the matrix A. *> \endverbatim -*> +*> *> \param[in] NRHS *> \verbatim *> NRHS is NRHS @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO diff --git a/lapack-netlib/TESTING/LIN/dlaord.f b/lapack-netlib/TESTING/LIN/dlaord.f index 13e3a03028..da3edb198a 100644 --- a/lapack-netlib/TESTING/LIN/dlaord.f +++ b/lapack-netlib/TESTING/LIN/dlaord.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAORD( JOB, N, X, INCX ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER INCX, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DLAORD( JOB, N, X, INCX ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/TESTING/LIN/dlaptm.f b/lapack-netlib/TESTING/LIN/dlaptm.f index 89322614c1..5c62ded108 100644 --- a/lapack-netlib/TESTING/LIN/dlaptm.f +++ b/lapack-netlib/TESTING/LIN/dlaptm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, N, NRHS * DOUBLE PRECISION ALPHA, BETA @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dlarhs.f b/lapack-netlib/TESTING/LIN/dlarhs.f index 75f8d4b8a0..f175cf8939 100644 --- a/lapack-netlib/TESTING/LIN/dlarhs.f +++ b/lapack-netlib/TESTING/LIN/dlarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -204,10 +204,10 @@ SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/LIN/dlatb4.f b/lapack-netlib/TESTING/LIN/dlatb4.f index 7983bd5657..6bdbe5597c 100644 --- a/lapack-netlib/TESTING/LIN/dlatb4.f +++ b/lapack-netlib/TESTING/LIN/dlatb4.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KL, KU, M, MODE, N * DOUBLE PRECISION ANORM, CNDNUM * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -120,10 +120,10 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, TYPE @@ -339,11 +339,10 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ANORM = ONE END IF * - ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR. - $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * -* xPO, xPP, xSY, xSP: Set parameters to generate a -* symmetric matrix. +* xPO, xPP: Set parameters to generate a +* symmetric positive definite matrix. * * Set TYPE, the type of matrix to be generated. * @@ -375,6 +374,43 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* +* + ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN +* +* xSY, xSP: Set parameters to generate a +* symmetric matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/dlatb5.f b/lapack-netlib/TESTING/LIN/dlatb5.f index 962094131d..16a5642b38 100644 --- a/lapack-netlib/TESTING/LIN/dlatb5.f +++ b/lapack-netlib/TESTING/LIN/dlatb5.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ANORM, CNDNUM * INTEGER IMAT, KL, KU, MODE, N * CHARACTER DIST, TYPE * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -114,10 +114,10 @@ SUBROUTINE DLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ANORM, CNDNUM diff --git a/lapack-netlib/TESTING/LIN/dlattb.f b/lapack-netlib/TESTING/LIN/dlattb.f index 7bf0d8a223..e35067f127 100644 --- a/lapack-netlib/TESTING/LIN/dlattb.f +++ b/lapack-netlib/TESTING/LIN/dlattb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, * LDAB, B, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, KD, LDAB, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION AB( LDAB, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -135,10 +135,10 @@ SUBROUTINE DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, $ LDAB, B, WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dlattp.f b/lapack-netlib/TESTING/LIN/dlattp.f index 031d17814b..407bd0716a 100644 --- a/lapack-netlib/TESTING/LIN/dlattp.f +++ b/lapack-netlib/TESTING/LIN/dlattp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -125,10 +125,10 @@ SUBROUTINE DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dlattr.f b/lapack-netlib/TESTING/LIN/dlattr.f index 4daea8fd5b..0e3a5ac6b5 100644 --- a/lapack-netlib/TESTING/LIN/dlattr.f +++ b/lapack-netlib/TESTING/LIN/dlattr.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, LDA, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -133,10 +133,10 @@ SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, $ WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dlavsp.f b/lapack-netlib/TESTING/LIN/dlavsp.f index 31235322a6..758c415fb2 100644 --- a/lapack-netlib/TESTING/LIN/dlavsp.f +++ b/lapack-netlib/TESTING/LIN/dlavsp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -130,10 +130,10 @@ SUBROUTINE DLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dlqt01.f b/lapack-netlib/TESTING/LIN/dlqt01.f index 517fbe8e0c..c17045f961 100644 --- a/lapack-netlib/TESTING/LIN/dlqt01.f +++ b/lapack-netlib/TESTING/LIN/dlqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dlqt02.f b/lapack-netlib/TESTING/LIN/dlqt02.f index 1783b93048..55b5a6c89b 100644 --- a/lapack-netlib/TESTING/LIN/dlqt02.f +++ b/lapack-netlib/TESTING/LIN/dlqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -135,10 +135,10 @@ SUBROUTINE DLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dlqt03.f b/lapack-netlib/TESTING/LIN/dlqt03.f index 2e6cb005e3..dc754554fa 100644 --- a/lapack-netlib/TESTING/LIN/dlqt03.f +++ b/lapack-netlib/TESTING/LIN/dlqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dlqt04.f b/lapack-netlib/TESTING/LIN/dlqt04.f new file mode 100644 index 0000000000..b73248b624 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dlqt04.f @@ -0,0 +1,259 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLQT04 tests DGELQT and DGEMLQT. +*> \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] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLQT04(M,N,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL DLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL DLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL DGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N ) + CALL DGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, L, LL ) + CALL DLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = DLANGE( '1', M, N, A, M, RWORK ) + RESID = DLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', N, N, ZERO, ONE, L, LL ) + CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL ) + RESID = DLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL DGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL DGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL DGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL DGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/lapack-netlib/TESTING/LIN/dlqt05.f b/lapack-netlib/TESTING/LIN/dlqt05.f new file mode 100644 index 0000000000..ce2604e418 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dlqt05.f @@ -0,0 +1,286 @@ +*> \brief \b DLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DQRT05 tests DTPLQT and DTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLQT05(M,N,L,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL DLASET( 'Full', M, N2, ZERO, ZERO, A, M ) + CALL DLASET( 'Full', NB, M, ZERO, ZERO, T, NB ) + DO J=1,M + CALL DLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL DLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL DLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL DLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL DTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL DLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 ) + CALL DGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL DLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 ) + CALL DLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*T| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = DLANGE( '1', M, N2, A, M, RWORK ) + RESID = DLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL DLASET( 'Full', N2, N2, ZERO, ONE, R, N2 ) + CALL DSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 ) + RESID = DLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL DLASET( 'Full', N2, M, ZERO, ONE, C, N2 ) + DO J=1,M + CALL DLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = DLANGE( '1', N2, M, C, N2, RWORK) + CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL DTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL DGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = DLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL DLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL DTPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL DGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = DLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL DLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = DLANGE( '1', M, N2, D, M, RWORK) + CALL DLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL DTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL DGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = DLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL DTPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL DGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = DLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/dpbt01.f b/lapack-netlib/TESTING/LIN/dpbt01.f index b0eeaf2a07..4acd74f5af 100644 --- a/lapack-netlib/TESTING/LIN/dpbt01.f +++ b/lapack-netlib/TESTING/LIN/dpbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDAFAC, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -119,10 +119,10 @@ SUBROUTINE DPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpbt02.f b/lapack-netlib/TESTING/LIN/dpbt02.f index fdd6401a74..657cdc9f71 100644 --- a/lapack-netlib/TESTING/LIN/dpbt02.f +++ b/lapack-netlib/TESTING/LIN/dpbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpbt05.f b/lapack-netlib/TESTING/LIN/dpbt05.f index dfc70f5f17..1ad4c0f6bf 100644 --- a/lapack-netlib/TESTING/LIN/dpbt05.f +++ b/lapack-netlib/TESTING/LIN/dpbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -171,10 +171,10 @@ SUBROUTINE DPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpot01.f b/lapack-netlib/TESTING/LIN/dpot01.f index f11174f4e0..8d84a1fe6a 100644 --- a/lapack-netlib/TESTING/LIN/dpot01.f +++ b/lapack-netlib/TESTING/LIN/dpot01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpot02.f b/lapack-netlib/TESTING/LIN/dpot02.f index 672eb06723..347b50378c 100644 --- a/lapack-netlib/TESTING/LIN/dpot02.f +++ b/lapack-netlib/TESTING/LIN/dpot02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -127,10 +127,10 @@ SUBROUTINE DPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpot03.f b/lapack-netlib/TESTING/LIN/dpot03.f index 7fbd05e028..d7a0cca92c 100644 --- a/lapack-netlib/TESTING/LIN/dpot03.f +++ b/lapack-netlib/TESTING/LIN/dpot03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -125,10 +125,10 @@ SUBROUTINE DPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpot05.f b/lapack-netlib/TESTING/LIN/dpot05.f index 4ebbd030b7..fa94909155 100644 --- a/lapack-netlib/TESTING/LIN/dpot05.f +++ b/lapack-netlib/TESTING/LIN/dpot05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -164,10 +164,10 @@ SUBROUTINE DPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpot06.f b/lapack-netlib/TESTING/LIN/dpot06.f index d2dc1fe21d..420662c1b6 100644 --- a/lapack-netlib/TESTING/LIN/dpot06.f +++ b/lapack-netlib/TESTING/LIN/dpot06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -127,10 +127,10 @@ SUBROUTINE DPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dppt01.f b/lapack-netlib/TESTING/LIN/dppt01.f index 6dcae7261d..2ad9e6839c 100644 --- a/lapack-netlib/TESTING/LIN/dppt01.f +++ b/lapack-netlib/TESTING/LIN/dppt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPPT01( UPLO, N, A, AFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( * ), AFAC( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DPPT01( UPLO, N, A, AFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dppt02.f b/lapack-netlib/TESTING/LIN/dppt02.f index f7c94074a8..de878137a6 100644 --- a/lapack-netlib/TESTING/LIN/dppt02.f +++ b/lapack-netlib/TESTING/LIN/dppt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( * ), B( LDB, * ), RWORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -122,10 +122,10 @@ SUBROUTINE DPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dppt03.f b/lapack-netlib/TESTING/LIN/dppt03.f index f11ee16fdd..edaec4446c 100644 --- a/lapack-netlib/TESTING/LIN/dppt03.f +++ b/lapack-netlib/TESTING/LIN/dppt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDWORK, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( * ), AINV( * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -110,10 +110,10 @@ SUBROUTINE DPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dppt05.f b/lapack-netlib/TESTING/LIN/dppt05.f index cd1a8c94c9..8d9dcc3ca9 100644 --- a/lapack-netlib/TESTING/LIN/dppt05.f +++ b/lapack-netlib/TESTING/LIN/dppt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -156,10 +156,10 @@ SUBROUTINE DPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dpst01.f b/lapack-netlib/TESTING/LIN/dpst01.f index b5eb7d1065..d6b6da93da 100644 --- a/lapack-netlib/TESTING/LIN/dpst01.f +++ b/lapack-netlib/TESTING/LIN/dpst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, * PIV, RWORK, RESID, RANK ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION RESID * INTEGER LDA, LDAFAC, LDPERM, N, RANK @@ -21,7 +21,7 @@ * $ PERM( LDPERM, * ), RWORK( * ) * INTEGER PIV( * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -134,10 +134,10 @@ SUBROUTINE DPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, $ PIV, RWORK, RESID, RANK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION RESID diff --git a/lapack-netlib/TESTING/LIN/dptt01.f b/lapack-netlib/TESTING/LIN/dptt01.f index 304079b1e9..44c609cbd9 100644 --- a/lapack-netlib/TESTING/LIN/dptt01.f +++ b/lapack-netlib/TESTING/LIN/dptt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPTT01( N, D, E, DF, EF, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER N * DOUBLE PRECISION RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION D( * ), DF( * ), E( * ), EF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DPTT01( N, D, E, DF, EF, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/TESTING/LIN/dptt02.f b/lapack-netlib/TESTING/LIN/dptt02.f index 7641c3320d..a9e8bd6205 100644 --- a/lapack-netlib/TESTING/LIN/dptt02.f +++ b/lapack-netlib/TESTING/LIN/dptt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, N, NRHS * DOUBLE PRECISION RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dptt05.f b/lapack-netlib/TESTING/LIN/dptt05.f index 5b816620d5..4a7aa6dc8a 100644 --- a/lapack-netlib/TESTING/LIN/dptt05.f +++ b/lapack-netlib/TESTING/LIN/dptt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, * FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, LDXACT, N, NRHS * .. @@ -19,7 +19,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -150,10 +150,10 @@ SUBROUTINE DPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, $ FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/dqlt01.f b/lapack-netlib/TESTING/LIN/dqlt01.f index 7f38c1a142..7bc66cb421 100644 --- a/lapack-netlib/TESTING/LIN/dqlt01.f +++ b/lapack-netlib/TESTING/LIN/dqlt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqlt02.f b/lapack-netlib/TESTING/LIN/dqlt02.f index c810d160f8..16a532b536 100644 --- a/lapack-netlib/TESTING/LIN/dqlt02.f +++ b/lapack-netlib/TESTING/LIN/dqlt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqlt03.f b/lapack-netlib/TESTING/LIN/dqlt03.f index e425f80b97..40c6638c5a 100644 --- a/lapack-netlib/TESTING/LIN/dqlt03.f +++ b/lapack-netlib/TESTING/LIN/dqlt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqpt01.f b/lapack-netlib/TESTING/LIN/dqpt01.f index fba9d0d455..b72eaaa77e 100644 --- a/lapack-netlib/TESTING/LIN/dqpt01.f +++ b/lapack-netlib/TESTING/LIN/dqpt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -120,10 +120,10 @@ DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt01.f b/lapack-netlib/TESTING/LIN/dqrt01.f index bc27e6eb80..fd411eb04c 100644 --- a/lapack-netlib/TESTING/LIN/dqrt01.f +++ b/lapack-netlib/TESTING/LIN/dqrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt01p.f b/lapack-netlib/TESTING/LIN/dqrt01p.f index 1cc8479cbf..6f9ba5ea93 100644 --- a/lapack-netlib/TESTING/LIN/dqrt01p.f +++ b/lapack-netlib/TESTING/LIN/dqrt01p.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt02.f b/lapack-netlib/TESTING/LIN/dqrt02.f index ac584a33e2..9008a49004 100644 --- a/lapack-netlib/TESTING/LIN/dqrt02.f +++ b/lapack-netlib/TESTING/LIN/dqrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -135,10 +135,10 @@ SUBROUTINE DQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt03.f b/lapack-netlib/TESTING/LIN/dqrt03.f index b4ca482b8a..9c957b02c5 100644 --- a/lapack-netlib/TESTING/LIN/dqrt03.f +++ b/lapack-netlib/TESTING/LIN/dqrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt04.f b/lapack-netlib/TESTING/LIN/dqrt04.f index 04a400f0f7..5d9e10313e 100644 --- a/lapack-netlib/TESTING/LIN/dqrt04.f +++ b/lapack-netlib/TESTING/LIN/dqrt04.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT04(M,N,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER M, N, NB, LDT * .. Return values .. * DOUBLE PRECISION RESULT(6) -* +* * *> \par Purpose: * ============= @@ -54,17 +54,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -74,7 +74,7 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -87,9 +87,9 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * ===================================================================== * * .. -* .. Local allocatable arrays +* .. Local allocatable arrays DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) * * .. Parameters .. @@ -109,11 +109,11 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN * .. * .. Data statements .. - DATA ISEED / 1988, 1989, 1990, 1991 / -* + DATA ISEED / 1988, 1989, 1990, 1991 / +* EPS = DLAMCH( 'Epsilon' ) K = MIN(M,N) L = MAX(M,N) @@ -121,8 +121,8 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * * Dynamically allocate local arrays * - ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), - $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), $ D(N,M), DF(N,M) ) * * Put random numbers into A and copy to AF @@ -140,7 +140,7 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * Generate the m-by-m matrix Q * CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M ) - CALL DGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, + CALL DGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, $ WORK, INFO ) * * Copy R @@ -176,7 +176,7 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * * Apply Q to C as Q*C * - CALL DGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + CALL DGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |Q*C - Q*C| / |C| @@ -195,7 +195,7 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * * Apply Q to C as QT*C * - CALL DGEMQRT( 'L', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + CALL DGEMQRT( 'L', 'T', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |QT*C - QT*C| / |C| @@ -206,7 +206,7 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -218,8 +218,8 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * * Apply Q to D as D*Q * - CALL DGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL DGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*Q - D*Q| / |D| * @@ -237,8 +237,8 @@ SUBROUTINE DQRT04(M,N,NB,RESULT) * * Apply Q to D as D*QT * - CALL DGEMQRT( 'R', 'T', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL DGEMQRT( 'R', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/dqrt05.f b/lapack-netlib/TESTING/LIN/dqrt05.f index 1aba348586..2e46100685 100644 --- a/lapack-netlib/TESTING/LIN/dqrt05.f +++ b/lapack-netlib/TESTING/LIN/dqrt05.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT05(M,N,L,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER LWORK, M, N, L, NB, LDT * .. Return values .. * DOUBLE PRECISION RESULT(6) -* +* * *> \par Purpose: * ============= @@ -45,7 +45,7 @@ *> The number of rows of the upper trapezoidal part the *> lower test matrix. 0 <= L <= M. *> \endverbatim -*> +*> *> \param[in] NB *> \verbatim *> NB is INTEGER @@ -61,17 +61,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -81,7 +81,7 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -92,11 +92,11 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) DOUBLE PRECISION RESULT(6) * * ===================================================================== -* +* * .. -* .. Local allocatable arrays +* .. Local allocatable arrays DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) * * .. Parameters .. @@ -117,7 +117,7 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) * .. * .. Data statements .. DATA ISEED / 1988, 1989, 1990, 1991 / -* +* EPS = DLAMCH( 'Epsilon' ) K = N M2 = M+N @@ -131,7 +131,7 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) * Dynamically allocate all arrays * ALLOCATE(A(M2,N),AF(M2,N),Q(M2,M2),R(M2,M2),RWORK(M2), - $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), + $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), $ D(N,M2),DF(N,M2) ) * * Put random stuff into A @@ -220,7 +220,7 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) * Apply Q to C as QT*C * CALL DTPMQRT( 'L','T',M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,M2, - $ CF(NP1,1),M2,WORK,INFO) + $ CF(NP1,1),M2,WORK,INFO) * * Compute |QT*C - QT*C| / |C| * @@ -230,7 +230,7 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M2)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -262,8 +262,8 @@ SUBROUTINE DQRT05(M,N,L,NB,RESULT) * Apply Q to D as D*QT * CALL DTPMQRT('R','T',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N, - $ DF(1,NP1),N,WORK,INFO) - + $ DF(1,NP1),N,WORK,INFO) + * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/dqrt11.f b/lapack-netlib/TESTING/LIN/dqrt11.f index 0dcfac0017..fe29ca5893 100644 --- a/lapack-netlib/TESTING/LIN/dqrt11.f +++ b/lapack-netlib/TESTING/LIN/dqrt11.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DQRT11( M, K, A, LDA, TAU, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== DOUBLE PRECISION FUNCTION DQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M diff --git a/lapack-netlib/TESTING/LIN/dqrt12.f b/lapack-netlib/TESTING/LIN/dqrt12.f index 948bd2d849..b8da5b6239 100644 --- a/lapack-netlib/TESTING/LIN/dqrt12.f +++ b/lapack-netlib/TESTING/LIN/dqrt12.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dqrt13.f b/lapack-netlib/TESTING/LIN/dqrt13.f index fa781f4cdb..42947b2cb6 100644 --- a/lapack-netlib/TESTING/LIN/dqrt13.f +++ b/lapack-netlib/TESTING/LIN/dqrt13.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, SCALE * DOUBLE PRECISION NORMA @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, SCALE diff --git a/lapack-netlib/TESTING/LIN/dqrt14.f b/lapack-netlib/TESTING/LIN/dqrt14.f index 9892b9d76f..9301e251f3 100644 --- a/lapack-netlib/TESTING/LIN/dqrt14.f +++ b/lapack-netlib/TESTING/LIN/dqrt14.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DQRT14( TRANS, M, N, NRHS, A, LDA, X, * LDX, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDX, LWORK, M, N, NRHS @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -116,10 +116,10 @@ DOUBLE PRECISION FUNCTION DQRT14( TRANS, M, N, NRHS, A, LDA, X, $ LDX, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dqrt15.f b/lapack-netlib/TESTING/LIN/dqrt15.f index c7f711aa85..68cf0cc8cb 100644 --- a/lapack-netlib/TESTING/LIN/dqrt15.f +++ b/lapack-netlib/TESTING/LIN/dqrt15.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, * RANK, NORMA, NORMB, ISEED, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE * DOUBLE PRECISION NORMA, NORMB @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -135,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -148,10 +148,10 @@ SUBROUTINE DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, $ RANK, NORMA, NORMB, ISEED, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE diff --git a/lapack-netlib/TESTING/LIN/dqrt16.f b/lapack-netlib/TESTING/LIN/dqrt16.f index afc7b4f76e..157f78e2f7 100644 --- a/lapack-netlib/TESTING/LIN/dqrt16.f +++ b/lapack-netlib/TESTING/LIN/dqrt16.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -133,10 +133,10 @@ SUBROUTINE DQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/dqrt17.f b/lapack-netlib/TESTING/LIN/dqrt17.f index f71f30222b..78580dca11 100644 --- a/lapack-netlib/TESTING/LIN/dqrt17.f +++ b/lapack-netlib/TESTING/LIN/dqrt17.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DQRT17( TRANS, IRESID, M, N, NRHS, A, * LDA, X, LDX, B, LDB, C, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDB, * ), * $ WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_lin * @@ -150,10 +150,10 @@ DOUBLE PRECISION FUNCTION DQRT17( TRANS, IRESID, M, N, NRHS, A, $ LDA, X, LDX, B, LDB, C, WORK, LWORK ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -172,8 +172,7 @@ DOUBLE PRECISION FUNCTION DQRT17( TRANS, IRESID, M, N, NRHS, A, * .. * .. Local Scalars .. INTEGER INFO, ISCL, NCOLS, NROWS - DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX, - $ SMLNUM + DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) diff --git a/lapack-netlib/TESTING/LIN/drqt01.f b/lapack-netlib/TESTING/LIN/drqt01.f index a74cb74848..d652b2a2bd 100644 --- a/lapack-netlib/TESTING/LIN/drqt01.f +++ b/lapack-netlib/TESTING/LIN/drqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -126,10 +126,10 @@ SUBROUTINE DRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/drqt02.f b/lapack-netlib/TESTING/LIN/drqt02.f index 153c5bf704..d10b5c117b 100644 --- a/lapack-netlib/TESTING/LIN/drqt02.f +++ b/lapack-netlib/TESTING/LIN/drqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/drqt03.f b/lapack-netlib/TESTING/LIN/drqt03.f index 655b443571..7ec0d6c7fb 100644 --- a/lapack-netlib/TESTING/LIN/drqt03.f +++ b/lapack-netlib/TESTING/LIN/drqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -136,10 +136,10 @@ SUBROUTINE DRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/drzt01.f b/lapack-netlib/TESTING/LIN/drzt01.f index 49ebff9c3f..2108cd1c97 100644 --- a/lapack-netlib/TESTING/LIN/drzt01.f +++ b/lapack-netlib/TESTING/LIN/drzt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DRZT01( M, N, A, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -85,12 +85,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -98,10 +98,10 @@ DOUBLE PRECISION FUNCTION DRZT01( M, N, A, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/drzt02.f b/lapack-netlib/TESTING/LIN/drzt02.f index f9677696ff..de3f266212 100644 --- a/lapack-netlib/TESTING/LIN/drzt02.f +++ b/lapack-netlib/TESTING/LIN/drzt02.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DRZT02( M, N, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -91,10 +91,10 @@ DOUBLE PRECISION FUNCTION DRZT02( M, N, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/dspt01.f b/lapack-netlib/TESTING/LIN/dspt01.f index 50e32c3fb0..f1bc904fd9 100644 --- a/lapack-netlib/TESTING/LIN/dspt01.f +++ b/lapack-netlib/TESTING/LIN/dspt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( * ), AFAC( * ), C( LDC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dsyt01_3.f b/lapack-netlib/TESTING/LIN/dsyt01_3.f new file mode 100644 index 0000000000..5eabb05f6a --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dsyt01_3.f @@ -0,0 +1,248 @@ +*> \brief \b DSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ E( * ), RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by DSYTRF_RK +*> (or DSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DSYTRF_RK (or DSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ), RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVSY_ROOK, DSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL DSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* 3) Call DLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL DLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call DLAVSY_ROOK again to multiply by U (or L ). +* + CALL DLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL DSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of DSYT01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/dsyt01_aa.f b/lapack-netlib/TESTING/LIN/dsyt01_aa.f new file mode 100644 index 0000000000..f008ecf2ec --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dsyt01_aa.f @@ -0,0 +1,263 @@ +*> \brief \b DSYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYT01 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by DSYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DSYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVSY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL DLASET( 'Full', N, N, ZERO, ZERO, C, LDC ) + CALL DLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF +* +* Call DTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DTRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL DTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call DTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL DTRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF + ENDIF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL DSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL DSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of DSYT01 +* + END diff --git a/lapack-netlib/TESTING/LIN/dtbt02.f b/lapack-netlib/TESTING/LIN/dtbt02.f index a06e773c88..f0f522a968 100644 --- a/lapack-netlib/TESTING/LIN/dtbt02.f +++ b/lapack-netlib/TESTING/LIN/dtbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, * LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -154,10 +154,10 @@ SUBROUTINE DTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, $ LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtbt03.f b/lapack-netlib/TESTING/LIN/dtbt03.f index 4b732b7850..3aedad6545 100644 --- a/lapack-netlib/TESTING/LIN/dtbt03.f +++ b/lapack-netlib/TESTING/LIN/dtbt03.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, * SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), CNORM( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -175,10 +175,10 @@ SUBROUTINE DTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, $ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtbt05.f b/lapack-netlib/TESTING/LIN/dtbt05.f index 951e07312f..3c2a5318c7 100644 --- a/lapack-netlib/TESTING/LIN/dtbt05.f +++ b/lapack-netlib/TESTING/LIN/dtbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -189,10 +189,10 @@ SUBROUTINE DTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtbt06.f b/lapack-netlib/TESTING/LIN/dtbt06.f index ded24c9731..2fd11f0e9e 100644 --- a/lapack-netlib/TESTING/LIN/dtbt06.f +++ b/lapack-netlib/TESTING/LIN/dtbt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, * WORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER KD, LDAB, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -125,10 +125,10 @@ SUBROUTINE DTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, $ WORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtplqt.f b/lapack-netlib/TESTING/LIN/dtplqt.f new file mode 100644 index 0000000000..9fcecc9842 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dtplqt.f @@ -0,0 +1,270 @@ +*> \brief \b DTPLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTPQRT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL DTPLQT2, DTPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL DTPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL DTPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of DTPLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/dtpt01.f b/lapack-netlib/TESTING/LIN/dtpt01.f index 82754bd00b..504dca6275 100644 --- a/lapack-netlib/TESTING/LIN/dtpt01.f +++ b/lapack-netlib/TESTING/LIN/dtpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AINVP( * ), AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtpt02.f b/lapack-netlib/TESTING/LIN/dtpt02.f index cec60142c5..777fdfc3b0 100644 --- a/lapack-netlib/TESTING/LIN/dtpt02.f +++ b/lapack-netlib/TESTING/LIN/dtpt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -141,10 +141,10 @@ SUBROUTINE DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, $ WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtpt03.f b/lapack-netlib/TESTING/LIN/dtpt03.f index 4832f8f589..ad82e59e91 100644 --- a/lapack-netlib/TESTING/LIN/dtpt03.f +++ b/lapack-netlib/TESTING/LIN/dtpt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, * TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION AP( * ), B( LDB, * ), CNORM( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -161,10 +161,10 @@ SUBROUTINE DTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, $ TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtpt05.f b/lapack-netlib/TESTING/LIN/dtpt05.f index a416751cf3..458a42ec4d 100644 --- a/lapack-netlib/TESTING/LIN/dtpt05.f +++ b/lapack-netlib/TESTING/LIN/dtpt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -174,10 +174,10 @@ SUBROUTINE DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtpt06.f b/lapack-netlib/TESTING/LIN/dtpt06.f index 4013d38de8..3f7c688327 100644 --- a/lapack-netlib/TESTING/LIN/dtpt06.f +++ b/lapack-netlib/TESTING/LIN/dtpt06.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * DOUBLE PRECISION AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtrt01.f b/lapack-netlib/TESTING/LIN/dtrt01.f index 6515763324..3039a2be75 100644 --- a/lapack-netlib/TESTING/LIN/dtrt01.f +++ b/lapack-netlib/TESTING/LIN/dtrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, LDAINV, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -124,10 +124,10 @@ SUBROUTINE DTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, $ WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtrt02.f b/lapack-netlib/TESTING/LIN/dtrt02.f index b94af80553..ad7d9b9637 100644 --- a/lapack-netlib/TESTING/LIN/dtrt02.f +++ b/lapack-netlib/TESTING/LIN/dtrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, * LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -150,10 +150,10 @@ SUBROUTINE DTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, $ LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtrt03.f b/lapack-netlib/TESTING/LIN/dtrt03.f index 46926bdb91..067db391b9 100644 --- a/lapack-netlib/TESTING/LIN/dtrt03.f +++ b/lapack-netlib/TESTING/LIN/dtrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, * CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), CNORM( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -156,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -169,10 +169,10 @@ SUBROUTINE DTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, $ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtrt05.f b/lapack-netlib/TESTING/LIN/dtrt05.f index 949868caae..f5ef134621 100644 --- a/lapack-netlib/TESTING/LIN/dtrt05.f +++ b/lapack-netlib/TESTING/LIN/dtrt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -181,10 +181,10 @@ SUBROUTINE DTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtrt06.f b/lapack-netlib/TESTING/LIN/dtrt06.f index d91ac2b4d4..f4f861e42b 100644 --- a/lapack-netlib/TESTING/LIN/dtrt06.f +++ b/lapack-netlib/TESTING/LIN/dtrt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, * RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_lin * @@ -121,10 +121,10 @@ SUBROUTINE DTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, $ RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/dtsqr01.f b/lapack-netlib/TESTING/LIN/dtsqr01.f new file mode 100644 index 0000000000..7a50009cc8 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dtsqr01.f @@ -0,0 +1,463 @@ +*> \brief \b DTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \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] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DTSQR01(TSSW, M, N, MB, NB, RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, TSIZE, MNB + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION TQUERY( 5 ), WORKQUERY +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB +* +* 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), LQ(L,N) ) +* +* 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 ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + CALL DGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL DGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'DGEQR' + CALL DGEQR( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL DLASET( 'Full', M, M, ZERO, ONE, Q, M ) + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'N', M, M, K, AF, M, T, TSIZE, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, R, M ) + CALL DLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |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 +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', M, M, ZERO, ONE, R, M ) + CALL DSYRK( 'U', 'C', 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 and a copy CF +* + 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 +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |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 QT*C +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'L', 'T', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |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 +* + srnamt = 'DGEMQR' + CALL DGEMQR( 'R', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |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 +* + CALL DGEMQR( 'R', 'T', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |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( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + CALL DGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, + $ WORKQUERY, -1, INFO ) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'DGELQ' + CALL DGELQ( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N ) + srnamt = 'DGEMLQ' + CALL DGEMLQ( 'R', 'N', N, N, K, AF, M, T, TSIZE, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, LQ, L ) + CALL DLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = DLANGE( '1', M, N, A, M, RWORK ) + RESID = DLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL DLASET( 'Full', N, N, ZERO, ONE, LQ, L ) + CALL DSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L ) + RESID = DLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL DGEMLQ( 'L', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL DGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL DLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL DGEMLQ( 'L', 'T', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL DGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL DGEMLQ( 'R', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL DGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL DLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL DGEMLQ( 'R', 'T', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL DGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = DLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/icopy.f b/lapack-netlib/TESTING/LIN/icopy.f index 1a94b36189..a518b0f0fc 100644 --- a/lapack-netlib/TESTING/LIN/icopy.f +++ b/lapack-netlib/TESTING/LIN/icopy.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ICOPY( N, SX, INCX, SY, INCY ) -* +* * .. Scalar Arguments .. * INTEGER INCX, INCY, N * .. * .. Array Arguments .. * INTEGER SX( * ), SY( * ) * .. -* +* * *> \par Purpose: * ============= @@ -63,22 +63,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ICOPY( N, SX, INCX, SY, INCY ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff --git a/lapack-netlib/TESTING/LIN/ilaenv.f b/lapack-netlib/TESTING/LIN/ilaenv.f index 3433576440..657128bc19 100644 --- a/lapack-netlib/TESTING/LIN/ilaenv.f +++ b/lapack-netlib/TESTING/LIN/ilaenv.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * N4 ) -* +* * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * @@ -150,10 +150,10 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -184,7 +184,21 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, * * Return a value from the common block. * - ILAENV = IPARMS( ISPEC ) + IF ( NAME(2:6).EQ.'GEQR ' ) THEN + IF (N3.EQ.2) THEN + ILAENV = IPARMS ( 2 ) + ELSE + ILAENV = IPARMS ( 1 ) + END IF + ELSE IF ( NAME(2:6).EQ.'GELQ ' ) THEN + IF (N3.EQ.2) THEN + ILAENV = IPARMS ( 2 ) + ELSE + ILAENV = IPARMS ( 1 ) + END IF + ELSE + ILAENV = IPARMS( ISPEC ) + END IF * ELSE IF( ISPEC.EQ.6 ) THEN * diff --git a/lapack-netlib/TESTING/LIN/schkaa.f b/lapack-netlib/TESTING/LIN/schkaa.f index ded959766c..bbee97b81b 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.f +++ b/lapack-netlib/TESTING/LIN/schkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SCHKAA -* +* * *> \par Purpose: * ============= @@ -51,6 +51,8 @@ *> SPT 12 List types on next line if 0 < NTYPES < 12 *> SSY 10 List types on next line if 0 < NTYPES < 10 *> SSR 10 List types on next line if 0 < NTYPES < 10 +*> SSK 10 List types on next line if 0 < NTYPES < 10 +*> SSA 10 List types on next line if 0 < NTYPES < 10 *> SSP 10 List types on next line if 0 < NTYPES < 10 *> STR 18 List types on next line if 0 < NTYPES < 18 *> STP 18 List types on next line if 0 < NTYPES < 18 @@ -94,10 +96,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -106,7 +108,7 @@ * ===================================================================== PROGRAM SCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- * April 2012 @@ -146,8 +148,8 @@ PROGRAM SCHKAA $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) REAL A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ), - $ WORK( NMAX, NMAX+MAXRHS+30 ) + $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ), + $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -158,10 +160,11 @@ PROGRAM SCHKAA EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3, $ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, - $ SCHKSY_ROOK, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, - $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, - $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, - $ ILAVER, SCHKQRT, SCHKQRTP + $ 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 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -640,8 +643,8 @@ PROGRAM SCHKAA * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * -* SR: symmetric indefinite matrices with Rook pivoting, -* with rook (bounded Bunch-Kaufman) pivoting algorithm +* SR: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -663,6 +666,60 @@ PROGRAM SCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SA: symmetric indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKSY_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL SDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * @@ -847,7 +904,7 @@ PROGRAM SCHKAA CALL SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ), $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ RWORK, RWORK( NMAX+1 ), WORK, IWORK, NOUT ) + $ RWORK, RWORK( NMAX+1 ), NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF @@ -868,7 +925,7 @@ PROGRAM SCHKAA * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -879,7 +936,40 @@ PROGRAM SCHKAA * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL SCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL SCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL SCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/lapack-netlib/TESTING/LIN/schkeq.f b/lapack-netlib/TESTING/LIN/schkeq.f index 60a3bd86ac..6381d9ddc7 100644 --- a/lapack-netlib/TESTING/LIN/schkeq.f +++ b/lapack-netlib/TESTING/LIN/schkeq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKEQ( THRESH, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NOUT * REAL THRESH * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SCHKEQ( THRESH, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NOUT diff --git a/lapack-netlib/TESTING/LIN/schkgb.f b/lapack-netlib/TESTING/LIN/schkgb.f index 3caf049134..724109b288 100644 --- a/lapack-netlib/TESTING/LIN/schkgb.f +++ b/lapack-netlib/TESTING/LIN/schkgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * REAL A( * ), AFAC( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -191,10 +191,10 @@ SUBROUTINE SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkge.f b/lapack-netlib/TESTING/LIN/schkge.f index 560f259d3e..2b8a77cc87 100644 --- a/lapack-netlib/TESTING/LIN/schkge.f +++ b/lapack-netlib/TESTING/LIN/schkge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -171,10 +171,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -185,7 +185,7 @@ SUBROUTINE SCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/schkgt.f b/lapack-netlib/TESTING/LIN/schkgt.f index 783d85f33d..c2dce7bb8c 100644 --- a/lapack-netlib/TESTING/LIN/schkgt.f +++ b/lapack-netlib/TESTING/LIN/schkgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -22,7 +22,7 @@ * REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -146,10 +146,10 @@ SUBROUTINE SCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schklq.f b/lapack-netlib/TESTING/LIN/schklq.f index 016fa2a5f6..7084a040c2 100644 --- a/lapack-netlib/TESTING/LIN/schklq.f +++ b/lapack-netlib/TESTING/LIN/schklq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -196,10 +196,10 @@ SUBROUTINE SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schklqt.f b/lapack-netlib/TESTING/LIN/schklqt.f new file mode 100644 index 0000000000..2daca557fc --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schklqt.f @@ -0,0 +1,210 @@ +*> \brief \b SCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKLQT( 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 +*> +*> SCHKLQT tests SGELQT and SGEMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKLQT( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQT, SLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRLQT( 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 ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DGELQT and DGEMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL SLQT04( M, N, NB, 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, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/schklqtp.f b/lapack-netlib/TESTING/LIN/schklqtp.f new file mode 100644 index 0000000000..183882efd7 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b SCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKLQTP( 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 +*> +*> SCHKLQTP tests STPLQT and STPMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKLQTP( 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*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQTP, DLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL SLQT05( M, N, L, NB, 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, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKQRTP +* + END diff --git a/lapack-netlib/TESTING/LIN/schkpb.f b/lapack-netlib/TESTING/LIN/schkpb.f index 09fa0611a8..257d592ec1 100644 --- a/lapack-netlib/TESTING/LIN/schkpb.f +++ b/lapack-netlib/TESTING/LIN/schkpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -172,10 +172,10 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkpo.f b/lapack-netlib/TESTING/LIN/schkpo.f index afeb176ecf..d712b3851c 100644 --- a/lapack-netlib/TESTING/LIN/schkpo.f +++ b/lapack-netlib/TESTING/LIN/schkpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -172,10 +172,10 @@ SUBROUTINE SCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkpp.f b/lapack-netlib/TESTING/LIN/schkpp.f index 9bee8ef1ee..0f34224804 100644 --- a/lapack-netlib/TESTING/LIN/schkpp.f +++ b/lapack-netlib/TESTING/LIN/schkpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -163,10 +163,10 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkps.f b/lapack-netlib/TESTING/LIN/schkps.f index b62f881a04..bae34d27a5 100644 --- a/lapack-netlib/TESTING/LIN/schkps.f +++ b/lapack-netlib/TESTING/LIN/schkps.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, * THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * REAL THRESH * INTEGER NMAX, NN, NNB, NOUT, NRANK @@ -23,7 +23,7 @@ * INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -154,10 +154,10 @@ SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL THRESH @@ -282,7 +282,7 @@ SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, * IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N, - $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, $ NOUT ) GO TO 120 END IF diff --git a/lapack-netlib/TESTING/LIN/schkpt.f b/lapack-netlib/TESTING/LIN/schkpt.f index 6f6c0fab6c..08a99ab74d 100644 --- a/lapack-netlib/TESTING/LIN/schkpt.f +++ b/lapack-netlib/TESTING/LIN/schkpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, D, E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -22,7 +22,7 @@ * REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -133,12 +133,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -146,10 +146,10 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, D, E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkq3.f b/lapack-netlib/TESTING/LIN/schkq3.f index 6a184e8d79..8c10f6285c 100644 --- a/lapack-netlib/TESTING/LIN/schkq3.f +++ b/lapack-netlib/TESTING/LIN/schkq3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * THRESH, A, COPYA, S, TAU, WORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NN, NNB, NOUT * REAL THRESH @@ -23,7 +23,7 @@ * REAL A( * ), COPYA( * ), S( * ), * $ TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -153,10 +153,10 @@ SUBROUTINE SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ THRESH, A, COPYA, S, TAU, WORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NN, NNB, NOUT diff --git a/lapack-netlib/TESTING/LIN/schkql.f b/lapack-netlib/TESTING/LIN/schkql.f index 4379673e61..817753dba9 100644 --- a/lapack-netlib/TESTING/LIN/schkql.f +++ b/lapack-netlib/TESTING/LIN/schkql.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -196,10 +196,10 @@ SUBROUTINE SCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkqr.f b/lapack-netlib/TESTING/LIN/schkqr.f index 70027a5cad..1546076004 100644 --- a/lapack-netlib/TESTING/LIN/schkqr.f +++ b/lapack-netlib/TESTING/LIN/schkqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -201,10 +201,10 @@ SUBROUTINE SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schkqrt.f b/lapack-netlib/TESTING/LIN/schkqrt.f index 0d6368af6e..9a3cc37d08 100644 --- a/lapack-netlib/TESTING/LIN/schkqrt.f +++ b/lapack-netlib/TESTING/LIN/schkqrt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -87,24 +87,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== - SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -122,7 +122,7 @@ SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * .. * .. Local Scalars .. CHARACTER*3 PATH - INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, $ MINMN * .. * .. Local Arrays .. @@ -173,7 +173,7 @@ SUBROUTINE SCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN * * Test SGEQRT and SGEMQRT -* +* CALL SQRT04( M, N, NB, RESULT ) * * Print information about the tests that did not diff --git a/lapack-netlib/TESTING/LIN/schkqrtp.f b/lapack-netlib/TESTING/LIN/schkqrtp.f index 68ba96feed..8a6915d3c5 100644 --- a/lapack-netlib/TESTING/LIN/schkqrtp.f +++ b/lapack-netlib/TESTING/LIN/schkqrtp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== - SUBROUTINE SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -172,14 +172,14 @@ SUBROUTINE SCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * MINMN = MIN( M, N ) DO L = 0, MINMN, MAX( MINMN, 1 ) -* +* * Do for each possible value of NB * DO K = 1, NNB NB = NBVAL( K ) * * Test STPQRT and STPMQRT -* +* IF( (NB.LE.N).AND.(NB.GT.0) ) THEN CALL SQRT05( M, N, L, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/schkrfp.f b/lapack-netlib/TESTING/LIN/schkrfp.f index 053949c179..75d19e3732 100644 --- a/lapack-netlib/TESTING/LIN/schkrfp.f +++ b/lapack-netlib/TESTING/LIN/schkrfp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM SCHKRFP -* +* * *> \par Purpose: * ============= @@ -47,10 +47,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -59,7 +59,7 @@ * ===================================================================== PROGRAM SCHKRFP * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -251,7 +251,7 @@ PROGRAM SCHKRFP CALL SDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + S_WORK_SLANSY ) * -* Test the convertion routines: +* Test the conversion routines: * stfttp, stpttf, stfttr, strttf, strttp and stpttr. * CALL SDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, diff --git a/lapack-netlib/TESTING/LIN/schkrq.f b/lapack-netlib/TESTING/LIN/schkrq.f index 8508774568..5c463dd1c8 100644 --- a/lapack-netlib/TESTING/LIN/schkrq.f +++ b/lapack-netlib/TESTING/LIN/schkrq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * $ B( * ), RWORK( * ), TAU( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -201,10 +201,10 @@ SUBROUTINE SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schksp.f b/lapack-netlib/TESTING/LIN/schksp.f index 782facc0ab..53cecd9e74 100644 --- a/lapack-netlib/TESTING/LIN/schksp.f +++ b/lapack-netlib/TESTING/LIN/schksp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -163,10 +163,10 @@ SUBROUTINE SCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schksy_aa.f b/lapack-netlib/TESTING/LIN/schksy_aa.f new file mode 100644 index 0000000000..35b1d9507e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schksy_aa.f @@ -0,0 +1,570 @@ +*> \brief \b SCHKSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKSY_AA tests SSYTRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @precisions fortran d -> z c +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, SLANSY + EXTERNAL DGET06, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT02, DPOT03, DPOT05, + $ DSYCON, SSYRFS, SSYT01_AA, SSYTRF_AA, + $ DSYTRI2, SSYTRS_AA, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + SRNAMT = 'SSYTRF_AA' + LWORK = MAX( 1, N*NB + N ) + CALL SSYTRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from SSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYTRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL SSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SSYTRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL SSYTRS_AA( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from SSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SSYTRS_AA', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of SCHKSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/schksy_rk.f b/lapack-netlib/TESTING/LIN/schksy_rk.f new file mode 100644 index 0000000000..22416ca4d7 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schksy_rk.f @@ -0,0 +1,846 @@ +*> \brief \b SCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SCHKSY_RK tests SSYTRF_RK, -TRI_3, -TRS_3, and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + REAL ALPHA, ANORM, CNDNUM, CONST, STEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + REAL BLOCK( 2, 2 ), SDUMMY( 1 ), RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SGET06, SLANGE, SLANSY + EXTERNAL SGET06, SLANGE, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGESVD, SGET04, + $ SLACPY, SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, + $ SSYCON_3, SSYT01_3, SSYTRF_RK, SSYTRI_3, + $ SSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SSYTRF_RK' + CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'SSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'SSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that SPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from SSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = SLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = SLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = SLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = SLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ SDUMMY, 1, SDUMMY, 1, + $ WORK, 10, INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ SDUMMY, 1, SDUMMY, 1, + $ WORK, 10, INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SSYTRS_3' + CALL SSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from SSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'SSYCON_3' + CALL SSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from DSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare to values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of SCHKSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/schksy_rook.f b/lapack-netlib/TESTING/LIN/schksy_rook.f index fdcd154cf8..0d9e58fba4 100644 --- a/lapack-netlib/TESTING/LIN/schksy_rook.f +++ b/lapack-netlib/TESTING/LIN/schksy_rook.f @@ -162,7 +162,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -171,10 +171,10 @@ SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -205,15 +205,14 @@ SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, - $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, - $ NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, $ SING_MIN, RCOND, RCONDC, STEMP * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) - INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) REAL BLOCK( 2, 2 ), RESULT( NTESTS ), SDUMMY( 1 ) * .. * .. External Functions .. diff --git a/lapack-netlib/TESTING/LIN/schktb.f b/lapack-netlib/TESTING/LIN/schktb.f index 0f417f9524..deb83bf0a5 100644 --- a/lapack-netlib/TESTING/LIN/schktb.f +++ b/lapack-netlib/TESTING/LIN/schktb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * REAL AB( * ), AINV( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -155,10 +155,10 @@ SUBROUTINE SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schktp.f b/lapack-netlib/TESTING/LIN/schktp.f index 8bfdedd03e..6f3a96f7e8 100644 --- a/lapack-netlib/TESTING/LIN/schktp.f +++ b/lapack-netlib/TESTING/LIN/schktp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * REAL AINVP( * ), AP( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -157,10 +157,10 @@ SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schktr.f b/lapack-netlib/TESTING/LIN/schktr.f index 0b12baa70c..a9737e35cd 100644 --- a/lapack-netlib/TESTING/LIN/schktr.f +++ b/lapack-netlib/TESTING/LIN/schktr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, * WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AINV( * ), B( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -167,10 +167,10 @@ SUBROUTINE SCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, $ WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/schktsqr.f b/lapack-netlib/TESTING/LIN/schktsqr.f new file mode 100644 index 0000000000..2bed434a8c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b SCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKTSQR( 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 +*> +*> SCHKTSQR tests SGETSQR and SORMTSQR. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKTSQR( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRTSQR, + $ STSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL SERRTSQR( 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test SGEQR and SGEMQR +* + CALL STSQR01('TS', M, N, MB, NB, 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, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test SGEQR and SGEMQR +* + CALL STSQR01('SW', M, N, MB, NB, 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 = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of SCHKQRT +* + END diff --git a/lapack-netlib/TESTING/LIN/schktz.f b/lapack-netlib/TESTING/LIN/schktz.f index 74406453bd..92d671c871 100644 --- a/lapack-netlib/TESTING/LIN/schktz.f +++ b/lapack-netlib/TESTING/LIN/schktz.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, * COPYA, S, TAU, WORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NOUT @@ -22,7 +22,7 @@ * REAL A( * ), COPYA( * ), S( * ), * $ TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -119,12 +119,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -132,10 +132,10 @@ SUBROUTINE SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, TAU, WORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvgb.f b/lapack-netlib/TESTING/LIN/sdrvgb.f index 1d9bbadd31..fc106ea515 100644 --- a/lapack-netlib/TESTING/LIN/sdrvgb.f +++ b/lapack-netlib/TESTING/LIN/sdrvgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ RWORK( * ), S( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -172,10 +172,10 @@ SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvgbx.f b/lapack-netlib/TESTING/LIN/sdrvgbx.f index d291f5b5f3..45adc39dba 100644 --- a/lapack-netlib/TESTING/LIN/sdrvgbx.f +++ b/lapack-netlib/TESTING/LIN/sdrvgbx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ RWORK( * ), S( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -175,10 +175,10 @@ SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvge.f b/lapack-netlib/TESTING/LIN/sdrvge.f index 8627e23680..8c08cddbaa 100644 --- a/lapack-netlib/TESTING/LIN/sdrvge.f +++ b/lapack-netlib/TESTING/LIN/sdrvge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -164,10 +164,10 @@ SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvgex.f b/lapack-netlib/TESTING/LIN/sdrvgex.f index cf8d07031a..1cc9f3c9ff 100644 --- a/lapack-netlib/TESTING/LIN/sdrvgex.f +++ b/lapack-netlib/TESTING/LIN/sdrvgex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,10 +153,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -167,7 +167,7 @@ SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/sdrvgt.f b/lapack-netlib/TESTING/LIN/sdrvgt.f index 3eee04841c..f939780217 100644 --- a/lapack-netlib/TESTING/LIN/sdrvgt.f +++ b/lapack-netlib/TESTING/LIN/sdrvgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, * B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -22,7 +22,7 @@ * REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -139,10 +139,10 @@ SUBROUTINE SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, $ B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvls.f b/lapack-netlib/TESTING/LIN/sdrvls.f index 2d4afa5235..c408a9bf06 100644 --- a/lapack-netlib/TESTING/LIN/sdrvls.f +++ b/lapack-netlib/TESTING/LIN/sdrvls.f @@ -2,16 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, -* COPYB, C, S, COPYS, WORK, IWORK, NOUT ) -* +* COPYB, C, S, COPYS, NOUT ) +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -19,19 +19,19 @@ * .. * .. Array Arguments .. * LOGICAL DOTYPE( * ) -* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), * $ NVAL( * ), NXVAL( * ) * REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), -* $ COPYS( * ), S( * ), WORK( * ) +* $ COPYS( * ), S( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSY +*> SDRVLS tests the least squares driver routines SGELS, SGETSLS, SGELSS, SGELSY, *> and SGELSD. *> \endverbatim * @@ -46,14 +46,14 @@ *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. *> The matrix of type j is generated as follows: *> j=1: A = U*D*V where U and V are random orthogonal matrices -*> and D has random entries (> 0.1) taken from a uniform +*> and D has random entries (> 0.1) taken from a uniform *> distribution (0,1). A is full rank. *> j=2: The same of 1, but A is scaled up. *> j=3: The same of 1, but A is scaled down. *> j=4: A = U*D*V where U and V are random orthogonal matrices *> and D has 3*min(M,N)/4 random entries (> 0.1) taken *> from a uniform distribution (0,1) and the remaining -*> entries set to 0. A is rank-deficient. +*> entries set to 0. A is rank-deficient. *> j=5: The same of 4, but A is scaled up. *> j=6: The same of 5, but A is scaled down. *> \endverbatim @@ -169,17 +169,6 @@ *> (min(MMAX,NMAX)) *> \endverbatim *> -*> \param[out] WORK -*> \verbatim -*> WORK is REAL array, -*> dimension (MMAX*NMAX + 4*NMAX + MMAX). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (15*NMAX) -*> \endverbatim -*> *> \param[in] NOUT *> \verbatim *> NOUT is INTEGER @@ -189,24 +178,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, - $ COPYB, C, S, COPYS, WORK, IWORK, NOUT ) + $ COPYB, C, S, COPYS, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -215,17 +204,17 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) - INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), + INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), $ NVAL( * ), NXVAL( * ) REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), - $ COPYS( * ), S( * ), WORK( * ) + $ COPYS( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) REAL ONE, TWO, ZERO @@ -234,15 +223,22 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, - $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, - $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK + INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK, + $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, + $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, + $ MMAX, NMAX, NSMAX, LIWORK, + $ LWORK_SGELS, LWORK_SGETSLS, LWORK_SGELSS, + $ LWORK_SGELSY, LWORK_SGELSD REAL EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. - INTEGER ISEED( 4 ), ISEEDY( 4 ) - REAL RESULT( NTESTS ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY + REAL RESULT( NTESTS ), WORKQUERY +* .. +* .. Allocatable Arrays .. + REAL, ALLOCATABLE :: WORK (:) + INTEGER, ALLOCATABLE :: IWORK (:) * .. * .. External Functions .. REAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17 @@ -273,7 +269,7 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * * Initialize constants and the random number seed. * - PATH( 1: 1 ) = 'Single precision' + PATH( 1: 1 ) = 'SINGLE PRECISION' PATH( 2: 3 ) = 'LS' NRUN = 0 NFAIL = 0 @@ -299,6 +295,73 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO ) $ CALL ALAHD( NOUT, PATH ) INFOT = 0 + CALL XLAENV( 2, 2 ) + CALL XLAENV( 9, SMLSIZ ) +* +* Compute maximal workspace needed for all routines +* + NMAX = 0 + MMAX = 0 + NSMAX = 0 + DO I = 1, NM + IF ( MVAL( I ).GT.MMAX ) THEN + MMAX = MVAL( I ) + END IF + ENDDO + DO I = 1, NN + IF ( NVAL( I ).GT.NMAX ) THEN + NMAX = NVAL( I ) + END IF + ENDDO + DO I = 1, NNS + IF ( NSVAL( I ).GT.NSMAX ) THEN + NSMAX = NSVAL( I ) + END IF + ENDDO + M = MMAX + N = NMAX + NRHS = NSMAX + LDA = MAX( 1, M ) + LDB = MAX( 1, M, N ) + MNMIN = MAX( MIN( M, N ), 1 ) +* +* Compute workspace needed for routines +* SQRT14, SQRT17 (two side cases), SQRT15 and SQRT12 +* + LWORK = MAX( ( M+N )*NRHS, + $ ( N+NRHS )*( M+2 ), ( M+NRHS )*( N+2 ), + $ MAX( M+MNMIN, NRHS*MNMIN,2*N+M ), + $ MAX( M*N+4*MNMIN+MAX(M,N), M*N+2*MNMIN+4*N ) ) +* +* Compute workspace needed for SGELS + CALL SGELS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_SGELS = INT ( WORKQUERY ) +* Compute workspace needed for SGETSLS + CALL SGETSLS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_SGETSLS = INT( WORKQUERY ) +* Compute workspace needed for SGELSY + CALL SGELSY( M, N, NRHS, A, LDA, B, LDB, IWORKQUERY, + $ RCOND, CRANK, WORKQUERY, -1, INFO ) + LWORK_SGELSY = INT( WORKQUERY ) +* Compute workspace needed for SGELSS + CALL SGELSS( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1 , INFO ) + LWORK_SGELSS = INT( WORKQUERY ) +* Compute workspace needed for SGELSD + CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1, IWORKQUERY, INFO ) + LWORK_SGELSD = INT( WORKQUERY ) +* Compute LIWORK workspace needed for SGELSY and SGELSD + LIWORK = MAX( 1, N, IWORKQUERY ) +* Compute LWORK workspace needed for all functions + LWORK = MAX( 1, LWORK, LWORK_SGELS, LWORK_SGETSLS, LWORK_SGELSY, + $ LWORK_SGELSS, LWORK_SGELSD ) + LWLSY = LWORK +* + ALLOCATE( WORK( LWORK ) ) + ALLOCATE( IWORK( LIWORK ) ) * DO 150 IM = 1, NM M = MVAL( IM ) @@ -306,16 +369,12 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * DO 140 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) * DO 130 INS = 1, NNS NRHS = NSVAL( INS ) - NLVL = MAX( INT( LOG( MAX( ONE, REAL( MNMIN ) ) / - $ REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 ) - LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+ - $ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 ) * DO 120 IRANK = 1, 2 DO 110 ISCALE = 1, 3 @@ -424,6 +483,110 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test SGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL SQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'T' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL SLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL SSCAL( NCOLS*NRHS, + $ ONE / REAL( NCOLS ), WORK, + $ 1 ) + END IF + CALL SGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, ONE, COPYA, LDA, + $ WORK, LDWORK, ZERO, B, LDB ) + CALL SLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL SLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL SLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'SGETSLS ' + CALL SGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL SLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL SQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = SQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = SQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -456,11 +619,6 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, DO 70 J = 1, N IWORK( J ) = 0 70 CONTINUE -* -* Set LWLSY to the adequate value. -* - LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ), - $ 2*MNMIN+NB*NRHS ) * CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA ) CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B, @@ -626,7 +784,7 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * Print information about the tests that did not * pass the threshold. * - DO 90 K = 3, NTESTS + DO 90 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -635,7 +793,7 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NFAIL = NFAIL + 1 END IF 90 CONTINUE - NRUN = NRUN + 12 + NRUN = NRUN + 12 * 100 CONTINUE 110 CONTINUE @@ -652,6 +810,12 @@ SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) +* + DEALLOCATE( WORK ) + DEALLOCATE( IWORK ) RETURN * * End of SDRVLS diff --git a/lapack-netlib/TESTING/LIN/sdrvpb.f b/lapack-netlib/TESTING/LIN/sdrvpb.f index 69c48a4737..ba018bc6d5 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpb.f +++ b/lapack-netlib/TESTING/LIN/sdrvpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -164,10 +164,10 @@ SUBROUTINE SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvpo.f b/lapack-netlib/TESTING/LIN/sdrvpo.f index 12ae86e6a4..d8d90cc3b5 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpo.f +++ b/lapack-netlib/TESTING/LIN/sdrvpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -164,10 +164,10 @@ SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvpox.f b/lapack-netlib/TESTING/LIN/sdrvpox.f index 565b6c3820..23fc87d3c7 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpox.f +++ b/lapack-netlib/TESTING/LIN/sdrvpox.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup single_lin * @@ -167,10 +167,10 @@ SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvpp.f b/lapack-netlib/TESTING/LIN/sdrvpp.f index 43b663c036..33b7d0d209 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpp.f +++ b/lapack-netlib/TESTING/LIN/sdrvpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), * $ X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -167,10 +167,10 @@ SUBROUTINE SDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvpt.f b/lapack-netlib/TESTING/LIN/sdrvpt.f index a906ddc23a..e2ca6bcb8b 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpt.f +++ b/lapack-netlib/TESTING/LIN/sdrvpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, * E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -22,7 +22,7 @@ * REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -140,10 +140,10 @@ SUBROUTINE SDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, $ E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvrf1.f b/lapack-netlib/TESTING/LIN/sdrvrf1.f index 60c1649bed..4aa9782042 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrf1.f +++ b/lapack-netlib/TESTING/LIN/sdrvrf1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * REAL THRESH @@ -18,7 +18,7 @@ * INTEGER NVAL( NN ) * REAL A( LDA, * ), ARF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -82,22 +82,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -161,17 +161,17 @@ SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) EPS = SLAMCH( 'Precision' ) SMALL = SLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL - SMALL = SMALL * LDA * LDA + SMALL = SMALL * LDA * LDA LARGE = LARGE / LDA / LDA * DO 130 IIN = 1, NN * N = NVAL( IIN ) * - DO 120 IIT = 1, 3 + DO 120 IIT = 1, 3 * Nothing to do for N=0 IF ( N .EQ. 0 ) EXIT - + * Quick Return if possible IF ( N .EQ. 0 ) EXIT * @@ -244,7 +244,7 @@ SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'SLANSF', + WRITE( NOUT, FMT = 9997 ) 'SLANSF', + N, IIT, UPLO, CFORM, NORM, RESULT(1) NFAIL = NFAIL + 1 END IF diff --git a/lapack-netlib/TESTING/LIN/sdrvrf2.f b/lapack-netlib/TESTING/LIN/sdrvrf2.f index 685681bbb7..350f47e14d 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrf2.f +++ b/lapack-netlib/TESTING/LIN/sdrvrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * .. @@ -17,14 +17,14 @@ * INTEGER NVAL( NN ) * REAL A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> SDRVRF2 tests the LAPACK RFP convertion routines. +*> SDRVRF2 tests the LAPACK RFP conversion routines. *> \endverbatim * * Arguments: @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -248,14 +248,14 @@ SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) WRITE( NOUT, FMT = 9996 ) NERRS, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP conversion', + ' routines ***') - 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + 9998 FORMAT( 1X, ' Error in RFP,conversion routines N=',I5, + ' UPLO=''', A1, ''', FORM =''',A1,'''') - 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed ( ', + 9997 FORMAT( 1X, 'All tests for the RFP conversion routines passed ( ', + I5,' tests run)') - 9996 FORMAT( 1X, 'RFP convertion routines: ',I5,' out of ',I5, - + ' error message recorded') + 9996 FORMAT( 1X, 'RFP conversion routines: ',I5,' out of ',I5, + + ' error message recorded') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/sdrvrf3.f b/lapack-netlib/TESTING/LIN/sdrvrf3.f index 3aa628606d..33ac108420 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/sdrvrf3.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * REAL THRESH @@ -21,7 +21,7 @@ * + B2( LDA, * ), S_WORK_SGEQRF( * ), * + S_WORK_SLANGE( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -118,10 +118,10 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -253,12 +253,12 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, END IF * * Generate A our NA--by--NA triangular -* matrix. +* matrix. * Our test is based on forward error so we * do want A to be well conditionned! To get * a well-conditionned triangular matrix, we * take the R factor of the QR/LQ factorization -* of a random matrix. +* of a random matrix. * DO J = 1, NA DO I = 1, NA @@ -336,7 +336,7 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'STFSM', + WRITE( NOUT, FMT = 9997 ) 'STFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, + N, RESULT(1) NFAIL = NFAIL + 1 @@ -359,7 +359,7 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, FMT = 9995 ) 'STFSM', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing STFSM + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing STFSM + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', diff --git a/lapack-netlib/TESTING/LIN/sdrvrf4.f b/lapack-netlib/TESTING/LIN/sdrvrf4.f index 23e28d3cb3..d811d049b5 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrf4.f +++ b/lapack-netlib/TESTING/LIN/sdrvrf4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * + LDA, S_WORK_SLANGE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDC, NN, NOUT * REAL THRESH @@ -20,7 +20,7 @@ * REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *), * + CRF( * ), S_WORK_SLANGE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -105,12 +105,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -118,10 +118,10 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + LDA, S_WORK_SLANGE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDC, NN, NOUT @@ -242,12 +242,12 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, NORMA = SLANGE( 'I', N, K, A, LDA, + S_WORK_SLANGE ) * - + ELSE * * In this case we are TRANS, so A is K-by-N * - DO J = 1,N + DO J = 1,N DO I = 1, K A( I, J) = SLARND( 2, ISEED ) END DO @@ -258,7 +258,7 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * END IF * -* Generate C1 our N--by--N symmetric matrix. +* Generate C1 our N--by--N symmetric matrix. * Make sure C2 has the same upper/lower part, * (the one that we do not touch), so * copy the initial C1 in C2 in it. @@ -313,7 +313,7 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * RESULT(1) = SLANGE( 'I', N, N, C1, LDC, + S_WORK_SLANGE ) - RESULT(1) = RESULT(1) + RESULT(1) = RESULT(1) + / MAX( ABS( ALPHA ) * NORMA + + ABS( BETA ) , ONE ) + / MAX( N , 1 ) / EPS @@ -323,7 +323,7 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'SSFRK', + WRITE( NOUT, FMT = 9997 ) 'SSFRK', + CFORM, UPLO, TRANS, N, K, RESULT(1) NFAIL = NFAIL + 1 END IF @@ -343,7 +343,7 @@ SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, FMT = 9995 ) 'SSFRK', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing SSFRK + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing SSFRK + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, diff --git a/lapack-netlib/TESTING/LIN/sdrvrfp.f b/lapack-netlib/TESTING/LIN/sdrvrfp.f index c79b5a2c0f..4b022bcfb6 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/sdrvrfp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -14,7 +14,7 @@ * + S_WORK_SLATMS, S_WORK_SPOT01, S_TEMP_SPOT02, * + S_TEMP_SPOT03, S_WORK_SLANSY, * + S_WORK_SPOT02, S_WORK_SPOT03 ) -* +* * .. Scalar Arguments .. * INTEGER NN, NNS, NNT, NOUT * REAL THRESH @@ -39,7 +39,7 @@ * REAL S_WORK_SPOT02( * ) * REAL S_WORK_SPOT03( * ) * .. -* +* * *> \par Purpose: * ============= @@ -52,11 +52,11 @@ *> This testing routine follow the same tests as DDRVPO (test for the full *> format Symmetric Positive Definite solver). *> -*> The tests are performed in Full Format, convertion back and forth from +*> The tests are performed in Full Format, conversion back and forth from *> full format to RFP format are performed using the routines STRTTF and *> STFTTR. *> -*> First, a specific matrix A of size N is created. There is nine types of +*> First, a specific matrix A of size N is created. There is nine types of *> different matrixes possible. *> 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) *> 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS @@ -226,12 +226,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup single_lin * @@ -243,10 +243,10 @@ SUBROUTINE SDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + S_TEMP_SPOT03, S_WORK_SLANSY, + S_WORK_SPOT02, S_WORK_SPOT03 ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -514,7 +514,7 @@ SUBROUTINE SDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, * * Form the inverse and compute the residual. * - IF(MOD(N,2).EQ.0)THEN + IF(MOD(N,2).EQ.0)THEN CALL SLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + N+1 ) ELSE @@ -549,7 +549,7 @@ SUBROUTINE SDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + RESULT( 3 ) ) * * Check solution from generated exact solution. - + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + RESULT( 4 ) ) NT = 4 diff --git a/lapack-netlib/TESTING/LIN/sdrvsp.f b/lapack-netlib/TESTING/LIN/sdrvsp.f index 6792dd9e0d..12110cfa94 100644 --- a/lapack-netlib/TESTING/LIN/sdrvsp.f +++ b/lapack-netlib/TESTING/LIN/sdrvsp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -156,10 +156,10 @@ SUBROUTINE SDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvsy_aa.f b/lapack-netlib/TESTING/LIN/sdrvsy_aa.f new file mode 100644 index 0000000000..8e5686f827 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/sdrvsy_aa.f @@ -0,0 +1,474 @@ +*> \brief \b SDRVSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVSY_AA tests the driver routine SSYSV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, SLANSY + EXTERNAL DGET06, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, DPOT05, + $ SSYSV_AA, SSYT01_AA, SSYTRF_AA, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with SLATB4 and generate a test matrix +* with SLATMS. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SSYSV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using SSYSV_AA. +* + SRNAMT = 'SSYSV_AA' + CALL SSYSV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from SSYSV_AA . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYSV_AA ', INFO, K, + $ UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'SSYSV_AA ', + $ UPLO, N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of SDRVSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/sdrvsy_rk.f b/lapack-netlib/TESTING/LIN/sdrvsy_rk.f new file mode 100644 index 0000000000..83cb5dda08 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/sdrvsy_rk.f @@ -0,0 +1,531 @@ +*> \brief \b SDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SDRVSY_RK tests the driver routines SSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLANSY + EXTERNAL SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT02, SSYSV_RK, + $ SSYT01_3, SSYTRF_RK, SSYTRI_3, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* SSYSV_RK. +* + SRNAMT = 'SSYSV_RK' + CALL SSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from SSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'SSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of SDRVSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/sdrvsyx.f b/lapack-netlib/TESTING/LIN/sdrvsyx.f index b3fc76f5cb..e314da2e0f 100644 --- a/lapack-netlib/TESTING/LIN/sdrvsyx.f +++ b/lapack-netlib/TESTING/LIN/sdrvsyx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -142,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -156,10 +156,10 @@ SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sebchvxx.f b/lapack-netlib/TESTING/LIN/sebchvxx.f index 9fa72df208..8a8e086654 100644 --- a/lapack-netlib/TESTING/LIN/sebchvxx.f +++ b/lapack-netlib/TESTING/LIN/sebchvxx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * diff --git a/lapack-netlib/TESTING/LIN/serrge.f b/lapack-netlib/TESTING/LIN/serrge.f index ff200a4b8a..d4b1f701f4 100644 --- a/lapack-netlib/TESTING/LIN/serrge.f +++ b/lapack-netlib/TESTING/LIN/serrge.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrgex.f b/lapack-netlib/TESTING/LIN/serrgex.f index e6afd3fcdb..ebeceae860 100644 --- a/lapack-netlib/TESTING/LIN/serrgex.f +++ b/lapack-netlib/TESTING/LIN/serrgex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrgt.f b/lapack-netlib/TESTING/LIN/serrgt.f index 65e0404c8a..0fc54cab9c 100644 --- a/lapack-netlib/TESTING/LIN/serrgt.f +++ b/lapack-netlib/TESTING/LIN/serrgt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRGT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRGT( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrlq.f b/lapack-netlib/TESTING/LIN/serrlq.f index 931dd7c6c9..e184f006f5 100644 --- a/lapack-netlib/TESTING/LIN/serrlq.f +++ b/lapack-netlib/TESTING/LIN/serrlq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRLQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRLQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrlqt.f b/lapack-netlib/TESTING/LIN/serrlqt.f new file mode 100644 index 0000000000..6144ec625d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/serrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b SERRLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRLQT tests the error exits for the DOUBLE PRECISION routines +*> that use the LQT decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRLQT( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGELQT3, SGELQT, + $ SGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* SGELQT +* + SRNAMT = 'SGELQT' + INFOT = 1 + CALL SGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'SGELQT', INFOT, NOUT, LERR, OK ) +* +* SGELQT3 +* + SRNAMT = 'SGELQT3' + INFOT = 1 + CALL SGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'SGELQT3', INFOT, NOUT, LERR, OK ) +* +* SGEMLQT +* + SRNAMT = 'SGEMLQT' + INFOT = 1 + CALL SGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'SGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/serrlqtp.f b/lapack-netlib/TESTING/LIN/serrlqtp.f new file mode 100644 index 0000000000..4d0437d4fb --- /dev/null +++ b/lapack-netlib/TESTING/LIN/serrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b DERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRLQTP tests the error exits for the REAL routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRLQTP( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, STPLQT2, STPLQT, + $ STPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* STPLQT +* + SRNAMT = 'STPLQT' + INFOT = 1 + CALL STPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL STPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL STPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL STPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'STPLQT', INFOT, NOUT, LERR, OK ) +* +* STPLQT2 +* + SRNAMT = 'STPLQT2' + INFOT = 1 + CALL STPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL STPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL STPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'STPLQT2', INFOT, NOUT, LERR, OK ) +* +* STPMLQT +* + SRNAMT = 'STPMLQT' + INFOT = 1 + CALL STPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL STPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL STPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL STPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL STPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL STPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'STPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/serrls.f b/lapack-netlib/TESTING/LIN/serrls.f index fe3ab0c325..f7912e1fbb 100644 --- a/lapack-netlib/TESTING/LIN/serrls.f +++ b/lapack-netlib/TESTING/LIN/serrls.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRLS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRLS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrpo.f b/lapack-netlib/TESTING/LIN/serrpo.f index 91f7b683ca..8061514d8b 100644 --- a/lapack-netlib/TESTING/LIN/serrpo.f +++ b/lapack-netlib/TESTING/LIN/serrpo.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrpox.f b/lapack-netlib/TESTING/LIN/serrpox.f index 88f34c0f60..123f5b70b1 100644 --- a/lapack-netlib/TESTING/LIN/serrpox.f +++ b/lapack-netlib/TESTING/LIN/serrpox.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrps.f b/lapack-netlib/TESTING/LIN/serrps.f index ea05b82476..dc9cb29f52 100644 --- a/lapack-netlib/TESTING/LIN/serrps.f +++ b/lapack-netlib/TESTING/LIN/serrps.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRPS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRPS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/serrql.f b/lapack-netlib/TESTING/LIN/serrql.f index 1ffdb93f59..1b094be6ea 100644 --- a/lapack-netlib/TESTING/LIN/serrql.f +++ b/lapack-netlib/TESTING/LIN/serrql.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRQL( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRQL( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrqp.f b/lapack-netlib/TESTING/LIN/serrqp.f index 30499202b5..596f275f30 100644 --- a/lapack-netlib/TESTING/LIN/serrqp.f +++ b/lapack-netlib/TESTING/LIN/serrqp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRQP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRQP( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrqr.f b/lapack-netlib/TESTING/LIN/serrqr.f index 93709123d5..3339a85ad8 100644 --- a/lapack-netlib/TESTING/LIN/serrqr.f +++ b/lapack-netlib/TESTING/LIN/serrqr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRQR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRQR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrqrt.f b/lapack-netlib/TESTING/LIN/serrqrt.f index c8650d3560..1df2c25c93 100644 --- a/lapack-netlib/TESTING/LIN/serrqrt.f +++ b/lapack-netlib/TESTING/LIN/serrqrt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRQRT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -56,10 +56,10 @@ SUBROUTINE SERRQRT( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE SERRQRT( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SGEQRT2, SGEQRT3, SGEQRT, - $ SGEMQRT + $ SGEMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/LIN/serrqrtp.f b/lapack-netlib/TESTING/LIN/serrqrtp.f index 2550cae799..211643b9b5 100644 --- a/lapack-netlib/TESTING/LIN/serrqrtp.f +++ b/lapack-netlib/TESTING/LIN/serrqrtp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRQRTP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -56,10 +56,10 @@ SUBROUTINE SERRQRTP( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE SERRQRTP( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, STPQRT2, STPQRT, - $ STPMQRT + $ STPMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,50 +171,50 @@ SUBROUTINE SERRQRTP( PATH, NUNIT ) * SRNAMT = 'STPMQRT' INFOT = 1 - CALL STPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL STPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL STPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL STPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL STPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) INFOT = 6 - CALL STPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL STPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL STPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL STPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL STPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL STPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + CALL STPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL STPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + CALL STPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL STPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + CALL STPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, $ W, INFO ) CALL CHKXER( 'STPMQRT', INFOT, NOUT, LERR, OK ) * diff --git a/lapack-netlib/TESTING/LIN/serrrfp.f b/lapack-netlib/TESTING/LIN/serrrfp.f index 98159bbd5a..1956cca4be 100644 --- a/lapack-netlib/TESTING/LIN/serrrfp.f +++ b/lapack-netlib/TESTING/LIN/serrrfp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRRFP( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -40,22 +40,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRRFP( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/serrrq.f b/lapack-netlib/TESTING/LIN/serrrq.f index 46b01b2c4d..c2cec4328d 100644 --- a/lapack-netlib/TESTING/LIN/serrrq.f +++ b/lapack-netlib/TESTING/LIN/serrrq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRRQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRRQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrsy.f b/lapack-netlib/TESTING/LIN/serrsy.f index 7e0829eb7b..ce6975d1e2 100644 --- a/lapack-netlib/TESTING/LIN/serrsy.f +++ b/lapack-netlib/TESTING/LIN/serrsy.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -79,17 +79,21 @@ SUBROUTINE SERRSY( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ) + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, SSPCON, SSYCON_ROOK, SSPRFS, - $ SSPTRF, SSPTRI, SSPTRS, SSYCON, SSYRFS, SSYTF2, - $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI, - $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK + EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, + $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS, + $ SSYTF2_RK, SSYTF2_ROOK, SSYTRF, SSYTRF_RK, + $ SSYTRF_ROOK, SSYTRI, SSYTF2, SSYTRI_3, + $ SSYTRI_3X, SSYTRI_ROOK, SSYTRF_AA, SSYTRI2, + $ SYTRI2X, SSYTRS, SSYTRS_3, SSYTRS_ROOK, + $ SSYTRS_AA * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -116,11 +120,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J IW( J ) = J 20 CONTINUE @@ -146,6 +151,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 4 CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) * * SSYTF2 * @@ -186,6 +197,19 @@ SUBROUTINE SERRSY( PATH, NUNIT ) CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) * +* SSYTRI2X +* + SRNAMT = 'SSYTRI2X' + INFOT = 1 + CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) +* * SSYTRS * SRNAMT = 'SSYTRS' @@ -271,6 +295,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 4 CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * SSYTF2_ROOK * @@ -332,13 +362,175 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 6 CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN * * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* SSYTRF_RK +* + SRNAMT = 'SSYTRF_RK' + INFOT = 1 + CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_RK +* + SRNAMT = 'SSYTF2_RK' + INFOT = 1 + CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3 +* + SRNAMT = 'SSYTRI_3' + INFOT = 1 + CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3X +* + SRNAMT = 'SSYTRI_3X' + INFOT = 1 + CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_3 +* + SRNAMT = 'SSYTRS_3' + INFOT = 1 + CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* SSYCON_3 +* + SRNAMT = 'SSYCON_3' + INFOT = 1 + CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with Aasen's algorithm. +* +* SSYTRF_AA +* + SRNAMT = 'SSYTRF_AA' + INFOT = 1 + CALL SSYTRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_AA', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_AA +* + SRNAMT = 'SSYTRS_AA' + INFOT = 1 + CALL SSYTRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRS_AA( 'U', 0, 1, A, 2, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRS_AA( 'U', 0, 1, A, 2, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * SSPTRF * SRNAMT = 'SSPTRF' diff --git a/lapack-netlib/TESTING/LIN/serrsyx.f b/lapack-netlib/TESTING/LIN/serrsyx.f index e2d41d1438..9249f104fc 100644 --- a/lapack-netlib/TESTING/LIN/serrsyx.f +++ b/lapack-netlib/TESTING/LIN/serrsyx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,8 +83,8 @@ SUBROUTINE SERRSY( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ), - $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) * .. * .. External Functions .. @@ -93,10 +93,11 @@ SUBROUTINE SERRSY( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, - $ SSPTRS, SSYCON, SSYCON_ROOK,SSYRFS, SSYTF2, - $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI, - $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK, - $ SSYRFSX + $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS, + $ SSYTF2, SSYTF2_RK, SSYTF2_ROOK, SSYTRF, + $ SSYTRF_RK, SSYTRF_ROOK, SSYTRI, SSYTRI_3, + $ SSYTRI_3X, SSYTRI_ROOK, SSYTRI2, SSYTRI2X, + $ SSYTRS, SSYTRS_3, SSYTRS_ROOK, SSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -123,12 +124,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J IW( J ) = J 20 CONTINUE @@ -154,6 +155,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 4 CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) * * SSYTF2 * @@ -194,6 +201,19 @@ SUBROUTINE SERRSY( PATH, NUNIT ) CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK ) * +* SSYTRI2X +* + SRNAMT = 'SSYTRI2X' + INFOT = 1 + CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) +* * SSYTRS * SRNAMT = 'SSYTRS' @@ -326,6 +346,12 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 4 CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * SSYTF2_ROOK * @@ -387,13 +413,126 @@ SUBROUTINE SERRSY( PATH, NUNIT ) INFOT = 6 CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN * * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* SSYTRF_RK +* + SRNAMT = 'SSYTRF_RK' + INFOT = 1 + CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_RK +* + SRNAMT = 'SSYTF2_RK' + INFOT = 1 + CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3 +* + SRNAMT = 'SSYTRI_3' + INFOT = 1 + CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3X +* + SRNAMT = 'SSYTRI_3X' + INFOT = 1 + CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_3 +* + SRNAMT = 'SSYTRS_3' + INFOT = 1 + CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* SSYCON_3 +* + SRNAMT = 'SSYCON_3' + INFOT = 1 + CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * SSPTRF * SRNAMT = 'SSPTRF' diff --git a/lapack-netlib/TESTING/LIN/serrtr.f b/lapack-netlib/TESTING/LIN/serrtr.f index 961bd98450..0bc4a897c8 100644 --- a/lapack-netlib/TESTING/LIN/serrtr.f +++ b/lapack-netlib/TESTING/LIN/serrtr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRTR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRTR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrtsqr.f b/lapack-netlib/TESTING/LIN/serrtsqr.f new file mode 100644 index 0000000000..f00f3e14b3 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/serrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b DERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRTSQR tests the error exits for the REAL routines +*> that use the TSQR decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRTSQR( PATH, NUNIT ) + 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 .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGEQR, + $ SGEMQR, SGELQ, SGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / REAL( I+J ) + C( I, J ) = 1.D0 / REAL( I+J ) + T( I, J ) = 1.D0 / REAL( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* SGEQR +* + SRNAMT = 'SGEQR' + INFOT = 1 + CALL SGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEQR( 3, 2, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'SGEQR', INFOT, NOUT, LERR, OK ) +* +* SGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'SGEMQR' + NB=1 + INFOT = 1 + CALL SGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMQR( 'R', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SGEMQR( 'L', 'N', 2, 1, 1, A, 2, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'SGEMQR', INFOT, NOUT, LERR, OK ) +* +* SGELQ +* + SRNAMT = 'SGELQ' + INFOT = 1 + CALL SGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGELQ( 2, 3, A, 3, TAU, 7, W, 0, INFO ) + CALL CHKXER( 'SGELQ', INFOT, NOUT, LERR, OK ) +* +* SGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'SGEMLQ' + NB=1 + INFOT = 1 + CALL SGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'SGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRTSQR +* + END diff --git a/lapack-netlib/TESTING/LIN/serrtz.f b/lapack-netlib/TESTING/LIN/serrtz.f index 2e328f1357..f5897642b1 100644 --- a/lapack-netlib/TESTING/LIN/serrtz.f +++ b/lapack-netlib/TESTING/LIN/serrtz.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRTZ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRTZ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/serrvx.f b/lapack-netlib/TESTING/LIN/serrvx.f index c09ca39982..3317e840a8 100644 --- a/lapack-netlib/TESTING/LIN/serrvx.f +++ b/lapack-netlib/TESTING/LIN/serrvx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- -* April 2012 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ SUBROUTINE SERRVX( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -91,7 +91,7 @@ SUBROUTINE SERRVX( PATH, NUNIT ) EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSV_ROOK, SSYSVX + $ SSYSV_AA, SSYSV_RK, SSYSV_ROOK, SSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,13 +118,14 @@ SUBROUTINE SERRVX( PATH, NUNIT ) A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -586,6 +587,12 @@ SUBROUTINE SERRVX( PATH, NUNIT ) INFOT = 8 CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) * * SSYSVX * @@ -626,6 +633,7 @@ SUBROUTINE SERRVX( PATH, NUNIT ) CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK ) +* * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * @@ -644,6 +652,65 @@ SUBROUTINE SERRVX( PATH, NUNIT ) INFOT = 8 CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'SSYSV_RK' + INFOT = 1 + CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SSYSV_AA +* + SRNAMT = 'SSYSV_AA' + INFOT = 1 + CALL SSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/serrvxx.f b/lapack-netlib/TESTING/LIN/serrvxx.f index a05a8ab626..4d2cd9f38d 100644 --- a/lapack-netlib/TESTING/LIN/serrvxx.f +++ b/lapack-netlib/TESTING/LIN/serrvxx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,9 +82,10 @@ SUBROUTINE SERRVX( PATH, NUNIT ) * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), - $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,8 +95,8 @@ SUBROUTINE SERRVX( PATH, NUNIT ) EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, SPOSVXX, - $ SGBSVXX + $ SSYSV_RK, SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, + $ SPOSVXX, SGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -122,13 +123,14 @@ SUBROUTINE SERRVX( PATH, NUNIT ) A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -799,6 +801,12 @@ SUBROUTINE SERRVX( PATH, NUNIT ) INFOT = 8 CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) * * SSYSVX * @@ -907,6 +915,8 @@ SUBROUTINE SERRVX( PATH, NUNIT ) $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO ) CALL CHKXER( 'SSYSVXX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SSYSV_ROOK * @@ -923,6 +933,47 @@ SUBROUTINE SERRVX( PATH, NUNIT ) INFOT = 8 CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'SSYSV_RK' + INFOT = 1 + CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/sgbt01.f b/lapack-netlib/TESTING/LIN/sgbt01.f index e2db4516c5..2dd6d93b2e 100644 --- a/lapack-netlib/TESTING/LIN/sgbt01.f +++ b/lapack-netlib/TESTING/LIN/sgbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KL, KU, LDA, LDAFAC, M, N * REAL RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), AFAC( LDAFAC, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KL, KU, LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/sgbt02.f b/lapack-netlib/TESTING/LIN/sgbt02.f index b274caffe0..2be982a8a6 100644 --- a/lapack-netlib/TESTING/LIN/sgbt02.f +++ b/lapack-netlib/TESTING/LIN/sgbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, * LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -139,10 +139,10 @@ SUBROUTINE SGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, $ LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sgbt05.f b/lapack-netlib/TESTING/LIN/sgbt05.f index 150cf117db..82c5a4a86c 100644 --- a/lapack-netlib/TESTING/LIN/sgbt05.f +++ b/lapack-netlib/TESTING/LIN/sgbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -176,10 +176,10 @@ SUBROUTINE SGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sgelqs.f b/lapack-netlib/TESTING/LIN/sgelqs.f index 8e7ea3b96e..cdffebdc8e 100644 --- a/lapack-netlib/TESTING/LIN/sgelqs.f +++ b/lapack-netlib/TESTING/LIN/sgelqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -121,10 +121,10 @@ SUBROUTINE SGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sgennd.f b/lapack-netlib/TESTING/LIN/sgennd.f index 78c8f1ee60..894590991e 100644 --- a/lapack-netlib/TESTING/LIN/sgennd.f +++ b/lapack-netlib/TESTING/LIN/sgennd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION SGENND (M, N, A, LDA) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== LOGICAL FUNCTION SGENND (M, N, A, LDA) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/TESTING/LIN/sgeqls.f b/lapack-netlib/TESTING/LIN/sgeqls.f index 1fe0ab650d..19ae7c5922 100644 --- a/lapack-netlib/TESTING/LIN/sgeqls.f +++ b/lapack-netlib/TESTING/LIN/sgeqls.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -122,10 +122,10 @@ SUBROUTINE SGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sgeqrs.f b/lapack-netlib/TESTING/LIN/sgeqrs.f index cbab20e5d9..9ec64073dc 100644 --- a/lapack-netlib/TESTING/LIN/sgeqrs.f +++ b/lapack-netlib/TESTING/LIN/sgeqrs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -121,10 +121,10 @@ SUBROUTINE SGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sgerqs.f b/lapack-netlib/TESTING/LIN/sgerqs.f index 0e3fa9c1c8..5b04c5ae2e 100644 --- a/lapack-netlib/TESTING/LIN/sgerqs.f +++ b/lapack-netlib/TESTING/LIN/sgerqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -122,10 +122,10 @@ SUBROUTINE SGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sget01.f b/lapack-netlib/TESTING/LIN/sget01.f index 93e2831df2..aa748e8f0e 100644 --- a/lapack-netlib/TESTING/LIN/sget01.f +++ b/lapack-netlib/TESTING/LIN/sget01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAFAC, M, N * REAL RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,12 +94,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -107,10 +107,10 @@ SUBROUTINE SGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/sget02.f b/lapack-netlib/TESTING/LIN/sget02.f index 4e61bc7517..0f15ec0f2a 100644 --- a/lapack-netlib/TESTING/LIN/sget02.f +++ b/lapack-netlib/TESTING/LIN/sget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -133,10 +133,10 @@ SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sget03.f b/lapack-netlib/TESTING/LIN/sget03.f index 0ac0d93899..8b4a2a384b 100644 --- a/lapack-netlib/TESTING/LIN/sget03.f +++ b/lapack-netlib/TESTING/LIN/sget03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, * RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAINV, LDWORK, N * REAL RCOND, RESID @@ -19,7 +19,7 @@ * REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,12 +96,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -109,10 +109,10 @@ SUBROUTINE SGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, $ RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAINV, LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/sget04.f b/lapack-netlib/TESTING/LIN/sget04.f index 4ff383e3fb..3873aabda3 100644 --- a/lapack-netlib/TESTING/LIN/sget04.f +++ b/lapack-netlib/TESTING/LIN/sget04.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDXACT, N, NRHS * REAL RCOND, RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sget06.f b/lapack-netlib/TESTING/LIN/sget06.f index 1500f2ccc4..420004b318 100644 --- a/lapack-netlib/TESTING/LIN/sget06.f +++ b/lapack-netlib/TESTING/LIN/sget06.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SGET06( RCOND, RCONDC ) -* +* * .. Scalar Arguments .. * REAL RCOND, RCONDC * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== REAL FUNCTION SGET06( RCOND, RCONDC ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL RCOND, RCONDC diff --git a/lapack-netlib/TESTING/LIN/sget07.f b/lapack-netlib/TESTING/LIN/sget07.f index ca12ec5e28..42c25cb1d7 100644 --- a/lapack-netlib/TESTING/LIN/sget07.f +++ b/lapack-netlib/TESTING/LIN/sget07.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, CHKFERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CHKFERR @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -165,10 +165,10 @@ SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sgtt01.f b/lapack-netlib/TESTING/LIN/sgtt01.f index 6cd1e3e0f2..5096f83cce 100644 --- a/lapack-netlib/TESTING/LIN/sgtt01.f +++ b/lapack-netlib/TESTING/LIN/sgtt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, * LDWORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDWORK, N * REAL RESID @@ -21,7 +21,7 @@ * $ DU2( * ), DUF( * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -134,10 +134,10 @@ SUBROUTINE SGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, $ LDWORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/sgtt02.f b/lapack-netlib/TESTING/LIN/sgtt02.f index 708a82e2b3..0a39150572 100644 --- a/lapack-netlib/TESTING/LIN/sgtt02.f +++ b/lapack-netlib/TESTING/LIN/sgtt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -124,10 +124,10 @@ SUBROUTINE SGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sgtt05.f b/lapack-netlib/TESTING/LIN/sgtt05.f index 74a28c7f1e..a55537f340 100644 --- a/lapack-netlib/TESTING/LIN/sgtt05.f +++ b/lapack-netlib/TESTING/LIN/sgtt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ DU( * ), FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -165,10 +165,10 @@ SUBROUTINE SGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/slahilb.f b/lapack-netlib/TESTING/LIN/slahilb.f index 66cb300917..be7af415e6 100644 --- a/lapack-netlib/TESTING/LIN/slahilb.f +++ b/lapack-netlib/TESTING/LIN/slahilb.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. * REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) * .. -* +* * *> \par Purpose: * ============= @@ -26,8 +26,8 @@ *> NRHS right-hand sides in B and solutions in X such that A*X=B. *> *> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all -*> entries are integers. The right-hand sides are the first NRHS -*> columns of M * the identity matrix, and the solutions are the +*> entries are integers. The right-hand sides are the first NRHS +*> columns of M * the identity matrix, and the solutions are the *> first NRHS columns of the inverse Hilbert matrix. *> *> The condition number of the Hilbert matrix grows exponentially with @@ -36,7 +36,7 @@ *> generated exactly without extra precision. Precision is exhausted *> when the largest entry in the inverse Hilbert matrix is greater than *> 2 to the power of the number of bits in the fraction of the data type -*> used plus one, which is 24 for single precision. +*> used plus one, which is 24 for single precision. *> *> In single, the generated solution is exact for N <= 6 and has *> small componentwise error for 7 <= N <= 11. @@ -50,7 +50,7 @@ *> N is INTEGER *> The dimension of the matrix A. *> \endverbatim -*> +*> *> \param[in] NRHS *> \verbatim *> NRHS is NRHS @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO diff --git a/lapack-netlib/TESTING/LIN/slaord.f b/lapack-netlib/TESTING/LIN/slaord.f index a6cfeec4d9..3d4553efe6 100644 --- a/lapack-netlib/TESTING/LIN/slaord.f +++ b/lapack-netlib/TESTING/LIN/slaord.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAORD( JOB, N, X, INCX ) -* +* * .. Scalar Arguments .. * CHARACTER JOB * INTEGER INCX, N @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -61,22 +61,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SLAORD( JOB, N, X, INCX ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER JOB diff --git a/lapack-netlib/TESTING/LIN/slaptm.f b/lapack-netlib/TESTING/LIN/slaptm.f index 00189cedb1..cfc04200a6 100644 --- a/lapack-netlib/TESTING/LIN/slaptm.f +++ b/lapack-netlib/TESTING/LIN/slaptm.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, N, NRHS * REAL ALPHA, BETA @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -104,22 +104,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/slarhs.f b/lapack-netlib/TESTING/LIN/slarhs.f index 5d05b12743..4d84cc67ef 100644 --- a/lapack-netlib/TESTING/LIN/slarhs.f +++ b/lapack-netlib/TESTING/LIN/slarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -191,12 +191,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -204,10 +204,10 @@ SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/LIN/slatb4.f b/lapack-netlib/TESTING/LIN/slatb4.f index c2e2021998..7be45ca0a9 100644 --- a/lapack-netlib/TESTING/LIN/slatb4.f +++ b/lapack-netlib/TESTING/LIN/slatb4.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KL, KU, M, MODE, N * REAL ANORM, CNDNUM * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -120,10 +120,10 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, TYPE @@ -339,11 +339,10 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ANORM = ONE END IF * - ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR. - $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * * xPO, xPP, xSY, xSP: Set parameters to generate a -* symmetric matrix. +* symmetric positive definite matrix. * * Set TYPE, the type of matrix to be generated. * @@ -375,6 +374,43 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* +* + ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN +* +* xSY, xSP: Set parameters to generate a +* symmetric matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/slatb5.f b/lapack-netlib/TESTING/LIN/slatb5.f index 1bd65daa1e..be8e962f95 100644 --- a/lapack-netlib/TESTING/LIN/slatb5.f +++ b/lapack-netlib/TESTING/LIN/slatb5.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * REAL ANORM, CNDNUM * INTEGER IMAT, KL, KU, MODE, N * CHARACTER DIST, TYPE * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -114,10 +114,10 @@ SUBROUTINE SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL ANORM, CNDNUM diff --git a/lapack-netlib/TESTING/LIN/slattb.f b/lapack-netlib/TESTING/LIN/slattb.f index b62232b56d..42655ac632 100644 --- a/lapack-netlib/TESTING/LIN/slattb.f +++ b/lapack-netlib/TESTING/LIN/slattb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, * LDAB, B, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, KD, LDAB, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * REAL AB( LDAB, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -135,10 +135,10 @@ SUBROUTINE SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, $ LDAB, B, WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/slattp.f b/lapack-netlib/TESTING/LIN/slattp.f index 22d0a9e691..adc99f3685 100644 --- a/lapack-netlib/TESTING/LIN/slattp.f +++ b/lapack-netlib/TESTING/LIN/slattp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * REAL A( * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -125,10 +125,10 @@ SUBROUTINE SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/slattr.f b/lapack-netlib/TESTING/LIN/slattr.f index 1b9059dffb..9896827f09 100644 --- a/lapack-netlib/TESTING/LIN/slattr.f +++ b/lapack-netlib/TESTING/LIN/slattr.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, * WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, LDA, N @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -133,10 +133,10 @@ SUBROUTINE SLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, $ WORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/slavsp.f b/lapack-netlib/TESTING/LIN/slavsp.f index c7eae92bf5..208a86c9fd 100644 --- a/lapack-netlib/TESTING/LIN/slavsp.f +++ b/lapack-netlib/TESTING/LIN/slavsp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * REAL A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,12 +117,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -130,10 +130,10 @@ SUBROUTINE SLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/slqt01.f b/lapack-netlib/TESTING/LIN/slqt01.f index 919fc982cf..daaf33cab0 100644 --- a/lapack-netlib/TESTING/LIN/slqt01.f +++ b/lapack-netlib/TESTING/LIN/slqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/slqt02.f b/lapack-netlib/TESTING/LIN/slqt02.f index 7de2f1da2f..1db9c5bd96 100644 --- a/lapack-netlib/TESTING/LIN/slqt02.f +++ b/lapack-netlib/TESTING/LIN/slqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -135,10 +135,10 @@ SUBROUTINE SLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/slqt03.f b/lapack-netlib/TESTING/LIN/slqt03.f index 1dd1c92a09..d625d3100a 100644 --- a/lapack-netlib/TESTING/LIN/slqt03.f +++ b/lapack-netlib/TESTING/LIN/slqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/slqt04.f b/lapack-netlib/TESTING/LIN/slqt04.f new file mode 100644 index 0000000000..526bd5623b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/slqt04.f @@ -0,0 +1,259 @@ +*> \brief \b SLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB, LDT +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLQT04 tests SGELQT and SGEMLQT. +*> \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] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SLQT04(M,N,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL SLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL SLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL SGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N ) + CALL SGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LL ) + CALL SLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = SLANGE( '1', M, N, A, M, RWORK ) + RESID = SLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', N, N, ZERO, ONE, L, LL ) + CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, L, LL ) + RESID = SLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL SGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL SGEMLQT( 'L', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL SGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL SGEMLQT( 'R', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/lapack-netlib/TESTING/LIN/slqt05.f b/lapack-netlib/TESTING/LIN/slqt05.f new file mode 100644 index 0000000000..3f9e8e1881 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/slqt05.f @@ -0,0 +1,279 @@ +* Definition: +* =========== +* +* SUBROUTINE SLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SQRT05 tests STPLQT and STPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SLQT05(M,N,L,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = SLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL SLASET( 'Full', M, N2, ZERO, ZERO, A, M ) + CALL SLASET( 'Full', NB, M, ZERO, ZERO, T, NB ) + DO J=1,M + CALL SLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL SLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL SLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL SLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL STPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL SLASET( 'Full', N2, N2, ZERO, ONE, Q, N2 ) + CALL SGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL SLASET( 'Full', N2, N2, ZERO, ZERO, R, N2 ) + CALL SLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*T| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = SLANGE( '1', M, N2, A, M, RWORK ) + RESID = SLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL SLASET( 'Full', N2, N2, ZERO, ONE, R, N2 ) + CALL SSYRK( 'U', 'N', N2, N2, -ONE, Q, N2, ONE, R, N2 ) + RESID = SLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL SLASET( 'Full', N2, M, ZERO, ONE, C, N2 ) + DO J=1,M + CALL SLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = SLANGE( '1', N2, M, C, N2, RWORK) + CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL STPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL SGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = SLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL SLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL STPMLQT( 'L','T',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL SGEMM('T','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = SLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL SLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = SLANGE( '1', M, N2, D, M, RWORK) + CALL SLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL STPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL SGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = SLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL STPMLQT('R','T',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL SGEMM( 'N', 'T', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = SLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/spbt01.f b/lapack-netlib/TESTING/LIN/spbt01.f index 63b26f55d3..6aa3ccfee1 100644 --- a/lapack-netlib/TESTING/LIN/spbt01.f +++ b/lapack-netlib/TESTING/LIN/spbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDAFAC, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -119,10 +119,10 @@ SUBROUTINE SPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spbt02.f b/lapack-netlib/TESTING/LIN/spbt02.f index bc2791366e..9676ef311a 100644 --- a/lapack-netlib/TESTING/LIN/spbt02.f +++ b/lapack-netlib/TESTING/LIN/spbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spbt05.f b/lapack-netlib/TESTING/LIN/spbt05.f index 05eed7c446..44466ac6ea 100644 --- a/lapack-netlib/TESTING/LIN/spbt05.f +++ b/lapack-netlib/TESTING/LIN/spbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -171,10 +171,10 @@ SUBROUTINE SPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spot01.f b/lapack-netlib/TESTING/LIN/spot01.f index 980db18438..930437271e 100644 --- a/lapack-netlib/TESTING/LIN/spot01.f +++ b/lapack-netlib/TESTING/LIN/spot01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spot02.f b/lapack-netlib/TESTING/LIN/spot02.f index fe7c5c3aba..7c68e7c0de 100644 --- a/lapack-netlib/TESTING/LIN/spot02.f +++ b/lapack-netlib/TESTING/LIN/spot02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -127,10 +127,10 @@ SUBROUTINE SPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spot03.f b/lapack-netlib/TESTING/LIN/spot03.f index 565c19bef5..424d43293e 100644 --- a/lapack-netlib/TESTING/LIN/spot03.f +++ b/lapack-netlib/TESTING/LIN/spot03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -20,7 +20,7 @@ * REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -125,10 +125,10 @@ SUBROUTINE SPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spot05.f b/lapack-netlib/TESTING/LIN/spot05.f index ea2c810a39..6c10a3faee 100644 --- a/lapack-netlib/TESTING/LIN/spot05.f +++ b/lapack-netlib/TESTING/LIN/spot05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -151,12 +151,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -164,10 +164,10 @@ SUBROUTINE SPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/sppt01.f b/lapack-netlib/TESTING/LIN/sppt01.f index 072e39bc64..97f9eb0fb0 100644 --- a/lapack-netlib/TESTING/LIN/sppt01.f +++ b/lapack-netlib/TESTING/LIN/sppt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPPT01( UPLO, N, A, AFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A( * ), AFAC( * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -81,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SPPT01( UPLO, N, A, AFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/sppt02.f b/lapack-netlib/TESTING/LIN/sppt02.f index fa298de761..8122e8eba8 100644 --- a/lapack-netlib/TESTING/LIN/sppt02.f +++ b/lapack-netlib/TESTING/LIN/sppt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( * ), B( LDB, * ), RWORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -122,10 +122,10 @@ SUBROUTINE SPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/sppt03.f b/lapack-netlib/TESTING/LIN/sppt03.f index bf756d08dd..2660249dfd 100644 --- a/lapack-netlib/TESTING/LIN/sppt03.f +++ b/lapack-netlib/TESTING/LIN/sppt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDWORK, N @@ -20,7 +20,7 @@ * REAL A( * ), AINV( * ), RWORK( * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -110,10 +110,10 @@ SUBROUTINE SPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/sppt05.f b/lapack-netlib/TESTING/LIN/sppt05.f index cd2a23fc03..c9c6b687ba 100644 --- a/lapack-netlib/TESTING/LIN/sppt05.f +++ b/lapack-netlib/TESTING/LIN/sppt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -156,10 +156,10 @@ SUBROUTINE SPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/spst01.f b/lapack-netlib/TESTING/LIN/spst01.f index 10b7745c40..d7331c6328 100644 --- a/lapack-netlib/TESTING/LIN/spst01.f +++ b/lapack-netlib/TESTING/LIN/spst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, * PIV, RWORK, RESID, RANK ) -* +* * .. Scalar Arguments .. * REAL RESID * INTEGER LDA, LDAFAC, LDPERM, N, RANK @@ -21,7 +21,7 @@ * $ PERM( LDPERM, * ), RWORK( * ) * INTEGER PIV( * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -134,10 +134,10 @@ SUBROUTINE SPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, $ PIV, RWORK, RESID, RANK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL RESID diff --git a/lapack-netlib/TESTING/LIN/sptt01.f b/lapack-netlib/TESTING/LIN/sptt01.f index 8d10a49420..23e82546f5 100644 --- a/lapack-netlib/TESTING/LIN/sptt01.f +++ b/lapack-netlib/TESTING/LIN/sptt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPTT01( N, D, E, DF, EF, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER N * REAL RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL D( * ), DF( * ), E( * ), EF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SPTT01( N, D, E, DF, EF, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/TESTING/LIN/sptt02.f b/lapack-netlib/TESTING/LIN/sptt02.f index d622016d69..5f0b08e1c8 100644 --- a/lapack-netlib/TESTING/LIN/sptt02.f +++ b/lapack-netlib/TESTING/LIN/sptt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, N, NRHS * REAL RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * REAL B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -92,22 +92,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sptt05.f b/lapack-netlib/TESTING/LIN/sptt05.f index a74e239e92..fe78cdc30f 100644 --- a/lapack-netlib/TESTING/LIN/sptt05.f +++ b/lapack-netlib/TESTING/LIN/sptt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, * FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, LDXACT, N, NRHS * .. @@ -19,7 +19,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -150,10 +150,10 @@ SUBROUTINE SPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, $ FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/sqlt01.f b/lapack-netlib/TESTING/LIN/sqlt01.f index 51bb584e54..133aaba044 100644 --- a/lapack-netlib/TESTING/LIN/sqlt01.f +++ b/lapack-netlib/TESTING/LIN/sqlt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqlt02.f b/lapack-netlib/TESTING/LIN/sqlt02.f index 4ea284cae5..6a52b0461f 100644 --- a/lapack-netlib/TESTING/LIN/sqlt02.f +++ b/lapack-netlib/TESTING/LIN/sqlt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqlt03.f b/lapack-netlib/TESTING/LIN/sqlt03.f index e8ef762f29..355fc00d5c 100644 --- a/lapack-netlib/TESTING/LIN/sqlt03.f +++ b/lapack-netlib/TESTING/LIN/sqlt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqpt01.f b/lapack-netlib/TESTING/LIN/sqpt01.f index f7f471f45b..e33d841fc3 100644 --- a/lapack-netlib/TESTING/LIN/sqpt01.f +++ b/lapack-netlib/TESTING/LIN/sqpt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * REAL A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -120,10 +120,10 @@ REAL FUNCTION SQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt01.f b/lapack-netlib/TESTING/LIN/sqrt01.f index d45497abc6..43f0d83cfb 100644 --- a/lapack-netlib/TESTING/LIN/sqrt01.f +++ b/lapack-netlib/TESTING/LIN/sqrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt01p.f b/lapack-netlib/TESTING/LIN/sqrt01p.f index 054f352822..a9de4ec34e 100644 --- a/lapack-netlib/TESTING/LIN/sqrt01p.f +++ b/lapack-netlib/TESTING/LIN/sqrt01p.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt02.f b/lapack-netlib/TESTING/LIN/sqrt02.f index 0442407b83..3509d03114 100644 --- a/lapack-netlib/TESTING/LIN/sqrt02.f +++ b/lapack-netlib/TESTING/LIN/sqrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -135,10 +135,10 @@ SUBROUTINE SQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt03.f b/lapack-netlib/TESTING/LIN/sqrt03.f index 6af6ff1d34..9e19dd6d6a 100644 --- a/lapack-netlib/TESTING/LIN/sqrt03.f +++ b/lapack-netlib/TESTING/LIN/sqrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt04.f b/lapack-netlib/TESTING/LIN/sqrt04.f index 9a1dc3560d..d86caca8ed 100644 --- a/lapack-netlib/TESTING/LIN/sqrt04.f +++ b/lapack-netlib/TESTING/LIN/sqrt04.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT04(M,N,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER M, N, NB, LDT * .. Return values .. * REAL RESULT(6) -* +* * *> \par Purpose: * ============= @@ -54,17 +54,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -74,7 +74,7 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -87,9 +87,9 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * ===================================================================== * * .. -* .. Local allocatable arrays +* .. Local allocatable arrays REAL, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) * * .. Parameters .. @@ -104,17 +104,17 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - REAL SLAMCH + REAL SLAMCH REAL SLANGE, SLANSY LOGICAL LSAME EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN * .. * .. Data statements .. - DATA ISEED / 1988, 1989, 1990, 1991 / -* + DATA ISEED / 1988, 1989, 1990, 1991 / +* EPS = SLAMCH( 'Epsilon' ) K = MIN(M,N) L = MAX(M,N) @@ -122,8 +122,8 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * * Dynamically allocate local arrays * - ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), - $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), $ D(N,M), DF(N,M) ) * * Put random numbers into A and copy to AF @@ -141,7 +141,7 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * Generate the m-by-m matrix Q * CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M ) - CALL SGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, + CALL SGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M, $ WORK, INFO ) * * Copy R @@ -177,7 +177,7 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * * Apply Q to C as Q*C * - CALL SGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + CALL SGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |Q*C - Q*C| / |C| @@ -196,7 +196,7 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * * Apply Q to C as QT*C * - CALL SGEMQRT( 'L', 'T', M, N, K, NB, AF, M, T, NB, CF, M, + CALL SGEMQRT( 'L', 'T', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |QT*C - QT*C| / |C| @@ -207,7 +207,7 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -219,8 +219,8 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * * Apply Q to D as D*Q * - CALL SGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL SGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*Q - D*Q| / |D| * @@ -238,8 +238,8 @@ SUBROUTINE SQRT04(M,N,NB,RESULT) * * Apply Q to D as D*QT * - CALL SGEMQRT( 'R', 'T', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL SGEMQRT( 'R', 'T', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/sqrt05.f b/lapack-netlib/TESTING/LIN/sqrt05.f index 420f4889f4..705d28938f 100644 --- a/lapack-netlib/TESTING/LIN/sqrt05.f +++ b/lapack-netlib/TESTING/LIN/sqrt05.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT05(M,N,L,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER LWORK, M, N, L, NB, LDT * .. Return values .. * REAL RESULT(6) -* +* * *> \par Purpose: * ============= @@ -45,7 +45,7 @@ *> The number of rows of the upper trapezoidal part the *> lower test matrix. 0 <= L <= M. *> \endverbatim -*> +*> *> \param[in] NB *> \verbatim *> NB is INTEGER @@ -61,17 +61,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -81,7 +81,7 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -92,11 +92,11 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) REAL RESULT(6) * * ===================================================================== -* +* * .. -* .. Local allocatable arrays +* .. Local allocatable arrays REAL, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) * * .. Parameters .. @@ -111,14 +111,14 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - REAL SLAMCH + REAL SLAMCH REAL SLANGE, SLANSY LOGICAL LSAME EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME * .. * .. Data statements .. DATA ISEED / 1988, 1989, 1990, 1991 / -* +* EPS = SLAMCH( 'Epsilon' ) K = N M2 = M+N @@ -132,7 +132,7 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) * Dynamically allocate all arrays * ALLOCATE(A(M2,N),AF(M2,N),Q(M2,M2),R(M2,M2),RWORK(M2), - $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), + $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), $ D(N,M2),DF(N,M2) ) * * Put random stuff into A @@ -187,7 +187,7 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) * Compute |I - Q'*Q| and store in RESULT(2) * CALL SLASET( 'Full', M2, M2, ZERO, ONE, R, M2 ) - CALL SSYRK( 'U', 'C', M2, M2, -ONE, Q, M2, ONE, + CALL SSYRK( 'U', 'C', M2, M2, -ONE, Q, M2, ONE, $ R, M2 ) RESID = SLANSY( '1', 'Upper', M2, R, M2, RWORK ) RESULT( 2 ) = RESID / (EPS*MAX(1,M2)) @@ -222,7 +222,7 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) * Apply Q to C as QT*C * CALL STPMQRT('L','T',M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,M2, - $ CF(NP1,1),M2,WORK,INFO) + $ CF(NP1,1),M2,WORK,INFO) * * Compute |QT*C - QT*C| / |C| * @@ -232,7 +232,7 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M2)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -264,8 +264,8 @@ SUBROUTINE SQRT05(M,N,L,NB,RESULT) * Apply Q to D as D*QT * CALL STPMQRT('R','T',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N, - $ DF(1,NP1),N,WORK,INFO) - + $ DF(1,NP1),N,WORK,INFO) + * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/sqrt11.f b/lapack-netlib/TESTING/LIN/sqrt11.f index 6bf6889795..eaffacbf05 100644 --- a/lapack-netlib/TESTING/LIN/sqrt11.f +++ b/lapack-netlib/TESTING/LIN/sqrt11.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M * .. * .. Array Arguments .. * REAL A( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== REAL FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M diff --git a/lapack-netlib/TESTING/LIN/sqrt12.f b/lapack-netlib/TESTING/LIN/sqrt12.f index 7bd601dc61..c7c367011a 100644 --- a/lapack-netlib/TESTING/LIN/sqrt12.f +++ b/lapack-netlib/TESTING/LIN/sqrt12.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL A( LDA, * ), S( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sqrt13.f b/lapack-netlib/TESTING/LIN/sqrt13.f index 594715069a..6d6583bc20 100644 --- a/lapack-netlib/TESTING/LIN/sqrt13.f +++ b/lapack-netlib/TESTING/LIN/sqrt13.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, SCALE * REAL NORMA @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, SCALE diff --git a/lapack-netlib/TESTING/LIN/sqrt14.f b/lapack-netlib/TESTING/LIN/sqrt14.f index 7d1680409d..6e8ac2f3e1 100644 --- a/lapack-netlib/TESTING/LIN/sqrt14.f +++ b/lapack-netlib/TESTING/LIN/sqrt14.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SQRT14( TRANS, M, N, NRHS, A, LDA, X, * LDX, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDX, LWORK, M, N, NRHS @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -116,10 +116,10 @@ REAL FUNCTION SQRT14( TRANS, M, N, NRHS, A, LDA, X, $ LDX, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sqrt15.f b/lapack-netlib/TESTING/LIN/sqrt15.f index cd7e30071b..2ead9fed32 100644 --- a/lapack-netlib/TESTING/LIN/sqrt15.f +++ b/lapack-netlib/TESTING/LIN/sqrt15.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, * RANK, NORMA, NORMB, ISEED, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE * REAL NORMA, NORMB @@ -19,7 +19,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -135,12 +135,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -148,10 +148,10 @@ SUBROUTINE SQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, $ RANK, NORMA, NORMB, ISEED, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE diff --git a/lapack-netlib/TESTING/LIN/sqrt16.f b/lapack-netlib/TESTING/LIN/sqrt16.f index 405f7ff3c1..92e014087f 100644 --- a/lapack-netlib/TESTING/LIN/sqrt16.f +++ b/lapack-netlib/TESTING/LIN/sqrt16.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), RWORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -133,10 +133,10 @@ SUBROUTINE SQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/sqrt17.f b/lapack-netlib/TESTING/LIN/sqrt17.f index dc7c01d26d..c7b543cb6d 100644 --- a/lapack-netlib/TESTING/LIN/sqrt17.f +++ b/lapack-netlib/TESTING/LIN/sqrt17.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SQRT17( TRANS, IRESID, M, N, NRHS, A, * LDA, X, LDX, B, LDB, C, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDB, * ), C( LDB, * ), * $ WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup single_lin * @@ -150,10 +150,10 @@ REAL FUNCTION SQRT17( TRANS, IRESID, M, N, NRHS, A, $ LDA, X, LDX, B, LDB, C, WORK, LWORK ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -172,8 +172,7 @@ REAL FUNCTION SQRT17( TRANS, IRESID, M, N, NRHS, A, * .. * .. Local Scalars .. INTEGER INFO, ISCL, NCOLS, NROWS - REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX, - $ SMLNUM + REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, SMLNUM * .. * .. Local Arrays .. REAL RWORK( 1 ) diff --git a/lapack-netlib/TESTING/LIN/srqt01.f b/lapack-netlib/TESTING/LIN/srqt01.f index 5747b6ea61..993001964e 100644 --- a/lapack-netlib/TESTING/LIN/srqt01.f +++ b/lapack-netlib/TESTING/LIN/srqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -126,10 +126,10 @@ SUBROUTINE SRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/srqt02.f b/lapack-netlib/TESTING/LIN/srqt02.f index 63b8884245..2960d16678 100644 --- a/lapack-netlib/TESTING/LIN/srqt02.f +++ b/lapack-netlib/TESTING/LIN/srqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/srqt03.f b/lapack-netlib/TESTING/LIN/srqt03.f index cf4a637a5a..0b3a8e3da5 100644 --- a/lapack-netlib/TESTING/LIN/srqt03.f +++ b/lapack-netlib/TESTING/LIN/srqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -136,10 +136,10 @@ SUBROUTINE SRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/srzt01.f b/lapack-netlib/TESTING/LIN/srzt01.f index fce9af1286..549bca2e07 100644 --- a/lapack-netlib/TESTING/LIN/srzt01.f +++ b/lapack-netlib/TESTING/LIN/srzt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SRZT01( M, N, A, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * REAL A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -85,12 +85,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -98,10 +98,10 @@ REAL FUNCTION SRZT01( M, N, A, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/srzt02.f b/lapack-netlib/TESTING/LIN/srzt02.f index 831a54f691..12f4018ff6 100644 --- a/lapack-netlib/TESTING/LIN/srzt02.f +++ b/lapack-netlib/TESTING/LIN/srzt02.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SRZT02( M, N, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * REAL AF( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -91,10 +91,10 @@ REAL FUNCTION SRZT02( M, N, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/sspt01.f b/lapack-netlib/TESTING/LIN/sspt01.f index 07ef88ffd1..ecd1d91787 100644 --- a/lapack-netlib/TESTING/LIN/sspt01.f +++ b/lapack-netlib/TESTING/LIN/sspt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * REAL A( * ), AFAC( * ), C( LDC, * ), RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -98,22 +98,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/ssyt01_3.f b/lapack-netlib/TESTING/LIN/ssyt01_3.f new file mode 100644 index 0000000000..f370962c39 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ssyt01_3.f @@ -0,0 +1,248 @@ +*> \brief \b SSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ E( * ), RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by SSYTRF_RK +*> (or SSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by SSYTRF_RK and SSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SSYTRF_RK (or SSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ), RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVSY_ROOK, SSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL SSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* 3) Call SLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL SLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call SLAVSY_ROOK again to multiply by U (or L ). +* + CALL SLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL SSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of SSYT01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/ssyt01_aa.f b/lapack-netlib/TESTING/LIN/ssyt01_aa.f new file mode 100644 index 0000000000..eecdf8a4dc --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ssyt01_aa.f @@ -0,0 +1,262 @@ +*> \brief \b SSYT01_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, +* C, LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYT01_AA reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by SSYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SSYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVSY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL SLASET( 'Full', N, N, ZERO, ZERO, C, LDC ) + CALL SLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL SLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL SLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL SLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL SLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF +* +* Call STRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL STRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL STRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call STRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL STRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL STRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF + ENDIF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL SSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL SSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of SSYT01_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/stbt02.f b/lapack-netlib/TESTING/LIN/stbt02.f index da57abe182..a633098e8f 100644 --- a/lapack-netlib/TESTING/LIN/stbt02.f +++ b/lapack-netlib/TESTING/LIN/stbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, * LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -141,12 +141,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -154,10 +154,10 @@ SUBROUTINE STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, $ LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stbt03.f b/lapack-netlib/TESTING/LIN/stbt03.f index 7104541d31..5c747ae902 100644 --- a/lapack-netlib/TESTING/LIN/stbt03.f +++ b/lapack-netlib/TESTING/LIN/stbt03.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE STBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, * SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * REAL AB( LDAB, * ), B( LDB, * ), CNORM( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -175,10 +175,10 @@ SUBROUTINE STBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, $ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stbt05.f b/lapack-netlib/TESTING/LIN/stbt05.f index 60b6c7d824..b19c34c395 100644 --- a/lapack-netlib/TESTING/LIN/stbt05.f +++ b/lapack-netlib/TESTING/LIN/stbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * $ FERR( * ), RESLTS( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -189,10 +189,10 @@ SUBROUTINE STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stbt06.f b/lapack-netlib/TESTING/LIN/stbt06.f index 452c40a183..f80cf551ca 100644 --- a/lapack-netlib/TESTING/LIN/stbt06.f +++ b/lapack-netlib/TESTING/LIN/stbt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, * WORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER KD, LDAB, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL AB( LDAB, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -125,10 +125,10 @@ SUBROUTINE STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, $ WORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/stplqt.f b/lapack-netlib/TESTING/LIN/stplqt.f new file mode 100644 index 0000000000..30f827998b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/stplqt.f @@ -0,0 +1,253 @@ +* Definition: +* =========== +* +* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPLQT computes a blocked LQ factorization of a real +*> "triangular-pentagonal" matrix C, which is composed of a +*> triangular block A and pentagonal block B, using the compact +*> WY representation for Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix B, and the order of the +*> triangular matrix A. +*> M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix B. +*> N >= 0. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the lower trapezoidal part of B. +*> MIN(M,N) >= L >= 0. See Further Details. +*> \endverbatim +*> +*> \param[in] MB +*> \verbatim +*> MB is INTEGER +*> The block size to be used in the blocked QR. M >= MB >= 1. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the lower triangular N-by-N matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the lower triangular matrix L. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> On entry, the pentagonal M-by-N matrix B. The first N-L columns +*> are rectangular, and the last L columns are lower trapezoidal. +*> On exit, B contains the pentagonal matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDT,N) +*> The lower triangular block reflectors stored in compact form +*> as a sequence of upper triangular blocks. See Further Details. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= MB. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MB*M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The input matrix C is a M-by-(M+N) matrix +*> +*> C = [ A ] [ B ] +*> +*> +*> where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal +*> matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L +*> upper trapezoidal matrix B2: +*> [ B ] = [ B1 ] [ B2 ] +*> [ B1 ] <- M-by-(N-L) rectangular +*> [ B2 ] <- M-by-L upper trapezoidal. +*> +*> The lower trapezoidal matrix B2 consists of the first L columns of a +*> N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, +*> B is rectangular M-by-N; if M=L=N, B is lower triangular. +*> +*> The matrix W stores the elementary reflectors H(i) in the i-th row +*> above the diagonal (of A) in the M-by-(M+N) input matrix C +*> [ C ] = [ A ] [ B ] +*> [ A ] <- lower triangular N-by-N +*> [ B ] <- M-by-N pentagonal +*> +*> so that W can be represented as +*> [ W ] = [ I ] [ V ] +*> [ I ] <- identity, N-by-N +*> [ V ] <- M-by-N, same form as B. +*> +*> Thus, all of information needed for W is contained on exit in B, which +*> we call V above. Note that V has the same form as B; that is, +*> [ V ] = [ V1 ] [ V2 ] +*> [ V1 ] <- M-by-(N-L) rectangular +*> [ V2 ] <- M-by-L lower trapezoidal. +*> +*> The rows of V represent the vectors which define the H(i)'s. +*> +*> The number of blocks is B = ceiling(M/MB), where each +*> block is of order MB except for the last block, which is of order +*> IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block +*> reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB +*> for the last block) T's are stored in the MB-by-N matrix T as +*> +*> T = [T1 T2 ... TB]. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, + $ INFO ) +* +* -- LAPACK computational 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 .. + INTEGER INFO, LDA, LDB, LDT, N, M, L, MB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER I, IB, LB, NB, IINFO +* .. +* .. External Subroutines .. + EXTERNAL STPLQT2, STPRFB, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN + INFO = -3 + ELSE IF( MB.LT.1 .OR. (MB.GT.M .AND. M.GT.0)) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDT.LT.MB ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPLQT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) RETURN +* + DO I = 1, M, MB +* +* Compute the QR factorization of the current block +* + IB = MIN( M-I+1, MB ) + NB = MIN( N-L+I+IB-1, N ) + IF( I.GE.L ) THEN + LB = 0 + ELSE + LB = NB-N+L-I+1 + END IF +* + CALL STPLQT2( IB, NB, LB, A(I,I), LDA, B( I, 1 ), LDB, + $ T(1, I ), LDT, IINFO ) +* +* Update by applying H**T to B(I+IB:M,:) from the right +* + IF( I+IB.LE.M ) THEN + CALL STPRFB( 'R', 'N', 'F', 'R', M-I-IB+1, NB, IB, LB, + $ B( I, 1 ), LDB, T( 1, I ), LDT, + $ A( I+IB, I ), LDA, B( I+IB, 1 ), LDB, + $ WORK, M-I-IB+1) + END IF + END DO + RETURN +* +* End of STPLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/stpt01.f b/lapack-netlib/TESTING/LIN/stpt01.f index d8da0ce32f..428821603c 100644 --- a/lapack-netlib/TESTING/LIN/stpt01.f +++ b/lapack-netlib/TESTING/LIN/stpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL AINVP( * ), AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -96,22 +96,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE STPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/stpt02.f b/lapack-netlib/TESTING/LIN/stpt02.f index 88943fb992..a8e88b2189 100644 --- a/lapack-netlib/TESTING/LIN/stpt02.f +++ b/lapack-netlib/TESTING/LIN/stpt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -141,10 +141,10 @@ SUBROUTINE STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, $ WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stpt03.f b/lapack-netlib/TESTING/LIN/stpt03.f index ce2a57848d..c32f8d9d02 100644 --- a/lapack-netlib/TESTING/LIN/stpt03.f +++ b/lapack-netlib/TESTING/LIN/stpt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, * TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL AP( * ), B( LDB, * ), CNORM( * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -161,10 +161,10 @@ SUBROUTINE STPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, $ TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stpt05.f b/lapack-netlib/TESTING/LIN/stpt05.f index 94934154a5..6e0e4680b9 100644 --- a/lapack-netlib/TESTING/LIN/stpt05.f +++ b/lapack-netlib/TESTING/LIN/stpt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -174,10 +174,10 @@ SUBROUTINE STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/stpt06.f b/lapack-netlib/TESTING/LIN/stpt06.f index 28bffcfcc9..d7bd082f0f 100644 --- a/lapack-netlib/TESTING/LIN/stpt06.f +++ b/lapack-netlib/TESTING/LIN/stpt06.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -18,7 +18,7 @@ * .. Array Arguments .. * REAL AP( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -99,22 +99,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/strt01.f b/lapack-netlib/TESTING/LIN/strt01.f index 5eb4f55d50..1e6af5b9de 100644 --- a/lapack-netlib/TESTING/LIN/strt01.f +++ b/lapack-netlib/TESTING/LIN/strt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, * WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, LDAINV, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), AINV( LDAINV, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -124,10 +124,10 @@ SUBROUTINE STRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, $ WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/strt02.f b/lapack-netlib/TESTING/LIN/strt02.f index e2d9d08319..14ba15bb7e 100644 --- a/lapack-netlib/TESTING/LIN/strt02.f +++ b/lapack-netlib/TESTING/LIN/strt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, * LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -150,10 +150,10 @@ SUBROUTINE STRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, $ LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/strt03.f b/lapack-netlib/TESTING/LIN/strt03.f index 118d1b4aec..23d408a810 100644 --- a/lapack-netlib/TESTING/LIN/strt03.f +++ b/lapack-netlib/TESTING/LIN/strt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, * CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * REAL A( LDA, * ), B( LDB, * ), CNORM( * ), * $ WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -156,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -169,10 +169,10 @@ SUBROUTINE STRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, $ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/strt05.f b/lapack-netlib/TESTING/LIN/strt05.f index 4e87918112..434ce9ad1d 100644 --- a/lapack-netlib/TESTING/LIN/strt05.f +++ b/lapack-netlib/TESTING/LIN/strt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -168,12 +168,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -181,10 +181,10 @@ SUBROUTINE STRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/strt06.f b/lapack-netlib/TESTING/LIN/strt06.f index 491019759b..8d607339de 100644 --- a/lapack-netlib/TESTING/LIN/strt06.f +++ b/lapack-netlib/TESTING/LIN/strt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE STRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, * RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup single_lin * @@ -121,10 +121,10 @@ SUBROUTINE STRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK, $ RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/stsqr01.f b/lapack-netlib/TESTING/LIN/stsqr01.f new file mode 100644 index 0000000000..b661d61f43 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/stsqr01.f @@ -0,0 +1,463 @@ +*> \brief \b STSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* REAL RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \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] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE STSQR01(TSSW, M, N, MB, NB, RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + REAL RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + REAL, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER( ZERO = 0.0, ONE = 1.0 ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, TSIZE, MNB + REAL ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) + REAL TQUERY( 5 ), WORKQUERY +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL SLAMCH, SLARNV, SLANGE, SLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = SLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB +* +* 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), LQ(L,N) ) +* +* 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 ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + CALL SGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL SGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMQR( 'L', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMQR( 'R', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'SGEQR' + CALL SGEQR( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL SLASET( 'Full', M, M, ZERO, ONE, Q, M ) + srnamt = 'SGEMQR' + CALL SGEMQR( 'L', 'N', M, M, K, AF, M, T, TSIZE, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, R, M ) + CALL SLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |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 +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', M, M, ZERO, ONE, R, M ) + CALL SSYRK( 'U', 'C', 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 and a copy CF +* + 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 +* + srnamt = 'DGEQR' + CALL SGEMQR( 'L', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |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 QT*C +* + srnamt = 'DGEQR' + CALL SGEMQR( 'L', 'T', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |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 +* + srnamt = 'DGEQR' + CALL SGEMQR( 'R', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |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 +* + CALL SGEMQR( 'R', 'T', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |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( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + CALL SGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, + $ WORKQUERY, -1, INFO ) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'SGELQ' + CALL SGELQ( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N ) + srnamt = 'SGEMLQ' + CALL SGEMLQ( 'R', 'N', N, N, K, AF, M, T, TSIZE, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, LQ, L ) + CALL SLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = SLANGE( '1', M, N, A, M, RWORK ) + RESID = SLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL SLASET( 'Full', N, N, ZERO, ONE, LQ, L ) + CALL SSYRK( 'U', 'C', N, N, -ONE, Q, N, ONE, LQ, L ) + RESID = SLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL SGEMLQ( 'L', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL SGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL SLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL SGEMLQ( 'L', 'T', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL SGEMM( 'T', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL SGEMLQ( 'R', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL SGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL SLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL SGEMLQ( 'R', 'T', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL SGEMM( 'N', 'T', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = SLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/xerbla.f b/lapack-netlib/TESTING/LIN/xerbla.f index 8694ff1ff7..b0e435a17d 100644 --- a/lapack-netlib/TESTING/LIN/xerbla.f +++ b/lapack-netlib/TESTING/LIN/xerbla.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XERBLA( SRNAME, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER*(*) SRNAME * INTEGER INFO * .. -* +* * *> \par Purpose: * ============= @@ -47,12 +47,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_eig * @@ -75,10 +75,10 @@ * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*(*) SRNAME @@ -123,7 +123,7 @@ SUBROUTINE XERBLA( SRNAME, INFO ) 9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6, $ ' instead of ', I2, ' ***' ) 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A, - $ ' instead of ', A6, ' ***' ) + $ ' instead of ', A9, ' ***' ) 9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6, $ ' had an illegal value ***' ) * diff --git a/lapack-netlib/TESTING/LIN/xlaenv.f b/lapack-netlib/TESTING/LIN/xlaenv.f index 19a54eb0bd..875459b85a 100644 --- a/lapack-netlib/TESTING/LIN/xlaenv.f +++ b/lapack-netlib/TESTING/LIN/xlaenv.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE XLAENV( ISPEC, NVALUE ) -* +* * .. Scalar Arguments .. * INTEGER ISPEC, NVALUE * .. -* +* * *> \par Purpose: * ============= @@ -66,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE XLAENV( ISPEC, NVALUE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER ISPEC, NVALUE diff --git a/lapack-netlib/TESTING/LIN/zchkaa.f b/lapack-netlib/TESTING/LIN/zchkaa.f index 3841534204..5146766b56 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.f +++ b/lapack-netlib/TESTING/LIN/zchkaa.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZCHKAA -* +* * *> \par Purpose: * ============= @@ -51,9 +51,12 @@ *> ZPT 12 List types on next line if 0 < NTYPES < 12 *> ZHE 10 List types on next line if 0 < NTYPES < 10 *> ZHR 10 List types on next line if 0 < NTYPES < 10 +*> ZHK 10 List types on next line if 0 < NTYPES < 10 +*> ZHA 10 List types on next line if 0 < NTYPES < 10 *> ZHP 10 List types on next line if 0 < NTYPES < 10 *> ZSY 11 List types on next line if 0 < NTYPES < 11 *> ZSR 11 List types on next line if 0 < NTYPES < 11 +*> ZSK 11 List types on next line if 0 < NTYPES < 11 *> ZSP 11 List types on next line if 0 < NTYPES < 11 *> ZTR 18 List types on next line if 0 < NTYPES < 18 *> ZTP 18 List types on next line if 0 < NTYPES < 18 @@ -97,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== PROGRAM ZCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * ===================================================================== * @@ -150,7 +153,7 @@ PROGRAM ZCHKAA $ RANKVAL( MAXIN ), PIV( NMAX ) DOUBLE PRECISION RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX*16 A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ WORK( NMAX, NMAX+MAXRHS+10 ) + $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -159,13 +162,16 @@ PROGRAM ZCHKAA * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, - $ ZCHKHE_ROOK, ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, - $ ZCHKPS, ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, - $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, - $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, - $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHP, ZDRVLS, - $ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, - $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP + $ 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, + $ ZDRVHP, ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, + $ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK, + $ ZDRVSY_AA, ILAVER, ZCHKQRT, ZCHKQRTP, ZCHKLQT, + $ ZCHKLQTP, ZCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -638,11 +644,11 @@ PROGRAM ZCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF -* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm, * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -664,6 +670,60 @@ PROGRAM ZCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* HK: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than HR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKHE_RK ( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -719,7 +779,7 @@ PROGRAM ZCHKAA ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SR: symmetric indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -741,6 +801,60 @@ PROGRAM ZCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKSY_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * @@ -935,8 +1049,7 @@ PROGRAM ZCHKAA CALL ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ), $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), - $ S( 1 ), S( NMAX+1 ), WORK, RWORK, IWORK, - $ NOUT ) + $ S( 1 ), S( NMAX+1 ), NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF @@ -947,7 +1060,7 @@ PROGRAM ZCHKAA * QT: QRT routines for general matrices * IF( TSTCHK ) THEN - CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH @@ -958,7 +1071,73 @@ PROGRAM ZCHKAA * QX: QRT routines for triangular-pentagonal matrices * IF( TSTCHK ) THEN - CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + CALL ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TQ' ) ) THEN +* +* TQ: LQT routines for general matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'XQ' ) ) THEN +* +* XQ: LQT routines for triangular-pentagonal matrices +* + IF( TSTCHK ) THEN + CALL ZCHKLQTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + $ NBVAL, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'TS' ) ) THEN +* +* TS: QR routines for tall-skinny matrices +* + IF( TSTCHK ) THEN + CALL ZCHKTSQR( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH diff --git a/lapack-netlib/TESTING/LIN/zchkab.f b/lapack-netlib/TESTING/LIN/zchkab.f index 82dbfa49bf..f15b46b2fc 100644 --- a/lapack-netlib/TESTING/LIN/zchkab.f +++ b/lapack-netlib/TESTING/LIN/zchkab.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZCHKAB -* +* * *> \par Purpose: * ============= @@ -61,10 +61,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -73,7 +73,7 @@ * ===================================================================== PROGRAM ZCHKAB * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/zchkeq.f b/lapack-netlib/TESTING/LIN/zchkeq.f index ac3ccf5bb7..56797bf2b4 100644 --- a/lapack-netlib/TESTING/LIN/zchkeq.f +++ b/lapack-netlib/TESTING/LIN/zchkeq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKEQ( THRESH, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NOUT * DOUBLE PRECISION THRESH * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZCHKEQ( THRESH, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NOUT diff --git a/lapack-netlib/TESTING/LIN/zchkgb.f b/lapack-netlib/TESTING/LIN/zchkgb.f index af3a599e3c..70660eff65 100644 --- a/lapack-netlib/TESTING/LIN/zchkgb.f +++ b/lapack-netlib/TESTING/LIN/zchkgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AFAC( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -177,12 +177,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -191,10 +191,10 @@ SUBROUTINE ZCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkge.f b/lapack-netlib/TESTING/LIN/zchkge.f index e7a31cfe41..41068f32ab 100644 --- a/lapack-netlib/TESTING/LIN/zchkge.f +++ b/lapack-netlib/TESTING/LIN/zchkge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, * NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, * X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NNS, NOUT @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -172,12 +172,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -186,10 +186,10 @@ SUBROUTINE ZCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, $ X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkgt.f b/lapack-netlib/TESTING/LIN/zchkgt.f index e8958e2494..5d18a8e2bf 100644 --- a/lapack-netlib/TESTING/LIN/zchkgt.f +++ b/lapack-netlib/TESTING/LIN/zchkgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -147,10 +147,10 @@ SUBROUTINE ZCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkhe_aa.f b/lapack-netlib/TESTING/LIN/zchkhe_aa.f new file mode 100644 index 0000000000..36125cce91 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkhe_aa.f @@ -0,0 +1,570 @@ +*> \brief \b ZCHKHE_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHE_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHE_AA tests ZHETRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKHE_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANHE + EXTERNAL DGET06, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRHE, ZGET04, + $ ZHECON, ZHERFS, ZHET01_AA, ZHETRF_AA, ZHETRI2, + $ ZHETRS_AA, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, + $ ZLATMS, ZPOT02, ZPOT03, ZPOT05 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate test matrix A. +* +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 1, ( NB+1 )*LDA ) + SRNAMT = 'ZHETRF_AA' + CALL ZHETRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZHETRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHETRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZHET01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZHETRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL ZHETRS_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Check error code from ZHETRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + END IF +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) +c 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, +c $ ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of ZCHKHE_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/zchkhe_rk.f b/lapack-netlib/TESTING/LIN/zchkhe_rk.f new file mode 100644 index 0000000000..a1ade8f915 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkhe_rk.f @@ -0,0 +1,859 @@ +*> \brief \b ZCHKHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHE_RK tests ZHETRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is CCOMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is CCOMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, DTEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANGE, ZLANHE + EXTERNAL DGET06, ZLANGE, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRHE, ZGESVD, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZPOT02, ZPOT03, + $ ZHECON_3, ZHET01_3, ZHETRF_RK, ZHETRI_3, + $ ZHETRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZHETRF_RK' + CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHETRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZHETRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZHETRI_3' +* +* Another reason that we need to compute the invesrse +* is that ZPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZHETRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = DCONJG( BLOCK( 1, 2 ) ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = DCONJG( BLOCK( 2, 1 ) ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZHETRS_3' + CALL ZHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZHETRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZHECON_3' + CALL ZHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZHECON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHECON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZCHKHE_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/zchkhe_rook.f b/lapack-netlib/TESTING/LIN/zchkhe_rook.f index 67d16b7bbf..470c012edf 100644 --- a/lapack-netlib/TESTING/LIN/zchkhe_rook.f +++ b/lapack-netlib/TESTING/LIN/zchkhe_rook.f @@ -163,7 +163,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -172,10 +172,10 @@ SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -211,15 +211,14 @@ SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, - $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, - $ NRUN, NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX, $ SING_MIN, RCOND, RCONDC, DTEMP * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) - INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) DOUBLE PRECISION RESULT( NTESTS ) COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) * .. diff --git a/lapack-netlib/TESTING/LIN/zchkhp.f b/lapack-netlib/TESTING/LIN/zchkhp.f index 7251592d25..08cfb10c8d 100644 --- a/lapack-netlib/TESTING/LIN/zchkhp.f +++ b/lapack-netlib/TESTING/LIN/zchkhp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -164,10 +164,10 @@ SUBROUTINE ZCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchklq.f b/lapack-netlib/TESTING/LIN/zchklq.f index 21adc67774..2c7c6369b5 100644 --- a/lapack-netlib/TESTING/LIN/zchklq.f +++ b/lapack-netlib/TESTING/LIN/zchklq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AC( * ), AF( * ), AL( * ), AQ( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -196,10 +196,10 @@ SUBROUTINE ZCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchklqt.f b/lapack-netlib/TESTING/LIN/zchklqt.f new file mode 100644 index 0000000000..0d23e1e57e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchklqt.f @@ -0,0 +1,210 @@ +*> \brief \b ZCHKLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKLQT( 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 +*> +*> ZCHKLQT tests ZGELQT and ZUNMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKLQT( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQT, ZLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRLQT( 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 ) +* +* Do for each possible value of NB +* + MINMN = MIN( M, N ) + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test ZGELQT and ZUNMLQT +* + IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN + CALL ZLQT04( M, N, NB, 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, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/zchklqtp.f b/lapack-netlib/TESTING/LIN/zchklqtp.f new file mode 100644 index 0000000000..9b76d1df64 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchklqtp.f @@ -0,0 +1,215 @@ +*> \brief \b ZCHKLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKLQTP( 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 +*> +*> ZCHKLQTP tests ZTPLQT and ZTPMLQT. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKLQTP( 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*3 PATH + INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN, + $ MINMN +* .. +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRLQTP, ZLQT04 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'XQ' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRLQTP( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of M +* + DO I = 1, NM + M = MVAL( I ) +* +* Do for each value of N +* + DO J = 1, NN + N = NVAL( J ) +* +* Do for each value of L +* + MINMN = MIN( M, N ) + DO L = 0, MINMN, MAX( MINMN, 1 ) +* +* Do for each possible value of NB +* + DO K = 1, NNB + NB = NBVAL( K ) +* +* Test DTPLQT and DTPMLQT +* + IF( (NB.LE.M).AND.(NB.GT.0) ) THEN + CALL ZLQT05( M, N, L, NB, 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, NB, L, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END IF + END DO + END DO + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' M=', I5, ', N=', I5, ', NB=', I4,' L=', I4, + $ ' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKLQTP +* + END diff --git a/lapack-netlib/TESTING/LIN/zchkpb.f b/lapack-netlib/TESTING/LIN/zchkpb.f index 3f555b3bab..c9fb433ea8 100644 --- a/lapack-netlib/TESTING/LIN/zchkpb.f +++ b/lapack-netlib/TESTING/LIN/zchkpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -168,10 +168,10 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkpo.f b/lapack-netlib/TESTING/LIN/zchkpo.f index 1d1da6aafd..5468b7281d 100644 --- a/lapack-netlib/TESTING/LIN/zchkpo.f +++ b/lapack-netlib/TESTING/LIN/zchkpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -154,12 +154,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -168,10 +168,10 @@ SUBROUTINE ZCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkpp.f b/lapack-netlib/TESTING/LIN/zchkpp.f index 4eac9ea52d..53b43d0aa9 100644 --- a/lapack-netlib/TESTING/LIN/zchkpp.f +++ b/lapack-netlib/TESTING/LIN/zchkpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -159,10 +159,10 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkps.f b/lapack-netlib/TESTING/LIN/zchkps.f index 5e406d601f..9acb28ead2 100644 --- a/lapack-netlib/TESTING/LIN/zchkps.f +++ b/lapack-netlib/TESTING/LIN/zchkps.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, * THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION THRESH * INTEGER NMAX, NN, NNB, NOUT, NRANK @@ -23,7 +23,7 @@ * INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) * LOGICAL DOTYPE( * ) * .. -* +* * *> \par Purpose: * ============= @@ -140,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -154,10 +154,10 @@ SUBROUTINE ZCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION THRESH diff --git a/lapack-netlib/TESTING/LIN/zchkpt.f b/lapack-netlib/TESTING/LIN/zchkpt.f index 04be25ba62..a4f8d8260d 100644 --- a/lapack-netlib/TESTING/LIN/zchkpt.f +++ b/lapack-netlib/TESTING/LIN/zchkpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * A, D, E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,12 +134,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -147,10 +147,10 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ A, D, E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkq3.f b/lapack-netlib/TESTING/LIN/zchkq3.f index 7619188ae5..63e3d64f38 100644 --- a/lapack-netlib/TESTING/LIN/zchkq3.f +++ b/lapack-netlib/TESTING/LIN/zchkq3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * THRESH, A, COPYA, S, TAU, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NN, NNB, NOUT * DOUBLE PRECISION THRESH @@ -23,7 +23,7 @@ * DOUBLE PRECISION S( * ), RWORK( * ) * COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -158,10 +158,10 @@ SUBROUTINE ZCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ THRESH, A, COPYA, S, TAU, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NN, NNB, NOUT diff --git a/lapack-netlib/TESTING/LIN/zchkql.f b/lapack-netlib/TESTING/LIN/zchkql.f index 56554c83fb..0ce0875491 100644 --- a/lapack-netlib/TESTING/LIN/zchkql.f +++ b/lapack-netlib/TESTING/LIN/zchkql.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, * B, X, XACT, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AC( * ), AF( * ), AL( * ), AQ( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -182,12 +182,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -196,10 +196,10 @@ SUBROUTINE ZCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC, $ B, X, XACT, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkqr.f b/lapack-netlib/TESTING/LIN/zchkqr.f index 9953bb333d..3c9763fe31 100644 --- a/lapack-netlib/TESTING/LIN/zchkqr.f +++ b/lapack-netlib/TESTING/LIN/zchkqr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -201,10 +201,10 @@ SUBROUTINE ZCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchkqrt.f b/lapack-netlib/TESTING/LIN/zchkqrt.f index 274c94f13a..61aad40f4f 100644 --- a/lapack-netlib/TESTING/LIN/zchkqrt.f +++ b/lapack-netlib/TESTING/LIN/zchkqrt.f @@ -2,13 +2,13 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) * .. Scalar Arguments .. * LOGICAL TSTERR @@ -88,24 +88,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== - SUBROUTINE ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE -* -* -- LAPACK test routine (version 3.4.0) -- +* +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -174,7 +174,7 @@ SUBROUTINE ZCHKQRT( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, NB = NBVAL( K ) * * Test ZGEQRT and ZGEMQRT -* +* IF( (NB.LE.MINMN).AND.(NB.GT.0) ) THEN CALL ZQRT04( M, N, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/zchkqrtp.f b/lapack-netlib/TESTING/LIN/zchkqrtp.f index fc297b7cb6..123eea63d1 100644 --- a/lapack-netlib/TESTING/LIN/zchkqrtp.f +++ b/lapack-netlib/TESTING/LIN/zchkqrtp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, +* SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * NBVAL, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT @@ -89,24 +89,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== - SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, + SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, $ NBVAL, NOUT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -126,7 +126,7 @@ SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * .. Local Scalars .. CHARACTER*3 PATH INTEGER I, J, K, T, L, M, N, NB, NFAIL, NERRS, NRUN, - $ MINMN + $ MINMN * .. * .. Local Arrays .. DOUBLE PRECISION RESULT( NTESTS ) @@ -172,14 +172,14 @@ SUBROUTINE ZCHKQRTP( THRESH, TSTERR, NM, MVAL, NN, NVAL, NNB, * MINMN = MIN( M, N ) DO L = 0, MINMN, MAX( MINMN, 1 ) -* +* * Do for each possible value of NB * DO K = 1, NNB NB = NBVAL( K ) * * Test ZTPQRT and ZTPMQRT -* +* IF( (NB.LE.N).AND.(NB.GT.0) ) THEN CALL ZQRT05( M, N, L, NB, RESULT ) * diff --git a/lapack-netlib/TESTING/LIN/zchkrfp.f b/lapack-netlib/TESTING/LIN/zchkrfp.f index 0597b9d0f2..27586a4483 100644 --- a/lapack-netlib/TESTING/LIN/zchkrfp.f +++ b/lapack-netlib/TESTING/LIN/zchkrfp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * PROGRAM ZCHKRFP -* +* * *> \par Purpose: * ============= @@ -47,10 +47,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -59,7 +59,7 @@ * ===================================================================== PROGRAM ZCHKRFP * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -253,7 +253,7 @@ PROGRAM ZCHKRFP CALL ZDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + D_WORK_ZLANHE ) * -* Test the convertion routines: +* Test the conversion routines: * zhfttp, ztpthf, ztfttr, ztrttf, ztrttp and ztpttr. * CALL ZDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, @@ -264,7 +264,7 @@ PROGRAM ZCHKRFP CALL ZDRVRF3( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + WORKAINV, WORKAFAC, D_WORK_ZLANHE, + Z_WORK_ZPOT03, Z_WORK_ZPOT02 ) - + * * Test the routine: zhfrk * diff --git a/lapack-netlib/TESTING/LIN/zchkrq.f b/lapack-netlib/TESTING/LIN/zchkrq.f index 5ff1133d2e..ef3bf30442 100644 --- a/lapack-netlib/TESTING/LIN/zchkrq.f +++ b/lapack-netlib/TESTING/LIN/zchkrq.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS @@ -25,7 +25,7 @@ * COMPLEX*16 A( * ), AC( * ), AF( * ), AQ( * ), AR( * ), * $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -201,10 +201,10 @@ SUBROUTINE ZCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC, $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchksp.f b/lapack-netlib/TESTING/LIN/zchksp.f index 6eab6d270e..808e80eeed 100644 --- a/lapack-netlib/TESTING/LIN/zchksp.f +++ b/lapack-netlib/TESTING/LIN/zchksp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -164,10 +164,10 @@ SUBROUTINE ZCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, $ IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchksy_aa.f b/lapack-netlib/TESTING/LIN/zchksy_aa.f new file mode 100644 index 0000000000..465f06d0e3 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchksy_aa.f @@ -0,0 +1,572 @@ +*> \brief \b ZCHKSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* COMPLEX*16 THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKSY_AA tests ZSYTRF_AA, -TRS_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is COMPLEX*16 +*> 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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is COMPLEX*16 array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @generated from LIN/dchksy_aa.f, fortran d -> z, Wed Nov 16 21:34:18 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKSY_AA( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANSY + EXTERNAL DGET06, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGET04, ZLACPY, + $ ZLARHS, ZLATB4, ZLATMS, ZSYT02, DSYT03, DSYT05, + $ DSYCON, ZSYRFS, ZSYT01_AA, ZSYTRF_AA, + $ DSYTRI2, ZSYTRS_AA, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + SRNAMT = 'ZSYTRF_AA' + LWORK = MAX( 1, N*NB + N ) + CALL ZSYTRF_AA( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZSYTRF_AA', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip solver test if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 2 (Using TRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZSYTRS_AA' + LWORK = MAX( 1, 3*N-2 ) + CALL ZSYTRS_AA( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from ZSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZSYTRS_AA', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of ZCHKSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/zchksy_rk.f b/lapack-netlib/TESTING/LIN/zchksy_rk.f new file mode 100644 index 0000000000..c72edc1335 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchksy_rk.f @@ -0,0 +1,867 @@ +*> \brief \b ZCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKSY_RK tests ZSYTRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim + +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANGE, ZLANSY + EXTERNAL DGET06, ZLANGE, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGESVD, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZSYT02, + $ ZSYT03, ZSYCON_3, ZSYT01_3, ZSYTRF_RK, + $ ZSYTRI_3, ZSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZSYTRF_RK' + CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that ZSYT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZSYTRS_3' + CALL ZSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZSYCON_3' + CALL ZSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of ZCHKSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/zchksy_rook.f b/lapack-netlib/TESTING/LIN/zchksy_rook.f index 97f57d818b..d5e53121c6 100644 --- a/lapack-netlib/TESTING/LIN/zchksy_rook.f +++ b/lapack-netlib/TESTING/LIN/zchksy_rook.f @@ -163,7 +163,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -172,10 +172,10 @@ SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -211,9 +211,8 @@ SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH, MATPATH INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, - $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, - $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, - $ NRUN, NT + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, $ SING_MIN, RCOND, RCONDC * .. diff --git a/lapack-netlib/TESTING/LIN/zchktb.f b/lapack-netlib/TESTING/LIN/zchktb.f index aebe9c031d..5a08340293 100644 --- a/lapack-netlib/TESTING/LIN/zchktb.f +++ b/lapack-netlib/TESTING/LIN/zchktb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -23,7 +23,7 @@ * COMPLEX*16 AB( * ), AINV( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -149,10 +149,10 @@ SUBROUTINE ZCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchktp.f b/lapack-netlib/TESTING/LIN/zchktp.f index 5888efc9b1..9336e12ac0 100644 --- a/lapack-netlib/TESTING/LIN/zchktp.f +++ b/lapack-netlib/TESTING/LIN/zchktp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -151,10 +151,10 @@ SUBROUTINE ZCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchktr.f b/lapack-netlib/TESTING/LIN/zchktr.f index a182cd6ab7..57634d86aa 100644 --- a/lapack-netlib/TESTING/LIN/zchktr.f +++ b/lapack-netlib/TESTING/LIN/zchktr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, * WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AINV( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -163,10 +163,10 @@ SUBROUTINE ZCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT, $ WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zchktsqr.f b/lapack-netlib/TESTING/LIN/zchktsqr.f new file mode 100644 index 0000000000..2361609230 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchktsqr.f @@ -0,0 +1,257 @@ +*> \brief \b DCHKQRT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKTSQR( 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 +*> +*> ZCHKTSQR tests ZGEQR and ZGEMQR. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZCHKTSQR( 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*3 PATH + INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB, + $ MINMN, MB, IMB +* +* .. Local Arrays .. + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRTSQR, + $ DTSQR01, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 'TS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 +* +* Test the error exits +* + IF( TSTERR ) CALL ZERRTSQR( 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test ZGEQR and ZGEMQR +* + CALL ZTSQR01( 'TS', M, N, MB, NB, 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, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* 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 ) + IF (MIN(M,N).NE.0) THEN + DO INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* +* Test ZGELQ and ZGEMLQ +* + CALL ZTSQR01( 'SW', M, N, MB, NB, 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 = 9998 )M, N, MB, NB, + $ T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + NTESTS + END DO + END DO + END IF + END DO + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 'TS: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + 9998 FORMAT( 'SW: M=', I5, ', N=', I5, ', MB=', I5, + $ ', NB=', I5,' test(', I2, ')=', G12.5 ) + RETURN +* +* End of ZCHKQRT +* + END diff --git a/lapack-netlib/TESTING/LIN/zchktz.f b/lapack-netlib/TESTING/LIN/zchktz.f index e9045273ed..fbdeabc922 100644 --- a/lapack-netlib/TESTING/LIN/zchktz.f +++ b/lapack-netlib/TESTING/LIN/zchktz.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, * COPYA, S, TAU, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NOUT @@ -22,7 +22,7 @@ * DOUBLE PRECISION S( * ), RWORK( * ) * COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -124,12 +124,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -137,10 +137,10 @@ SUBROUTINE ZCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A, $ COPYA, S, TAU, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvab.f b/lapack-netlib/TESTING/LIN/zdrvab.f index 6af545ad8f..78d779c676 100644 --- a/lapack-netlib/TESTING/LIN/zdrvab.f +++ b/lapack-netlib/TESTING/LIN/zdrvab.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, * NSVAL, THRESH, NMAX, A, AFAC, B, * X, WORK, RWORK, SWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NM, NMAX, NNS, NOUT * DOUBLE PRECISION THRESH @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), B( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -138,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -152,10 +152,10 @@ SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, $ NSVAL, THRESH, NMAX, A, AFAC, B, $ X, WORK, RWORK, SWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NM, NMAX, NNS, NOUT @@ -213,7 +213,7 @@ SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, COMMON / SRNAMC / SRNAMT * .. * .. Data statements .. - DATA ISEEDY / 2006, 2007, 2008, 2009 / + DATA ISEEDY / 2006, 2007, 2008, 2009 / * .. * .. Executable Statements .. * @@ -321,7 +321,7 @@ SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, CALL ZLACPY( 'Full', M, N, AFAC, LDA, A, LDA ) ENDIF * -* Check error code from ZCGESV. This should be the same as +* Check error code from ZCGESV. This should be the same as * the one of DGETRF. * IF( INFO.NE.IZERO ) THEN @@ -355,7 +355,7 @@ SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, * Print information about the tests that did not * pass the testing. * -* If iterative refinement has been used and claimed to +* If iterative refinement has been used and claimed to * be successful (ITER>0), we want * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1 * @@ -425,7 +425,7 @@ SUBROUTINE ZDRVAB( DOTYPE, NM, MVAL, NNS, $ 14X, '11. Scaled near overflow', / 4X, $ '6. Last column zero' ) 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', - $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', + $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', $ / 4x, 'or norm_1( B - A * X ) / ', $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' ) RETURN diff --git a/lapack-netlib/TESTING/LIN/zdrvac.f b/lapack-netlib/TESTING/LIN/zdrvac.f index a32866ee69..08f4c227f7 100644 --- a/lapack-netlib/TESTING/LIN/zdrvac.f +++ b/lapack-netlib/TESTING/LIN/zdrvac.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * A, AFAC, B, X, WORK, * RWORK, SWORK, NOUT ) -* +* * .. Scalar Arguments .. * INTEGER NMAX, NM, NNS, NOUT * DOUBLE PRECISION THRESH @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), B( * ), * $ WORK( * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -131,12 +131,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -145,10 +145,10 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, $ A, AFAC, B, X, WORK, $ RWORK, SWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NMAX, NM, NNS, NOUT @@ -178,7 +178,7 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, CHARACTER DIST, TYPE, UPLO, XTYPE CHARACTER*3 PATH INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, - $ IZERO, KL, KU, LDA, MODE, N, + $ IZERO, KL, KU, LDA, MODE, N, $ NERRS, NFAIL, NIMAT, NRHS, NRUN DOUBLE PRECISION ANORM, CNDNUM * .. @@ -192,7 +192,7 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * .. * .. External Subroutines .. EXTERNAL ALAERH, ZLACPY, ZLAIPD, - $ ZLARHS, ZLATB4, ZLATMS, + $ ZLARHS, ZLATB4, ZLATMS, $ ZPOT06, ZCPOSV * .. * .. Intrinsic Functions .. @@ -333,7 +333,7 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, SRNAMT = 'ZCPOSV ' KASE = KASE + 1 * - CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA) + CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA) * CALL ZCPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, $ WORK, SWORK, RWORK, ITER, INFO ) @@ -374,7 +374,7 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, * Print information about the tests that did not * pass the testing. * -* If iterative refinement has been used and claimed to +* If iterative refinement has been used and claimed to * be successful (ITER>0), we want * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 * @@ -452,7 +452,7 @@ SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', $ / 4x, 'or norm_1( B - A * X ) / ', $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' ) - + RETURN * * End of ZDRVAC diff --git a/lapack-netlib/TESTING/LIN/zdrvgb.f b/lapack-netlib/TESTING/LIN/zdrvgb.f index 19e4ad8d34..6740a6fcfe 100644 --- a/lapack-netlib/TESTING/LIN/zdrvgb.f +++ b/lapack-netlib/TESTING/LIN/zdrvgb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -172,10 +172,10 @@ SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvgbx.f b/lapack-netlib/TESTING/LIN/zdrvgbx.f index a8c4310f2c..9ab2100b74 100644 --- a/lapack-netlib/TESTING/LIN/zdrvgbx.f +++ b/lapack-netlib/TESTING/LIN/zdrvgbx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER LA, LAFB, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -175,10 +175,10 @@ SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvge.f b/lapack-netlib/TESTING/LIN/zdrvge.f index 4b724c208b..1edad5e709 100644 --- a/lapack-netlib/TESTING/LIN/zdrvge.f +++ b/lapack-netlib/TESTING/LIN/zdrvge.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -150,12 +150,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -164,10 +164,10 @@ SUBROUTINE ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvgex.f b/lapack-netlib/TESTING/LIN/zdrvgex.f index 9b7c3003fb..cdfa10727a 100644 --- a/lapack-netlib/TESTING/LIN/zdrvgex.f +++ b/lapack-netlib/TESTING/LIN/zdrvgex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,10 +153,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -167,7 +167,7 @@ SUBROUTINE ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/zdrvgt.f b/lapack-netlib/TESTING/LIN/zdrvgt.f index 0f13764429..d260012e86 100644 --- a/lapack-netlib/TESTING/LIN/zdrvgt.f +++ b/lapack-netlib/TESTING/LIN/zdrvgt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, * B, X, XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -23,7 +23,7 @@ * COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -139,10 +139,10 @@ SUBROUTINE ZDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, $ B, X, XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvhe_aa.f b/lapack-netlib/TESTING/LIN/zdrvhe_aa.f new file mode 100644 index 0000000000..87ebdaa20d --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvhe_aa.f @@ -0,0 +1,483 @@ +*> \brief \b ZDRVHE_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVHE_AA tests the driver routine ZHESV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANHE + EXTERNAL DGET06, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZHESV_AA, ZHET01_AA, ZHETRF_AA, + $ ZHETRI2, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, + $ ZLATMS, ZPOT02 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZHESV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using ZHESV. +* + SRNAMT = 'ZHESV_AA ' + CALL ZHESV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZHESV . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHESV_AA', INFO, K, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZHET01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZHESV_AA', UPLO, N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVHE_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvhe_rk.f b/lapack-netlib/TESTING/LIN/zdrvhe_rk.f new file mode 100644 index 0000000000..93c3fe61d0 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvhe_rk.f @@ -0,0 +1,534 @@ +*> \brief \b ZDRVHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVHE_RK tests the driver routines ZHESV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANHE + EXTERNAL ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, + $ ZGET04, ZLACPY, ZLARHS, ZLATB4, ZLATMS, + $ ZHESV_RK, ZHET01_3, ZPOT02, ZHETRF_RK, ZHETRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZHESV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZHESV_RK. +* + SRNAMT = 'ZHESV_RK' + CALL ZHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHESV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHESV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZHESV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVHE_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvhex.f b/lapack-netlib/TESTING/LIN/zdrvhex.f index ed5c855697..3c0dfbfe49 100644 --- a/lapack-netlib/TESTING/LIN/zdrvhex.f +++ b/lapack-netlib/TESTING/LIN/zdrvhex.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ SUBROUTINE ZDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/zdrvhp.f b/lapack-netlib/TESTING/LIN/zdrvhp.f index 5fc46b0c81..66bd765529 100644 --- a/lapack-netlib/TESTING/LIN/zdrvhp.f +++ b/lapack-netlib/TESTING/LIN/zdrvhp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVHP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -157,10 +157,10 @@ SUBROUTINE ZDRVHP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvls.f b/lapack-netlib/TESTING/LIN/zdrvls.f index d729811d85..c9485e45dc 100644 --- a/lapack-netlib/TESTING/LIN/zdrvls.f +++ b/lapack-netlib/TESTING/LIN/zdrvls.f @@ -2,16 +2,16 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, -* COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT ) -* +* COPYB, C, S, COPYS, NOUT ) +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NNS, NOUT @@ -19,21 +19,20 @@ * .. * .. Array Arguments .. * LOGICAL DOTYPE( * ) -* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), * $ NVAL( * ), NXVAL( * ) -* DOUBLE PRECISION COPYS( * ), RWORK( * ), S( * ) -* COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), -* $ WORK( * ) +* DOUBLE PRECISION COPYS( * ), S( * ) +* COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZDRVLS tests the least squares driver routines ZGELS, CGELSS, ZGELSY -*> and CGELSD. +*> ZDRVLS tests the least squares driver routines ZGELS, ZGETSLS, ZGELSS, ZGELSY +*> and ZGELSD. *> \endverbatim * * Arguments: @@ -170,22 +169,6 @@ *> (min(MMAX,NMAX)) *> \endverbatim *> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (MMAX*NMAX + 4*NMAX + MMAX). -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (5*NMAX-1) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (15*NMAX) -*> \endverbatim -*> *> \param[in] NOUT *> \verbatim *> NOUT is INTEGER @@ -195,24 +178,24 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, - $ COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT ) + $ COPYB, C, S, COPYS, NOUT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -221,18 +204,17 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) - INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), + INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ), $ NVAL( * ), NXVAL( * ) - DOUBLE PRECISION COPYS( * ), RWORK( * ), S( * ) - COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ), - $ WORK( * ) + DOUBLE PRECISION COPYS( * ), S( * ) + COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 14 ) + PARAMETER ( NTESTS = 16 ) INTEGER SMLSIZ PARAMETER ( SMLSIZ = 25 ) DOUBLE PRECISION ONE, ZERO @@ -244,15 +226,25 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * .. Local Scalars .. CHARACTER TRANS CHARACTER*3 PATH - INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK, + INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK, $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK, $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS, - $ NFAIL, NRHS, NROWS, NRUN, RANK + $ NFAIL, NRHS, NROWS, NRUN, RANK, MB, + $ MMAX, NMAX, NSMAX, LIWORK, LRWORK, + $ LWORK_ZGELS, LWORK_ZGETSLS, LWORK_ZGELSS, + $ LWORK_ZGELSY, LWORK_ZGELSD, + $ LRWORK_ZGELSY, LRWORK_ZGELSS, LRWORK_ZGELSD DOUBLE PRECISION EPS, NORMA, NORMB, RCOND * .. * .. Local Arrays .. - INTEGER ISEED( 4 ), ISEEDY( 4 ) - DOUBLE PRECISION RESULT( NTESTS ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY + DOUBLE PRECISION RESULT( NTESTS ), RWORKQUERY + COMPLEX*16 WORKQUERY +* .. +* .. Allocatable Arrays .. + COMPLEX*16, ALLOCATABLE :: WORK (:) + DOUBLE PRECISION, ALLOCATABLE :: RWORK (:) + INTEGER, ALLOCATABLE :: IWORK (:) * .. * .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH, ZQRT12, ZQRT14, ZQRT17 @@ -262,10 +254,10 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DLASRT, XLAENV, $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS, $ ZGELSY, ZGEMM, ZLACPY, ZLARNV, ZQRT13, ZQRT15, - $ ZQRT16 + $ ZQRT16, ZGETSLS * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT + INTRINSIC DBLE, MAX, MIN, INT, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -308,6 +300,77 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO ) $ CALL ALAHD( NOUT, PATH ) INFOT = 0 +* +* Compute maximal workspace needed for all routines +* + NMAX = 0 + MMAX = 0 + NSMAX = 0 + DO I = 1, NM + IF ( MVAL( I ).GT.MMAX ) THEN + MMAX = MVAL( I ) + END IF + ENDDO + DO I = 1, NN + IF ( NVAL( I ).GT.NMAX ) THEN + NMAX = NVAL( I ) + END IF + ENDDO + DO I = 1, NNS + IF ( NSVAL( I ).GT.NSMAX ) THEN + NSMAX = NSVAL( I ) + END IF + ENDDO + M = MMAX + N = NMAX + NRHS = NSMAX + LDA = MAX( 1, M ) + LDB = MAX( 1, M, N ) + MNMIN = MAX( MIN( M, N ), 1 ) +* +* Compute workspace needed for routines +* ZQRT14, ZQRT17 (two side cases), ZQRT15 and ZQRT12 +* + LWORK = MAX( ( M+N )*NRHS, + $ ( N+NRHS )*( M+2 ), ( M+NRHS )*( N+2 ), + $ MAX( M+MNMIN, NRHS*MNMIN,2*N+M ), + $ MAX( M*N+4*MNMIN+MAX(M,N), M*N+2*MNMIN+4*N ) ) +* +* Compute workspace needed for ZGELS + CALL ZGELS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_ZGELS = INT ( WORKQUERY ) +* Compute workspace needed for ZGETSLS + CALL ZGETSLS( 'N', M, N, NRHS, A, LDA, B, LDB, + $ WORKQUERY, -1, INFO ) + LWORK_ZGETSLS = INT( WORKQUERY ) +* Compute workspace needed for ZGELSY + CALL ZGELSY( M, N, NRHS, A, LDA, B, LDB, IWORKQUERY, + $ RCOND, CRANK, WORKQUERY, -1, RWORK, INFO ) + LWORK_ZGELSY = INT( WORKQUERY ) + LRWORK_ZGELSY = 2*N +* Compute workspace needed for ZGELSS + CALL ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, + $ RCOND, CRANK, WORKQUERY, -1 , RWORK, INFO ) + LWORK_ZGELSS = INT( WORKQUERY ) + LRWORK_ZGELSS = 5*MNMIN +* Compute workspace needed for ZGELSD + CALL ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, CRANK, + $ WORKQUERY, -1, RWORKQUERY, IWORKQUERY, INFO ) + LWORK_ZGELSD = INT( WORKQUERY ) + LRWORK_ZGELSD = INT( RWORKQUERY ) +* Compute LIWORK workspace needed for ZGELSY and ZGELSD + LIWORK = MAX( 1, N, IWORKQUERY ) +* Compute LRWORK workspace needed for ZGELSY, ZGELSS and ZGELSD + LRWORK = MAX( 1, LRWORK_ZGELSY, LRWORK_ZGELSS, LRWORK_ZGELSD ) +* Compute LWORK workspace needed for all functions + LWORK = MAX( 1, LWORK, LWORK_ZGELS, LWORK_ZGETSLS, LWORK_ZGELSY, + $ LWORK_ZGELSS, LWORK_ZGELSD ) + LWLSY = LWORK +* + ALLOCATE( WORK( LWORK ) ) + ALLOCATE( IWORK( LIWORK ) ) + ALLOCATE( RWORK( LRWORK ) ) * DO 140 IM = 1, NM M = MVAL( IM ) @@ -315,13 +378,12 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * DO 130 IN = 1, NN N = NVAL( IN ) - MNMIN = MIN( M, N ) + MNMIN = MAX(MIN( M, N ),1) LDB = MAX( 1, M, N ) + MB = (MNMIN+1) * DO 120 INS = 1, NNS NRHS = NSVAL( INS ) - LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ), - $ M*N+4*MNMIN+MAX( M, N ), 2*N+M ) * DO 110 IRANK = 1, 2 DO 100 ISCALE = 1, 3 @@ -431,6 +493,110 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NRUN = NRUN + 2 30 CONTINUE 40 CONTINUE +* +* +* Test ZGETSLS +* +* Generate a matrix of scaling type ISCALE +* + CALL ZQRT13( ISCALE, M, N, COPYA, LDA, NORMA, + $ ISEED ) + DO 65 INB = 1, NNB + MB = NBVAL( INB ) + CALL XLAENV( 1, MB ) + DO 62 IMB = 1, NNB + NB = NBVAL( IMB ) + CALL XLAENV( 2, NB ) +* + DO 60 ITRAN = 1, 2 + IF( ITRAN.EQ.1 ) THEN + TRANS = 'N' + NROWS = M + NCOLS = N + ELSE + TRANS = 'C' + NROWS = N + NCOLS = M + END IF + LDWORK = MAX( 1, NCOLS ) +* +* Set up a consistent rhs +* + IF( NCOLS.GT.0 ) THEN + CALL ZLARNV( 2, ISEED, NCOLS*NRHS, + $ WORK ) + CALL ZSCAL( NCOLS*NRHS, + $ ONE / DBLE( NCOLS ), WORK, + $ 1 ) + END IF + CALL ZGEMM( TRANS, 'No transpose', NROWS, + $ NRHS, NCOLS, CONE, COPYA, LDA, + $ WORK, LDWORK, CZERO, B, LDB ) + CALL ZLACPY( 'Full', NROWS, NRHS, B, LDB, + $ COPYB, LDB ) +* +* Solve LS or overdetermined system +* + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL ZLACPY( 'Full', M, N, COPYA, LDA, + $ A, LDA ) + CALL ZLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, B, LDB ) + END IF + SRNAMT = 'ZGETSLS ' + CALL ZGETSLS( TRANS, M, N, NRHS, A, + $ LDA, B, LDB, WORK, LWORK, INFO ) + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZGETSLS ', INFO, 0, + $ TRANS, M, N, NRHS, -1, NB, + $ ITYPE, NFAIL, NERRS, + $ NOUT ) +* +* Check correctness of results +* + LDWORK = MAX( 1, NROWS ) + IF( NROWS.GT.0 .AND. NRHS.GT.0 ) + $ CALL ZLACPY( 'Full', NROWS, NRHS, + $ COPYB, LDB, C, LDB ) + CALL ZQRT16( TRANS, M, N, NRHS, COPYA, + $ LDA, B, LDB, C, LDB, WORK, + $ RESULT( 15 ) ) +* + IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR. + $ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN +* +* Solving LS system +* + RESULT( 16 ) = ZQRT17( TRANS, 1, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ COPYB, LDB, C, WORK, + $ LWORK ) + ELSE +* +* Solving overdetermined system +* + RESULT( 16 ) = ZQRT14( TRANS, M, N, + $ NRHS, COPYA, LDA, B, LDB, + $ WORK, LWORK ) + END IF +* +* Print information about the tests that +* did not pass the threshold. +* + DO 50 K = 15, 16 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )TRANS, M, + $ N, NRHS, MB, NB, ITYPE, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + 2 + 60 CONTINUE + 62 CONTINUE + 65 CONTINUE END IF * * Generate a matrix of scaling type ISCALE and rank @@ -467,12 +633,6 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, DO 70 J = 1, N IWORK( J ) = 0 70 CONTINUE -* -* Set LWLSY to the adequate value. -* - LWLSY = MNMIN + MAX( 2*MNMIN, NB*( N+1 ), - $ MNMIN+NB*NRHS ) - LWLSY = MAX( 1, LWLSY ) * SRNAMT = 'ZGELSY' CALL ZGELSY( M, N, NRHS, A, LDA, B, LDB, IWORK, @@ -635,7 +795,7 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, * Print information about the tests that did not * pass the threshold. * - DO 80 K = 3, NTESTS + DO 80 K = 3, 14 IF( RESULT( K ).GE.THRESH ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) @@ -661,6 +821,13 @@ SUBROUTINE ZDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4, $ ', type', I2, ', test(', I2, ')=', G12.5 ) + 9997 FORMAT( ' TRANS=''', A1,' M=', I5, ', N=', I5, ', NRHS=', I4, + $ ', MB=', I4,', NB=', I4,', type', I2, + $ ', test(', I2, ')=', G12.5 ) +* + DEALLOCATE( WORK ) + DEALLOCATE( IWORK ) + DEALLOCATE( RWORK ) RETURN * * End of ZDRVLS diff --git a/lapack-netlib/TESTING/LIN/zdrvpb.f b/lapack-netlib/TESTING/LIN/zdrvpb.f index ea98aa48b1..264796452a 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpb.f +++ b/lapack-netlib/TESTING/LIN/zdrvpb.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -159,10 +159,10 @@ SUBROUTINE ZDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvpo.f b/lapack-netlib/TESTING/LIN/zdrvpo.f index 24431e6cd3..1308a1f586 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpo.f +++ b/lapack-netlib/TESTING/LIN/zdrvpo.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -159,10 +159,10 @@ SUBROUTINE ZDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvpox.f b/lapack-netlib/TESTING/LIN/zdrvpox.f index 3242f08eb8..260d8c1f29 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpox.f +++ b/lapack-netlib/TESTING/LIN/zdrvpox.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -162,10 +162,10 @@ SUBROUTINE ZDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvpp.f b/lapack-netlib/TESTING/LIN/zdrvpp.f index 94550ddb74..82901e3ecf 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpp.f +++ b/lapack-netlib/TESTING/LIN/zdrvpp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, * RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), * $ BSAV( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -145,12 +145,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -159,10 +159,10 @@ SUBROUTINE ZDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvpt.f b/lapack-netlib/TESTING/LIN/zdrvpt.f index 8d71be9d36..5943c0637f 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpt.f +++ b/lapack-netlib/TESTING/LIN/zdrvpt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, * E, B, X, XACT, WORK, RWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NN, NOUT, NRHS @@ -23,7 +23,7 @@ * COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ), * $ XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -127,12 +127,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -140,10 +140,10 @@ SUBROUTINE ZDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, $ E, B, X, XACT, WORK, RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvrf1.f b/lapack-netlib/TESTING/LIN/zdrvrf1.f index bfc7e66d7a..6e468452ac 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrf1.f +++ b/lapack-netlib/TESTING/LIN/zdrvrf1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * DOUBLE PRECISION THRESH @@ -19,7 +19,7 @@ * DOUBLE PRECISION WORK( * ) * COMPLEX*16 A( LDA, * ), ARF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -164,14 +164,14 @@ SUBROUTINE ZDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) EPS = DLAMCH( 'Precision' ) SMALL = DLAMCH( 'Safe minimum' ) LARGE = ONE / SMALL - SMALL = SMALL * LDA * LDA + SMALL = SMALL * LDA * LDA LARGE = LARGE / LDA / LDA * DO 130 IIN = 1, NN * N = NVAL( IIN ) * - DO 120 IIT = 1, 3 + DO 120 IIT = 1, 3 * Nothing to do for N=0 IF ( N .EQ. 0 ) EXIT * @@ -244,7 +244,7 @@ SUBROUTINE ZDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'ZLANHF', + WRITE( NOUT, FMT = 9997 ) 'ZLANHF', + N, IIT, UPLO, CFORM, NORM, RESULT(1) NFAIL = NFAIL + 1 END IF diff --git a/lapack-netlib/TESTING/LIN/zdrvrf2.f b/lapack-netlib/TESTING/LIN/zdrvrf2.f index 0d4de1b331..2e95ce7cb7 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrf2.f +++ b/lapack-netlib/TESTING/LIN/zdrvrf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * .. @@ -17,14 +17,14 @@ * INTEGER NVAL( NN ) * COMPLEX*16 A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZDRVRF2 tests the LAPACK RFP convertion routines. +*> ZDRVRF2 tests the LAPACK RFP conversion routines. *> \endverbatim * * Arguments: @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -248,14 +248,14 @@ SUBROUTINE ZDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) WRITE( NOUT, FMT = 9996 ) NERRS, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP conversion', + ' routines ***') - 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + 9998 FORMAT( 1X, ' Error in RFP,conversion routines N=',I5, + ' UPLO=''', A1, ''', FORM =''',A1,'''') - 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', + 9997 FORMAT( 1X, 'All tests for the RFP conversion routines passed (', + I5,' tests run)') - 9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5, - + ' error message recorded') + 9996 FORMAT( 1X, 'RFP conversion routines:',I5,' out of ',I5, + + ' error message recorded') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/zdrvrf3.f b/lapack-netlib/TESTING/LIN/zdrvrf3.f index fa6fb61004..e596b0b6a9 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/zdrvrf3.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU ) -* +* * .. Scalar Arguments .. * INTEGER LDA, NN, NOUT * DOUBLE PRECISION THRESH @@ -22,7 +22,7 @@ * + B2( LDA, * ) * COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * ) * .. -* +* * *> \par Purpose: * ============= @@ -106,12 +106,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -119,10 +119,10 @@ SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, NN, NOUT @@ -257,12 +257,12 @@ SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, END IF * * Generate A our NA--by--NA triangular -* matrix. +* matrix. * Our test is based on forward error so we * do want A to be well conditionned! To get * a well-conditionned triangular matrix, we * take the R factor of the QR/LQ factorization -* of a random matrix. +* of a random matrix. * DO J = 1, NA DO I = 1, NA @@ -292,7 +292,7 @@ SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, * * After the QR factorization, the diagonal * of A is made of real numbers, we multiply -* by a random complex number of absolute +* by a random complex number of absolute * value 1.0E+00. * DO J = 1, NA @@ -349,7 +349,7 @@ SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'ZTFSM', + WRITE( NOUT, FMT = 9997 ) 'ZTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, + N, RESULT(1) NFAIL = NFAIL + 1 @@ -372,7 +372,7 @@ SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, WRITE( NOUT, FMT = 9995 ) 'ZTFSM', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZTFSM + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZTFSM + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', diff --git a/lapack-netlib/TESTING/LIN/zdrvrf4.f b/lapack-netlib/TESTING/LIN/zdrvrf4.f index 6b6055e827..93e866b082 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrf4.f +++ b/lapack-netlib/TESTING/LIN/zdrvrf4.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * + LDA, D_WORK_ZLANGE ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDC, NN, NOUT * DOUBLE PRECISION THRESH @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *), * + CRF( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -114,10 +114,10 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + LDA, D_WORK_ZLANGE ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDC, NN, NOUT @@ -244,7 +244,7 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * * In this case we are TRANS, so A is K-by-N * - DO J = 1,N + DO J = 1,N DO I = 1, K A( I, J) = ZLARND( 4, ISEED ) END DO @@ -256,7 +256,7 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, END IF * * -* Generate C1 our N--by--N Hermitian matrix. +* Generate C1 our N--by--N Hermitian matrix. * Make sure C2 has the same upper/lower part, * (the one that we do not touch), so * copy the initial C1 in C2 in it. @@ -311,7 +311,7 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, * RESULT(1) = ZLANGE( 'I', N, N, C1, LDC, + D_WORK_ZLANGE ) - RESULT(1) = RESULT(1) + RESULT(1) = RESULT(1) + / MAX( DABS( ALPHA ) * NORMA * NORMA + + DABS( BETA ) * NORMC, ONE ) + / MAX( N , 1 ) / EPS @@ -321,7 +321,7 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF - WRITE( NOUT, FMT = 9997 ) 'ZHFRK', + WRITE( NOUT, FMT = 9997 ) 'ZHFRK', + CFORM, UPLO, TRANS, N, K, RESULT(1) NFAIL = NFAIL + 1 END IF @@ -341,7 +341,7 @@ SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN END IF * - 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK + ***') 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, diff --git a/lapack-netlib/TESTING/LIN/zdrvrfp.f b/lapack-netlib/TESTING/LIN/zdrvrfp.f index e101abafad..c7be7da037 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/zdrvrfp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -14,7 +14,7 @@ * + Z_WORK_ZLATMS, Z_WORK_ZPOT02, * + Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE, * + D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 ) -* +* * .. Scalar Arguments .. * INTEGER NN, NNS, NNT, NOUT * DOUBLE PRECISION THRESH @@ -40,7 +40,7 @@ * DOUBLE PRECISION D_WORK_ZPOT02( * ) * DOUBLE PRECISION D_WORK_ZPOT03( * ) * .. -* +* * *> \par Purpose: * ============= @@ -53,11 +53,11 @@ *> This testing routine follow the same tests as ZDRVPO (test for the full *> format Symmetric Positive Definite solver). *> -*> The tests are performed in Full Format, convertion back and forth from +*> The tests are performed in Full Format, conversion back and forth from *> full format to RFP format are performed using the routines ZTRTTF and *> ZTFTTR. *> -*> First, a specific matrix A of size N is created. There is nine types of +*> First, a specific matrix A of size N is created. There is nine types of *> different matrixes possible. *> 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) *> 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS @@ -227,12 +227,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -244,10 +244,10 @@ SUBROUTINE ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE, + D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -521,7 +521,7 @@ SUBROUTINE ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, * * Form the inverse and compute the residual. * - IF(MOD(N,2).EQ.0)THEN + IF(MOD(N,2).EQ.0)THEN CALL ZLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + N+1 ) ELSE diff --git a/lapack-netlib/TESTING/LIN/zdrvsp.f b/lapack-netlib/TESTING/LIN/zdrvsp.f index 039b36e295..94dd6553c9 100644 --- a/lapack-netlib/TESTING/LIN/zdrvsp.f +++ b/lapack-netlib/TESTING/LIN/zdrvsp.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,12 +143,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -157,10 +157,10 @@ SUBROUTINE ZDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvsy_aa.f b/lapack-netlib/TESTING/LIN/zdrvsy_aa.f new file mode 100644 index 0000000000..7b9626785c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvsy_aa.f @@ -0,0 +1,480 @@ +*> \brief \b ZDRVSY_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSY_AA tests the driver routine ZSYSV_AA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is COMPLEX*16 +*> 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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is COMPLEX*16 array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 December 2016 +* +* @generated from LIN/ddrvsy_aa.f, fortran d -> z, Thu Nov 17 12:14:51 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVSY_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANSY + EXTERNAL DGET06, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, ZGET04, ZLACPY, + $ ZLARHS, ZLASET, ZLATB4, ZLATMS, ZSYT02, DSYT05, + $ ZSYSV_AA, ZSYT01_AA, ZSYTRF_AA, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZSYSV_AA --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using ZSYSV_AA. +* + SRNAMT = 'ZSYSV_AA' + CALL ZSYSV_AA( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZSYSV_AA . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZSYSV_AA ', INFO, K, + $ UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) + NT = 2 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZSYSV_AA ', + $ UPLO, N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVSY_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvsy_rk.f b/lapack-netlib/TESTING/LIN/zdrvsy_rk.f new file mode 100644 index 0000000000..1cc983a2cd --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvsy_rk.f @@ -0,0 +1,542 @@ +*> \brief \b ZDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( *), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSY_RK tests the driver routines ZSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \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 dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \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] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \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 December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- 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 NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANSY + EXTERNAL ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, + $ ZSYSV_RK, ZSYT01_3, ZSYT02, ZSYTRF_RK, ZSYTRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by ZSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = ZLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZSYSV_RK. +* + SRNAMT = 'ZSYSV_RK' + CALL ZSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVSY_RK +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvsy_rook.f b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f index 0718a98388..11019bdf2d 100644 --- a/lapack-netlib/TESTING/LIN/zdrvsy_rook.f +++ b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, * IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -153,10 +153,10 @@ SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvsyx.f b/lapack-netlib/TESTING/LIN/zdrvsyx.f index d0dfba88fe..9431cd692b 100644 --- a/lapack-netlib/TESTING/LIN/zdrvsyx.f +++ b/lapack-netlib/TESTING/LIN/zdrvsyx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -143,10 +143,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -157,7 +157,7 @@ SUBROUTINE ZDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 diff --git a/lapack-netlib/TESTING/LIN/zebchvxx.f b/lapack-netlib/TESTING/LIN/zebchvxx.f index 9b95563334..8437685a59 100644 --- a/lapack-netlib/TESTING/LIN/zebchvxx.f +++ b/lapack-netlib/TESTING/LIN/zebchvxx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * diff --git a/lapack-netlib/TESTING/LIN/zerrab.f b/lapack-netlib/TESTING/LIN/zerrab.f index 8862aabc03..1d345a412c 100644 --- a/lapack-netlib/TESTING/LIN/zerrab.f +++ b/lapack-netlib/TESTING/LIN/zerrab.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRAB( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -35,22 +35,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRAB( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/zerrac.f b/lapack-netlib/TESTING/LIN/zerrac.f index 112b3fe573..0ba2b0e061 100644 --- a/lapack-netlib/TESTING/LIN/zerrac.f +++ b/lapack-netlib/TESTING/LIN/zerrac.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRAC( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -35,22 +35,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRAC( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/zerrge.f b/lapack-netlib/TESTING/LIN/zerrge.f index 9b6cd4d95a..a106b3a364 100644 --- a/lapack-netlib/TESTING/LIN/zerrge.f +++ b/lapack-netlib/TESTING/LIN/zerrge.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrgex.f b/lapack-netlib/TESTING/LIN/zerrgex.f index baaa0e5c10..8c0a9f43df 100644 --- a/lapack-netlib/TESTING/LIN/zerrgex.f +++ b/lapack-netlib/TESTING/LIN/zerrgex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRGE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRGE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrgt.f b/lapack-netlib/TESTING/LIN/zerrgt.f index 965b6e55b7..4a5ab934ed 100644 --- a/lapack-netlib/TESTING/LIN/zerrgt.f +++ b/lapack-netlib/TESTING/LIN/zerrgt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRGT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRGT( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrhe.f b/lapack-netlib/TESTING/LIN/zerrhe.f index 6006628893..5f1465b297 100644 --- a/lapack-netlib/TESTING/LIN/zerrhe.f +++ b/lapack-netlib/TESTING/LIN/zerrhe.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,17 +81,19 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INTEGER IP( NMAX ) DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, - $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, - $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS, - $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK, + $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF, + $ ZHETRF_RK, ZHETRF_ROOK, ZHETRF_AA, ZHETRI, + $ ZHETRI_3, ZHETRI_3X, ZHETRI_ROOK, ZHETRI2, + $ ZHETRI2X, ZHETRS, ZHETRS_3, ZHETRS_ROOK, + $ ZHETRS_AA, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, $ ZHPTRS * .. * .. Scalars in Common .. @@ -122,6 +124,7 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -130,13 +133,13 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) 20 CONTINUE ANRM = 1.0D0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZHETRF * SRNAMT = 'ZHETRF' @@ -149,6 +152,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 4 CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) * * ZHETF2 * @@ -189,6 +198,19 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK ) * +* ZHETRI2X +* + SRNAMT = 'ZHETRI2X' + INFOT = 1 + CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) +* * ZHETRS * SRNAMT = 'ZHETRS' @@ -255,12 +277,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 6 CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * ZHETRF_ROOK * @@ -274,6 +296,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 4 CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZHETF2_ROOK * @@ -335,13 +363,171 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 6 CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZHETRF_RK +* + SRNAMT = 'ZHETRF_RK' + INFOT = 1 + CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_RK +* + SRNAMT = 'ZHETF2_RK' + INFOT = 1 + CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3 +* + SRNAMT = 'ZHETRI_3' + INFOT = 1 + CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3X +* + SRNAMT = 'ZHETRI_3X' + INFOT = 1 + CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_3 +* + SRNAMT = 'ZHETRS_3' + INFOT = 1 + CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) +* +* ZHECON_3 +* + SRNAMT = 'ZHECON_3' + INFOT = 1 + CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with Aasen's algorithm. +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* ZHETRF_AA +* + SRNAMT = 'ZHETRF_AA' + INFOT = 1 + CALL ZHETRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_AA', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_AA +* + SRNAMT = 'ZHETRS_AA' + INFOT = 1 + CALL ZHETRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRS_AA( 'U', 0, 1, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZHPTRF * SRNAMT = 'ZHPTRF' diff --git a/lapack-netlib/TESTING/LIN/zerrhex.f b/lapack-netlib/TESTING/LIN/zerrhex.f index bcaf1ed42c..938c283e23 100644 --- a/lapack-netlib/TESTING/LIN/zerrhex.f +++ b/lapack-netlib/TESTING/LIN/zerrhex.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRHE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -87,18 +87,19 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, - $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, - $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS, - $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, - $ ZHPTRS, ZHERFSX + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK, + $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF, + $ ZHETRF_RK, ZHETRF_ROOK, ZHETRI, ZHETRI_3, + $ ZHETRI_3X, ZHETRI_ROOK, ZHETRI2, ZHETRI2X, + $ ZHETRS, ZHETRS_3, ZHETRS_ROOK, ZHPCON, + $ ZHPRFS, ZHPTRF, ZHPTRI, ZHPTRS, ZHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -128,6 +129,7 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -156,6 +158,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 4 CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) * * ZHETF2 * @@ -196,6 +204,19 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK ) * +* ZHETRI2X +* + SRNAMT = 'ZHETRI2X' + INFOT = 1 + CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) +* * ZHETRS * SRNAMT = 'ZHETRS' @@ -309,12 +330,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 6 CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * ZHETRF_ROOK * @@ -328,6 +349,12 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 4 CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZHETF2_ROOK * @@ -389,13 +416,122 @@ SUBROUTINE ZERRHE( PATH, NUNIT ) INFOT = 6 CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN * * Test error exits of the routines that use factorization -* of a Hermitian indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZHETRF_RK +* + SRNAMT = 'ZHETRF_RK' + INFOT = 1 + CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_RK +* + SRNAMT = 'ZHETF2_RK' + INFOT = 1 + CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3 +* + SRNAMT = 'ZHETRI_3' + INFOT = 1 + CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3X +* + SRNAMT = 'ZHETRI_3X' + INFOT = 1 + CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_3 +* + SRNAMT = 'ZHETRS_3' + INFOT = 1 + CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) +* +* ZHECON_3 +* + SRNAMT = 'ZHECON_3' + INFOT = 1 + CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZHPTRF * SRNAMT = 'ZHPTRF' diff --git a/lapack-netlib/TESTING/LIN/zerrlq.f b/lapack-netlib/TESTING/LIN/zerrlq.f index 5531f32aa5..48d7aaa8e5 100644 --- a/lapack-netlib/TESTING/LIN/zerrlq.f +++ b/lapack-netlib/TESTING/LIN/zerrlq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRLQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRLQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrlqt.f b/lapack-netlib/TESTING/LIN/zerrlqt.f new file mode 100644 index 0000000000..2ca3d71210 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zerrlqt.f @@ -0,0 +1,197 @@ +*> \brief \b ZERLQT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRLQT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRLQT tests the error exits for the COMPLEX routines +*> that use the LQT decomposition of a general matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRLQT( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGELQT3, ZGELQT, + $ ZGEMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for LQT factorization +* +* ZGELQT +* + SRNAMT = 'ZGELQT' + INFOT = 1 + CALL ZGELQT( -1, 0, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQT( 0, -1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGELQT( 0, 0, 0, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGELQT( 2, 1, 1, A, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGELQT( 2, 2, 2, A, 2, T, 1, W, INFO ) + CALL CHKXER( 'ZGELQT', INFOT, NOUT, LERR, OK ) +* +* ZGELQT3 +* + SRNAMT = 'ZGELQT3' + INFOT = 1 + CALL ZGELQT3( -1, 0, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQT3( 0, -1, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGELQT3( 2, 2, A, 1, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGELQT3( 2, 2, A, 2, T, 1, INFO ) + CALL CHKXER( 'ZGELQT3', INFOT, NOUT, LERR, OK ) +* +* ZGEMLQT +* + SRNAMT = 'ZGEMLQT' + INFOT = 1 + CALL ZGEMLQT( '/', 'N', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMLQT( 'L', '/', 0, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMLQT( 'L', 'N', -1, 0, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMLQT( 'L', 'N', 0, -1, 0, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQT( 'L', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQT( 'R', 'N', 0, 0, -1, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGEMLQT( 'L', 'N', 0, 0, 0, 0, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMLQT( 'R', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMLQT( 'L', 'N', 2, 2, 2, 1, A, 1, T, 1, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGEMLQT( 'R', 'N', 1, 1, 1, 1, A, 1, T, 0, C, 1, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZGEMLQT( 'L', 'N', 1, 1, 1, 1, A, 1, T, 1, C, 0, W, INFO ) + CALL CHKXER( 'ZGEMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/zerrlqtp.f b/lapack-netlib/TESTING/LIN/zerrlqtp.f new file mode 100644 index 0000000000..f78a311f64 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zerrlqtp.f @@ -0,0 +1,225 @@ +*> \brief \b ZERRLQTP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRLQTP( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRLQTP tests the error exits for the complex routines +*> that use the LQT decomposition of a triangular-pentagonal matrix. +*> \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 December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRLQTP( PATH, NUNIT ) + 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 .. + CHARACTER*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 ), W( NMAX ), + $ B( NMAX, NMAX ), C( NMAX, NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZTPLQT2, ZTPLQT, + $ ZTPMLQT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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 ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + C( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + T( I, J ) = 1.D0 / DCMPLX( DBLE( I+J ), 0.D0 ) + END DO + W( J ) = 0.0 + END DO + OK = .TRUE. +* +* Error exits for TPLQT factorization +* +* ZTPLQT +* + SRNAMT = 'ZTPLQT' + INFOT = 1 + CALL ZTPLQT( -1, 1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPLQT( 1, -1, 0, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT( 0, 1, -1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT( 0, 1, 1, 1, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPLQT( 0, 1, 0, 0, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPLQT( 1, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZTPLQT( 2, 1, 0, 2, A, 1, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZTPLQT( 2, 1, 0, 1, A, 2, B, 1, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZTPLQT( 2, 2, 1, 2, A, 2, B, 2, T, 1, W, INFO ) + CALL CHKXER( 'ZTPLQT', INFOT, NOUT, LERR, OK ) +* +* ZTPLQT2 +* + SRNAMT = 'ZTPLQT2' + INFOT = 1 + CALL ZTPLQT2( -1, 0, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPLQT2( 0, -1, 0, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPLQT2( 0, 0, -1, A, 1, B, 1, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTPLQT2( 2, 2, 0, A, 1, B, 2, T, 2, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZTPLQT2( 2, 2, 0, A, 2, B, 1, T, 2, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZTPLQT2( 2, 2, 0, A, 2, B, 2, T, 1, INFO ) + CALL CHKXER( 'ZTPLQT2', INFOT, NOUT, LERR, OK ) +* +* ZTPMLQT +* + SRNAMT = 'ZTPMLQT' + INFOT = 1 + CALL ZTPMLQT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPMLQT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPMLQT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTPMLQT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTPMLQT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + INFOT = 6 + CALL ZTPMLQT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZTPMLQT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZTPMLQT( 'R', 'N', 2, 2, 2, 1, 1, A, 1, T, 1, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZTPMLQT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZTPMLQT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + $ W, INFO ) + CALL CHKXER( 'ZTPMLQT', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRLQT +* + END diff --git a/lapack-netlib/TESTING/LIN/zerrls.f b/lapack-netlib/TESTING/LIN/zerrls.f index bfb1bd771d..2df87b66b7 100644 --- a/lapack-netlib/TESTING/LIN/zerrls.f +++ b/lapack-netlib/TESTING/LIN/zerrls.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRLS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRLS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrpo.f b/lapack-netlib/TESTING/LIN/zerrpo.f index 143a21e2e1..f53847a18b 100644 --- a/lapack-netlib/TESTING/LIN/zerrpo.f +++ b/lapack-netlib/TESTING/LIN/zerrpo.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrpox.f b/lapack-netlib/TESTING/LIN/zerrpox.f index 761029dd49..fbd9ff3911 100644 --- a/lapack-netlib/TESTING/LIN/zerrpox.f +++ b/lapack-netlib/TESTING/LIN/zerrpox.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRPO( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRPO( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrps.f b/lapack-netlib/TESTING/LIN/zerrps.f index 805a5124d9..5c10dd859a 100644 --- a/lapack-netlib/TESTING/LIN/zerrps.f +++ b/lapack-netlib/TESTING/LIN/zerrps.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRPS( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRPS( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/zerrql.f b/lapack-netlib/TESTING/LIN/zerrql.f index c59ac88060..2c20dfa851 100644 --- a/lapack-netlib/TESTING/LIN/zerrql.f +++ b/lapack-netlib/TESTING/LIN/zerrql.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRQL( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRQL( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrqp.f b/lapack-netlib/TESTING/LIN/zerrqp.f index efd1d905ad..e63b65a9d4 100644 --- a/lapack-netlib/TESTING/LIN/zerrqp.f +++ b/lapack-netlib/TESTING/LIN/zerrqp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRQP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRQP( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrqr.f b/lapack-netlib/TESTING/LIN/zerrqr.f index 8d086a6a19..88e46b0d9d 100644 --- a/lapack-netlib/TESTING/LIN/zerrqr.f +++ b/lapack-netlib/TESTING/LIN/zerrqr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRQR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRQR( PATH, NUNIT ) * -* -- LAPACK test routine ((version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrqrt.f b/lapack-netlib/TESTING/LIN/zerrqrt.f index ea5b6c5469..1f030ca059 100644 --- a/lapack-netlib/TESTING/LIN/zerrqrt.f +++ b/lapack-netlib/TESTING/LIN/zerrqrt.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRQRT( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -56,10 +56,10 @@ SUBROUTINE ZERRQRT( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE ZERRQRT( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZGEQRT2, ZGEQRT3, ZGEQRT, - $ ZGEMQRT + $ ZGEMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK diff --git a/lapack-netlib/TESTING/LIN/zerrqrtp.f b/lapack-netlib/TESTING/LIN/zerrqrtp.f index 7a903f9ea0..6370e04542 100644 --- a/lapack-netlib/TESTING/LIN/zerrqrtp.f +++ b/lapack-netlib/TESTING/LIN/zerrqrtp.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRQRTP( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,12 +43,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -56,10 +56,10 @@ SUBROUTINE ZERRQRTP( PATH, NUNIT ) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,7 +81,7 @@ SUBROUTINE ZERRQRTP( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZTPQRT2, ZTPQRT, - $ ZTPMQRT + $ ZTPMQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,50 +171,50 @@ SUBROUTINE ZERRQRTP( PATH, NUNIT ) * SRNAMT = 'ZTPMQRT' INFOT = 1 - CALL ZTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( '/', 'N', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', '/', 0, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', -1, 0, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', 0, -1, 0, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', 0, 0, -1, 0, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) INFOT = 6 - CALL ZTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', 0, 0, 0, -1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL ZTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', 0, 0, 0, 0, 0, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL ZTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'R', 'N', 1, 2, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL ZTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, + CALL ZTPMQRT( 'L', 'N', 2, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL ZTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, + CALL ZTPMQRT( 'R', 'N', 1, 1, 1, 1, 1, A, 1, T, 0, B, 1, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, + CALL ZTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 0, C, 1, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) INFOT = 15 - CALL ZTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, + CALL ZTPMQRT( 'L', 'N', 1, 1, 1, 1, 1, A, 1, T, 1, B, 1, C, 0, $ W, INFO ) CALL CHKXER( 'ZTPMQRT', INFOT, NOUT, LERR, OK ) * diff --git a/lapack-netlib/TESTING/LIN/zerrrfp.f b/lapack-netlib/TESTING/LIN/zerrrfp.f index 1fba4406ac..0553c40797 100644 --- a/lapack-netlib/TESTING/LIN/zerrrfp.f +++ b/lapack-netlib/TESTING/LIN/zerrrfp.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRRFP( NUNIT ) -* +* * .. Scalar Arguments .. * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -40,22 +40,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRRFP( NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER NUNIT diff --git a/lapack-netlib/TESTING/LIN/zerrrq.f b/lapack-netlib/TESTING/LIN/zerrrq.f index c775b27a4e..36085c8b2a 100644 --- a/lapack-netlib/TESTING/LIN/zerrrq.f +++ b/lapack-netlib/TESTING/LIN/zerrrq.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRRQ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRRQ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrsy.f b/lapack-netlib/TESTING/LIN/zerrsy.f index a9126a12fc..4179e98f35 100644 --- a/lapack-netlib/TESTING/LIN/zerrsy.f +++ b/lapack-netlib/TESTING/LIN/zerrsy.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,7 +80,7 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INTEGER IP( NMAX ) DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -88,9 +88,11 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, - $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, - $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK + $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS, + $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF, + $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3, + $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2Z, + $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -120,6 +122,7 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -128,13 +131,13 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) 20 CONTINUE ANRM = 1.0D0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF * SRNAMT = 'ZSYTRF' @@ -147,6 +150,12 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 4 CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) * * ZSYTF2 * @@ -187,6 +196,19 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK ) * +* ZSYTRI2X +* + SRNAMT = 'ZSYTRI2X' + INFOT = 1 + CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) +* * ZSYTRS * SRNAMT = 'ZSYTRS' @@ -253,13 +275,13 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 6 CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF_ROOK * SRNAMT = 'ZSYTRF_ROOK' @@ -272,6 +294,12 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 4 CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZSYTF2_ROOK * @@ -333,13 +361,122 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 6 CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN * * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZSYTRF_RK +* + SRNAMT = 'ZSYTRF_RK' + INFOT = 1 + CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_RK +* + SRNAMT = 'ZSYTF2_RK' + INFOT = 1 + CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3 +* + SRNAMT = 'ZSYTRI_3' + INFOT = 1 + CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3X +* + SRNAMT = 'ZSYTRI_3X' + INFOT = 1 + CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_3 +* + SRNAMT = 'ZSYTRS_3' + INFOT = 1 + CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_3 +* + SRNAMT = 'ZSYCON_3' + INFOT = 1 + CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * ZSPTRF * SRNAMT = 'ZSPTRF' @@ -412,6 +549,50 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 5 CALL ZSPCON( 'U', 1, A, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSPCON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with Aasen's algorithm. +* +* ZSYTRF_AA +* + SRNAMT = 'ZSYTRF_AA' + INFOT = 1 + CALL ZSYTRF_AA( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_AA( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_AA( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_AA( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_AA', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_AA( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_AA', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_AA +* + SRNAMT = 'ZSYTRS_AA' + INFOT = 1 + CALL ZSYTRS_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_AA( 'U', 2, 1, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZSYTRS_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYTRS_AA', INFOT, NOUT, LERR, OK ) +* END IF * * Print a summary line. diff --git a/lapack-netlib/TESTING/LIN/zerrsyx.f b/lapack-netlib/TESTING/LIN/zerrsyx.f index 1512eb0464..3152ba8e22 100644 --- a/lapack-netlib/TESTING/LIN/zerrsyx.f +++ b/lapack-netlib/TESTING/LIN/zerrsyx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRSY( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -46,22 +46,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -86,7 +86,7 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,10 +94,11 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, - $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, - $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK, - $ ZSYRFSX + $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS, + $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF, + $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3, + $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2X, + $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK, ZSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -127,6 +128,7 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -136,13 +138,13 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) 20 CONTINUE ANRM = 1.0D0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF * SRNAMT = 'ZSYTRF' @@ -155,6 +157,12 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 4 CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) * * ZSYTF2 * @@ -195,6 +203,19 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK ) * +* ZSYTRI2X +* + SRNAMT = 'ZSYTRI2X' + INFOT = 1 + CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) +* * ZSYTRS * SRNAMT = 'ZSYTRS' @@ -308,13 +329,13 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 6 CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF_ROOK * SRNAMT = 'ZSYTRF_ROOK' @@ -327,6 +348,12 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 4 CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZSYTF2_ROOK * @@ -388,13 +415,122 @@ SUBROUTINE ZERRSY( PATH, NUNIT ) INFOT = 6 CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN * * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZSYTRF_RK +* + SRNAMT = 'ZSYTRF_RK' + INFOT = 1 + CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_RK +* + SRNAMT = 'ZSYTF2_RK' + INFOT = 1 + CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3 +* + SRNAMT = 'ZSYTRI_3' + INFOT = 1 + CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3X +* + SRNAMT = 'ZSYTRI_3X' + INFOT = 1 + CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_3 +* + SRNAMT = 'ZSYTRS_3' + INFOT = 1 + CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_3 +* + SRNAMT = 'ZSYCON_3' + INFOT = 1 + CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * ZSPTRF * SRNAMT = 'ZSPTRF' diff --git a/lapack-netlib/TESTING/LIN/zerrtr.f b/lapack-netlib/TESTING/LIN/zerrtr.f index f0708fbbb9..e81d96cd95 100644 --- a/lapack-netlib/TESTING/LIN/zerrtr.f +++ b/lapack-netlib/TESTING/LIN/zerrtr.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRTR( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRTR( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrtsqr.f b/lapack-netlib/TESTING/LIN/zerrtsqr.f new file mode 100644 index 0000000000..526ea0812a --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zerrtsqr.f @@ -0,0 +1,243 @@ +*> \brief \b ZERRTSQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRTSQR( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRTSQR tests the error exits for the ZOUBLE PRECISION routines +*> that use the TSQR decomposition of a general matrix. +*> \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 Zenver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZERRTSQR( PATH, NUNIT ) + 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 .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 2 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, NB +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ), + $ C( NMAX, NMAX ), TAU(NMAX) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGEQR, + $ ZGEMQR, ZGELQ, ZGEMLQ +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*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.D0 / DBLE( I+J ) + C( I, J ) = 1.D0 / DBLE( I+J ) + T( I, J ) = 1.D0 / DBLE( I+J ) + END DO + W( J ) = 0.D0 + END DO + OK = .TRUE. +* +* Error exits for TS factorization +* +* ZGEQR +* + SRNAMT = 'ZGEQR' + INFOT = 1 + CALL ZGEQR( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEQR( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEQR( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGEQR( 3, 2, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEQR( 3, 2, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'ZGEQR', INFOT, NOUT, LERR, OK ) +* +* ZGEMQR +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'ZGEMQR' + NB=1 + INFOT = 1 + CALL ZGEMQR( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMQR( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMQR( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMQR( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMQR( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMQR( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGEMQR( 'L', 'N', 2, 1, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMQR( 'R', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGEMQR( 'L', 'N', 2, 1, 1, A, 2, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMQR( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'ZGEMQR', INFOT, NOUT, LERR, OK ) +* +* ZGELQ +* + SRNAMT = 'ZGELQ' + INFOT = 1 + CALL ZGELQ( -1, 0, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGELQ( 0, -1, A, 1, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGELQ( 1, 1, A, 0, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGELQ( 2, 3, A, 3, TAU, 1, W, 1, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGELQ( 2, 3, A, 3, TAU, 8, W, 0, INFO ) + CALL CHKXER( 'ZGELQ', INFOT, NOUT, LERR, OK ) +* +* ZGEMLQ +* + TAU(1)=1 + TAU(2)=1 + SRNAMT = 'ZGEMLQ' + NB=1 + INFOT = 1 + CALL ZGEMLQ( '/', 'N', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMLQ( 'L', '/', 0, 0, 0, A, 1, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMLQ( 'L', 'N', -1, 0, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMLQ( 'L', 'N', 0, -1, 0, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQ( 'L', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMLQ( 'R', 'N', 0, 0, -1, A, 1, TAU, 1, C, 1, W,1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGEMLQ( 'L', 'N', 1, 2, 0, A, 0, TAU, 1, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMLQ( 'R', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 1, TAU, 0, C, 1, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGEMLQ( 'L', 'N', 1, 2, 1, A, 1, TAU, 6, C, 0, W, 1,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMLQ( 'L', 'N', 2, 2, 1, A, 2, TAU, 6, C, 2, W, 0,INFO) + CALL CHKXER( 'ZGEMLQ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRTSQR +* + END diff --git a/lapack-netlib/TESTING/LIN/zerrtz.f b/lapack-netlib/TESTING/LIN/zerrtz.f index 579c3bf02a..5eb1cf2915 100644 --- a/lapack-netlib/TESTING/LIN/zerrtz.f +++ b/lapack-netlib/TESTING/LIN/zerrtz.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRTZ( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -42,22 +42,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRTZ( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/zerrvx.f b/lapack-netlib/TESTING/LIN/zerrvx.f index 057bf872be..6d64a9e72e 100644 --- a/lapack-netlib/TESTING/LIN/zerrvx.f +++ b/lapack-netlib/TESTING/LIN/zerrvx.f @@ -9,12 +9,12 @@ * =========== * * SUBROUTINE ZERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,7 +82,7 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) DOUBLE PRECISION C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), $ RF( NMAX ), RW( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -90,10 +90,11 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, - $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, - $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSV_ROOK, ZSYSVX + $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX, + $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, + $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, + $ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK, + $ ZSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -123,6 +124,7 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -593,6 +595,12 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) * * ZHESVX * @@ -651,6 +659,65 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZHESV_RK' + INFOT = 1 + CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* ZHESV_AA +* + SRNAMT = 'ZHESV_AA' + INFOT = 1 + CALL ZHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -715,6 +782,12 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) * * ZSYSVX * @@ -773,6 +846,46 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZSYSV_RK' + INFOT = 1 + CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zerrvxx.f b/lapack-netlib/TESTING/LIN/zerrvxx.f index 52fd98b44b..9dc0082152 100644 --- a/lapack-netlib/TESTING/LIN/zerrvxx.f +++ b/lapack-netlib/TESTING/LIN/zerrvxx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -85,7 +85,7 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) $ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -93,11 +93,11 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, - $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, - $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSV_ROOK, ZSYSVX, ZGESVXX, ZSYSVXX, ZPOSVXX, - $ ZHESVXX, ZGBSVXX + $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX, + $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, + $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, + $ ZSYSV, ZSYSV_RK, ZSYSV_ROOK, ZSYSVX, ZGESVXX, + $ ZSYSVXX, ZPOSVXX, ZHESVXX, ZGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -127,6 +127,7 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -835,6 +836,12 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) * * ZHESVX * @@ -951,6 +958,47 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZHESV_RK' + INFOT = 1 + CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -1015,6 +1063,12 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) * * ZSYSVX * @@ -1141,6 +1195,46 @@ SUBROUTINE ZERRVX( PATH, NUNIT ) INFOT = 8 CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZSYSV_RK' + INFOT = 1 + CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zgbt01.f b/lapack-netlib/TESTING/LIN/zgbt01.f index 1c95fb606b..2d3e8ed1dc 100644 --- a/lapack-netlib/TESTING/LIN/zgbt01.f +++ b/lapack-netlib/TESTING/LIN/zgbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER KL, KU, LDA, LDAFAC, M, N * DOUBLE PRECISION RESID @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER KL, KU, LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/zgbt02.f b/lapack-netlib/TESTING/LIN/zgbt02.f index 2fbbaaded4..41f589d853 100644 --- a/lapack-netlib/TESTING/LIN/zgbt02.f +++ b/lapack-netlib/TESTING/LIN/zgbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, * LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -126,12 +126,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -139,10 +139,10 @@ SUBROUTINE ZGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, $ LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zgbt05.f b/lapack-netlib/TESTING/LIN/zgbt05.f index 3556b9b6a8..87a1bdda6e 100644 --- a/lapack-netlib/TESTING/LIN/zgbt05.f +++ b/lapack-netlib/TESTING/LIN/zgbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -176,10 +176,10 @@ SUBROUTINE ZGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zgelqs.f b/lapack-netlib/TESTING/LIN/zgelqs.f index 1514a1aa9b..7545d015e4 100644 --- a/lapack-netlib/TESTING/LIN/zgelqs.f +++ b/lapack-netlib/TESTING/LIN/zgelqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -121,10 +121,10 @@ SUBROUTINE ZGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zgennd.f b/lapack-netlib/TESTING/LIN/zgennd.f index d6bd7ebec5..250835364b 100644 --- a/lapack-netlib/TESTING/LIN/zgennd.f +++ b/lapack-netlib/TESTING/LIN/zgennd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * LOGICAL FUNCTION ZGENND (M, N, A, LDA) -* +* * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -56,22 +56,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== LOGICAL FUNCTION ZGENND (M, N, A, LDA) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA diff --git a/lapack-netlib/TESTING/LIN/zgeqls.f b/lapack-netlib/TESTING/LIN/zgeqls.f index 5aae27c928..b668fac5dd 100644 --- a/lapack-netlib/TESTING/LIN/zgeqls.f +++ b/lapack-netlib/TESTING/LIN/zgeqls.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -122,10 +122,10 @@ SUBROUTINE ZGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zgeqrs.f b/lapack-netlib/TESTING/LIN/zgeqrs.f index d0d2f95dbf..f0d020817c 100644 --- a/lapack-netlib/TESTING/LIN/zgeqrs.f +++ b/lapack-netlib/TESTING/LIN/zgeqrs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -121,10 +121,10 @@ SUBROUTINE ZGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zgerqs.f b/lapack-netlib/TESTING/LIN/zgerqs.f index ebb58d9059..d94a7a3dc6 100644 --- a/lapack-netlib/TESTING/LIN/zgerqs.f +++ b/lapack-netlib/TESTING/LIN/zgerqs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, * INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. @@ -18,7 +18,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -122,10 +122,10 @@ SUBROUTINE ZGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zget01.f b/lapack-netlib/TESTING/LIN/zget01.f index e22c818159..fc21b3bfa6 100644 --- a/lapack-netlib/TESTING/LIN/zget01.f +++ b/lapack-netlib/TESTING/LIN/zget01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAFAC, M, N * DOUBLE PRECISION RESID @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -95,12 +95,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -108,10 +108,10 @@ SUBROUTINE ZGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAFAC, M, N diff --git a/lapack-netlib/TESTING/LIN/zget02.f b/lapack-netlib/TESTING/LIN/zget02.f index cf25ec0263..764620a39a 100644 --- a/lapack-netlib/TESTING/LIN/zget02.f +++ b/lapack-netlib/TESTING/LIN/zget02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -133,10 +133,10 @@ SUBROUTINE ZGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zget03.f b/lapack-netlib/TESTING/LIN/zget03.f index 28b2cbac94..cb05ec4425 100644 --- a/lapack-netlib/TESTING/LIN/zget03.f +++ b/lapack-netlib/TESTING/LIN/zget03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, * RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDAINV, LDWORK, N * DOUBLE PRECISION RCOND, RESID @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -110,10 +110,10 @@ SUBROUTINE ZGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, $ RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDAINV, LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/zget04.f b/lapack-netlib/TESTING/LIN/zget04.f index 55e91c01b6..fe39a8351d 100644 --- a/lapack-netlib/TESTING/LIN/zget04.f +++ b/lapack-netlib/TESTING/LIN/zget04.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDX, LDXACT, N, NRHS * DOUBLE PRECISION RCOND, RESID @@ -17,7 +17,7 @@ * .. Array Arguments .. * COMPLEX*16 X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zget07.f b/lapack-netlib/TESTING/LIN/zget07.f index e154266c09..d9a06a8d8f 100644 --- a/lapack-netlib/TESTING/LIN/zget07.f +++ b/lapack-netlib/TESTING/LIN/zget07.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, CHKFERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * LOGICAL CHKFERR @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -153,12 +153,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -166,10 +166,10 @@ SUBROUTINE ZGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zget08.f b/lapack-netlib/TESTING/LIN/zget08.f index 9b49442291..7d40ecfcca 100644 --- a/lapack-netlib/TESTING/LIN/zget08.f +++ b/lapack-netlib/TESTING/LIN/zget08.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGET08( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -133,10 +133,10 @@ SUBROUTINE ZGET08( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zgtt01.f b/lapack-netlib/TESTING/LIN/zgtt01.f index a6c11063e2..c58c99d021 100644 --- a/lapack-netlib/TESTING/LIN/zgtt01.f +++ b/lapack-netlib/TESTING/LIN/zgtt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, * LDWORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER LDWORK, N * DOUBLE PRECISION RESID @@ -21,7 +21,7 @@ * COMPLEX*16 D( * ), DF( * ), DL( * ), DLF( * ), DU( * ), * $ DU2( * ), DUF( * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -134,10 +134,10 @@ SUBROUTINE ZGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, $ LDWORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDWORK, N diff --git a/lapack-netlib/TESTING/LIN/zgtt02.f b/lapack-netlib/TESTING/LIN/zgtt02.f index 37170fa71c..acdd5b2936 100644 --- a/lapack-netlib/TESTING/LIN/zgtt02.f +++ b/lapack-netlib/TESTING/LIN/zgtt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -124,10 +124,10 @@ SUBROUTINE ZGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zgtt05.f b/lapack-netlib/TESTING/LIN/zgtt05.f index ee9df4ac1f..2dbf5f016b 100644 --- a/lapack-netlib/TESTING/LIN/zgtt05.f +++ b/lapack-netlib/TESTING/LIN/zgtt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ), XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -165,10 +165,10 @@ SUBROUTINE ZGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zhet01_3.f b/lapack-netlib/TESTING/LIN/zhet01_3.f new file mode 100644 index 0000000000..3499868cbb --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zhet01_3.f @@ -0,0 +1,264 @@ +*> \brief \b ZHET01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHET01_3 reconstructs a Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by ZHETRF_RK +*> (or ZHETRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZHETRF_RK (or ZHETRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION ZLANHE, DLAMCH + EXTERNAL LSAME, ZLANHE, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVHE_ROOK, ZSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DIMAG, DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO J = 1, N + IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + END DO +* +* 2) Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVHE_RK again to multiply by U (or L ). +* + CALL ZLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + END DO + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + END DO + ELSE + DO J = 1, N + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + DO I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/DBLE( N ) )/ANORM ) / EPS + END IF +* +* b) Convert to factor of L (or U) +* + CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of ZHET01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/zhet01_aa.f b/lapack-netlib/TESTING/LIN/zhet01_aa.f new file mode 100644 index 0000000000..fc9feb86c2 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zhet01_aa.f @@ -0,0 +1,269 @@ +*> \brief \b ZHET01_AA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHET01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, +* C, LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHET01_AA reconstructs a hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by ZHETRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZHETRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is COMPLEX*16 +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZHET01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVHE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL ZLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL ZLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL ZLACGV( N-1, C( 2, 1 ), LDC+1 ) + ELSE + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL ZLACGV( N-1, C( 1, 2 ), LDC+1 ) + ENDIF +* +* Call ZTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose', 'Unit', + $ N-1, N, CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), + $ LDC ) + ELSE + CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call ZTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose', 'Unit', N, + $ N-1, CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), + $ LDC ) + END IF +* +* Apply hermitian pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO + ENDIF +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of ZHET01_AA +* + END diff --git a/lapack-netlib/TESTING/LIN/zhpt01.f b/lapack-netlib/TESTING/LIN/zhpt01.f index a6f9a4a898..dff63463a2 100644 --- a/lapack-netlib/TESTING/LIN/zhpt01.f +++ b/lapack-netlib/TESTING/LIN/zhpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), AFAC( * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZHPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zlahilb.f b/lapack-netlib/TESTING/LIN/zlahilb.f index e9e5199259..98c0303dbc 100644 --- a/lapack-netlib/TESTING/LIN/zlahilb.f +++ b/lapack-netlib/TESTING/LIN/zlahilb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, * INFO, PATH) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. @@ -18,7 +18,7 @@ * COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -134,10 +134,10 @@ SUBROUTINE ZLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, $ INFO, PATH) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO @@ -168,7 +168,7 @@ SUBROUTINE ZLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8) DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), $ (-.5,-.5),(.5,-.5),(.5,.5)/ DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), @@ -236,7 +236,7 @@ SUBROUTINE ZLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, END DO END DO END IF -* +* * Generate matrix B as simply the first NRHS columns of M * the * identity. TMP = DBLE(M) diff --git a/lapack-netlib/TESTING/LIN/zlaipd.f b/lapack-netlib/TESTING/LIN/zlaipd.f index 918e2bdfff..5975ccf14a 100644 --- a/lapack-netlib/TESTING/LIN/zlaipd.f +++ b/lapack-netlib/TESTING/LIN/zlaipd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAIPD( N, A, INDA, VINDA ) -* +* * .. Scalar Arguments .. * INTEGER INDA, N, VINDA * .. * .. Array Arguments .. * COMPLEX*16 A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,22 +71,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZLAIPD( N, A, INDA, VINDA ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INDA, N, VINDA diff --git a/lapack-netlib/TESTING/LIN/zlaptm.f b/lapack-netlib/TESTING/LIN/zlaptm.f index cc9ff89bfe..6d78a6d6cc 100644 --- a/lapack-netlib/TESTING/LIN/zlaptm.f +++ b/lapack-netlib/TESTING/LIN/zlaptm.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, * LDB ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,12 +116,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -129,10 +129,10 @@ SUBROUTINE ZLAPTM( UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, $ LDB ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zlarhs.f b/lapack-netlib/TESTING/LIN/zlarhs.f index 19ac07c8a8..a2f5f9b859 100644 --- a/lapack-netlib/TESTING/LIN/zlarhs.f +++ b/lapack-netlib/TESTING/LIN/zlarhs.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * A, LDA, X, LDX, B, LDB, ISEED, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS, UPLO, XTYPE * CHARACTER*3 PATH @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -196,12 +196,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -209,10 +209,10 @@ SUBROUTINE ZLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, $ A, LDA, X, LDX, B, LDB, ISEED, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS, UPLO, XTYPE diff --git a/lapack-netlib/TESTING/LIN/zlatb4.f b/lapack-netlib/TESTING/LIN/zlatb4.f index 44db6e8f18..15fab3e1d5 100644 --- a/lapack-netlib/TESTING/LIN/zlatb4.f +++ b/lapack-netlib/TESTING/LIN/zlatb4.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, TYPE * CHARACTER*3 PATH * INTEGER IMAT, KL, KU, M, MODE, N * DOUBLE PRECISION ANORM, CNDNUM * .. -* +* * *> \par Purpose: * ============= @@ -108,12 +108,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2013 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -121,10 +121,10 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- 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..-- -* November 2013 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, TYPE @@ -340,12 +340,10 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ANORM = ONE END IF * - ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR. - $ LSAMEN( 2, C2, 'HE' ) .OR. LSAMEN( 2, C2, 'HP' ) .OR. - $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN * -* xPO, xPP, xHE, xHP, xSY, xSP: Set parameters to generate a -* symmetric or Hermitian matrix. +* xPO, xPP: Set parameters to generate a +* symmetric or Hermitian positive definite matrix. * * Set TYPE, the type of matrix to be generated. * @@ -377,6 +375,43 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'HE' ) .OR. LSAMEN( 2, C2, 'HP' ) .OR. + $ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN +* +* xHE, xHP, xSY, xSP: Set parameters to generate a +* symmetric or Hermitian matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF * ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zlatb5.f b/lapack-netlib/TESTING/LIN/zlatb5.f index e2589ca480..2ccca75a86 100644 --- a/lapack-netlib/TESTING/LIN/zlatb5.f +++ b/lapack-netlib/TESTING/LIN/zlatb5.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, * CNDNUM, DIST ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION ANORM, CNDNUM * INTEGER IMAT, KL, KU, MODE, N * CHARACTER DIST, TYPE * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -101,12 +101,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -114,10 +114,10 @@ SUBROUTINE ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ANORM, CNDNUM diff --git a/lapack-netlib/TESTING/LIN/zlatsp.f b/lapack-netlib/TESTING/LIN/zlatsp.f index 337cb96b25..e7e4c1c916 100644 --- a/lapack-netlib/TESTING/LIN/zlatsp.f +++ b/lapack-netlib/TESTING/LIN/zlatsp.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATSP( UPLO, N, X, ISEED ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -18,7 +18,7 @@ * INTEGER ISEED( * ) * COMPLEX*16 X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -72,22 +72,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZLATSP( UPLO, N, X, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zlatsy.f b/lapack-netlib/TESTING/LIN/zlatsy.f index 95de42b1bd..66b2b4fc40 100644 --- a/lapack-netlib/TESTING/LIN/zlatsy.f +++ b/lapack-netlib/TESTING/LIN/zlatsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATSY( UPLO, N, X, LDX, ISEED ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDX, N @@ -18,7 +18,7 @@ * INTEGER ISEED( * ) * COMPLEX*16 X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -77,22 +77,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZLATSY( UPLO, N, X, LDX, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zlattb.f b/lapack-netlib/TESTING/LIN/zlattb.f index 038adef5ba..5c81763566 100644 --- a/lapack-netlib/TESTING/LIN/zlattb.f +++ b/lapack-netlib/TESTING/LIN/zlattb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, * LDAB, B, WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, KD, LDAB, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AB( LDAB, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -128,12 +128,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -141,10 +141,10 @@ SUBROUTINE ZLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, $ LDAB, B, WORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlattp.f b/lapack-netlib/TESTING/LIN/zlattp.f index b93b1694a7..ef85a280bd 100644 --- a/lapack-netlib/TESTING/LIN/zlattp.f +++ b/lapack-netlib/TESTING/LIN/zlattp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, * RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AP( * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -131,10 +131,10 @@ SUBROUTINE ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, $ RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlattr.f b/lapack-netlib/TESTING/LIN/zlattr.f index 1ea6a1538d..360aa816b6 100644 --- a/lapack-netlib/TESTING/LIN/zlattr.f +++ b/lapack-netlib/TESTING/LIN/zlattr.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, * WORK, RWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER IMAT, INFO, LDA, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,12 +125,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -138,10 +138,10 @@ SUBROUTINE ZLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, $ WORK, RWORK, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlavhp.f b/lapack-netlib/TESTING/LIN/zlavhp.f index b217c26349..08c2b4759b 100644 --- a/lapack-netlib/TESTING/LIN/zlavhp.f +++ b/lapack-netlib/TESTING/LIN/zlavhp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -131,10 +131,10 @@ SUBROUTINE ZLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlavsp.f b/lapack-netlib/TESTING/LIN/zlavsp.f index b491645c15..a248d01d9c 100644 --- a/lapack-netlib/TESTING/LIN/zlavsp.f +++ b/lapack-netlib/TESTING/LIN/zlavsp.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, * INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -118,12 +118,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -131,10 +131,10 @@ SUBROUTINE ZLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB, $ INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlqt01.f b/lapack-netlib/TESTING/LIN/zlqt01.f index cf721e9ebd..492c71c1f0 100644 --- a/lapack-netlib/TESTING/LIN/zlqt01.f +++ b/lapack-netlib/TESTING/LIN/zlqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zlqt02.f b/lapack-netlib/TESTING/LIN/zlqt02.f index dcf85001fe..9a1f35d68d 100644 --- a/lapack-netlib/TESTING/LIN/zlqt02.f +++ b/lapack-netlib/TESTING/LIN/zlqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -135,10 +135,10 @@ SUBROUTINE ZLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zlqt03.f b/lapack-netlib/TESTING/LIN/zlqt03.f index 4f38f7c87f..bff040e760 100644 --- a/lapack-netlib/TESTING/LIN/zlqt03.f +++ b/lapack-netlib/TESTING/LIN/zlqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zlqt04.f b/lapack-netlib/TESTING/LIN/zlqt04.f new file mode 100644 index 0000000000..550432817a --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zlqt04.f @@ -0,0 +1,262 @@ +*> \brief \b DLQT04 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLQT04(M,N,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, NB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLQT04 tests ZGELQT and ZUNMLQT. +*> \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] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= Min(M,N). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - L Q | +*> RESULT(2) = | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZLQT04(M,N,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ L(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0) + PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, LL, LWORK, LDT + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION ZLANGE, ZLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + LL = MAX(M,N) + LWORK = MAX(2,LL)*MAX(2,LL)*NB +* +* Dynamically allocate local arrays +* + ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + $ D(N,M), DF(N,M) ) +* +* Put random numbers into A and copy to AF +* + LDT=NB + DO J=1,N + CALL ZLARNV( 2, ISEED, M, A( 1, J ) ) + END DO + CALL ZLACPY( 'Full', M, N, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL ZGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) +* +* Generate the n-by-n matrix Q +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N ) + CALL ZGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, + $ WORK, INFO ) +* +* Copy L +* + CALL ZLASET( 'Full', LL, N, CZERO, CZERO, L, LL ) + CALL ZLACPY( 'Lower', M, N, AF, M, L, LL ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) + ANORM = ZLANGE( '1', M, N, A, M, RWORK ) + RESID = ZLANGE( '1', M, N, L, LL, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, L, LL ) + CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), L, LL) + RESID = ZLANSY( '1', 'Upper', N, L, LL, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL ZGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL ZGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL ZGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL ZGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + $ WORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END + diff --git a/lapack-netlib/TESTING/LIN/zlqt05.f b/lapack-netlib/TESTING/LIN/zlqt05.f new file mode 100644 index 0000000000..1b8fd1449a --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zlqt05.f @@ -0,0 +1,289 @@ +*> \brief \b ZLQT05 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLQT05(M,N,L,NB,RESULT) +* +* .. Scalar Arguments .. +* INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZQRT05 tests ZTPLQT and ZTPMLQT. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> Number of rows in lower part of the test matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Number of columns in test matrix. +*> \endverbatim +*> +*> \param[in] L +*> \verbatim +*> L is INTEGER +*> The number of rows of the upper trapezoidal part the +*> lower test matrix. 0 <= L <= M. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size of test matrix. NB <= N. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | +*> RESULT(2) = | I - Q^H Q | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE ZLQT05(M,N,L,NB,RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + INTEGER LWORK, M, N, L, NB, LDT +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + INTEGER INFO, J, K, N2, NP1,i + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION ZLANGE, ZLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* + EPS = DLAMCH( 'Epsilon' ) + K = M + N2 = M+N + IF( N.GT.0 ) THEN + NP1 = M+1 + ELSE + NP1 = 1 + END IF + LWORK = N2*N2*NB +* +* Dynamically allocate all arrays +* + ALLOCATE(A(M,N2),AF(M,N2),Q(N2,N2),R(N2,N2),RWORK(N2), + $ WORK(LWORK),T(NB,M),C(N2,M),CF(N2,M), + $ D(M,N2),DF(M,N2) ) +* +* Put random stuff into A +* + LDT=NB + CALL ZLASET( 'Full', M, N2, CZERO, CZERO, A, M ) + CALL ZLASET( 'Full', NB, M, CZERO, CZERO, T, NB ) + DO J=1,M + CALL ZLARNV( 2, ISEED, M-J+1, A( J, J ) ) + END DO + IF( N.GT.0 ) THEN + DO J=1,N-L + CALL ZLARNV( 2, ISEED, M, A( 1, MIN(N+M,M+1) + J - 1 ) ) + END DO + END IF + IF( L.GT.0 ) THEN + DO J=1,L + CALL ZLARNV( 2, ISEED, M-J+1, A( J, MIN(N+M,N+M-L+1) + $ + J - 1 ) ) + END DO + END IF +* +* Copy the matrix A to the array AF. +* + CALL ZLACPY( 'Full', M, N2, A, M, AF, M ) +* +* Factor the matrix A in the array AF. +* + CALL ZTPLQT( M,N,L,NB,AF,M,AF(1,NP1),M,T,LDT,WORK,INFO) +* +* Generate the (M+N)-by-(M+N) matrix Q by applying H to I +* + CALL ZLASET( 'Full', N2, N2, CZERO, ONE, Q, N2 ) + CALL ZGEMLQT( 'L', 'N', N2, N2, K, NB, AF, M, T, LDT, Q, N2, + $ WORK, INFO ) +* +* Copy L +* + CALL ZLASET( 'Full', N2, N2, CZERO, CZERO, R, N2 ) + CALL ZLACPY( 'Lower', M, N2, AF, M, R, N2 ) +* +* Compute |L - A*Q*C| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, A, M, Q, N2, ONE, R, N2) + ANORM = ZLANGE( '1', M, N2, A, M, RWORK ) + RESID = ZLANGE( '1', M, N2, R, N2, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,N2)) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q*Q'| and store in RESULT(2) +* + CALL ZLASET( 'Full', N2, N2, CZERO, ONE, R, N2 ) + CALL ZHERK( 'U', 'N', N2, N2, DREAL(-ONE), Q, N2, DREAL(ONE), + $ R, N2 ) + RESID = ZLANSY( '1', 'Upper', N2, R, N2, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N2)) +* +* Generate random m-by-n matrix C and a copy CF +* + CALL ZLASET( 'Full', N2, M, CZERO, ONE, C, N2 ) + DO J=1,M + CALL ZLARNV( 2, ISEED, N2, C( 1, J ) ) + END DO + CNORM = ZLANGE( '1', N2, M, C, N2, RWORK) + CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as Q*C +* + CALL ZTPMLQT( 'L','N', N,M,K,L,NB,AF(1, NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL ZGEMM( 'N', 'N', N2, M, N2, -ONE, Q, N2, C, N2, ONE, CF, N2 ) + RESID = ZLANGE( '1', N2, M, CF, N2, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 3 ) = ZERO + END IF + +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', N2, M, C, N2, CF, N2 ) +* +* Apply Q to C as QT*C +* + CALL ZTPMLQT( 'L','C',N,M,K,L,NB,AF(1,NP1),M,T,LDT,CF,N2, + $ CF(NP1,1),N2,WORK,INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL ZGEMM('C','N',N2,M,N2,-ONE,Q,N2,C,N2,ONE,CF,N2) + RESID = ZLANGE( '1', N2, M, CF, N2, RWORK ) + + IF( CNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N2)*CNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random m-by-n matrix D and a copy DF +* + DO J=1,N2 + CALL ZLARNV( 2, ISEED, M, D( 1, J ) ) + END DO + DNORM = ZLANGE( '1', M, N2, D, M, RWORK) + CALL ZLACPY( 'Full', M, N2, D, M, DF, M ) +* +* Apply Q to D as D*Q +* + CALL ZTPMLQT('R','N',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL ZGEMM('N','N',M,N2,N2,-ONE,D,M,Q,N2,ONE,DF,M) + RESID = ZLANGE('1',M, N2,DF,M,RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY('Full',M,N2,D,M,DF,M ) +* +* Apply Q to D as D*QT +* + CALL ZTPMLQT('R','C',M,N,K,L,NB,AF(1,NP1),M,T,LDT,DF,M, + $ DF(1,NP1),M,WORK,INFO) + +* +* Compute |D*QT - D*QT| / |D| +* + CALL ZGEMM( 'N', 'C', M, N2, N2, -ONE, D, M, Q, N2, ONE, DF, M ) + RESID = ZLANGE( '1', M, N2, DF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N2)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) + RETURN + END diff --git a/lapack-netlib/TESTING/LIN/zpbt01.f b/lapack-netlib/TESTING/LIN/zpbt01.f index 695dd525e5..25783e8073 100644 --- a/lapack-netlib/TESTING/LIN/zpbt01.f +++ b/lapack-netlib/TESTING/LIN/zpbt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDAFAC, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -120,10 +120,10 @@ SUBROUTINE ZPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpbt02.f b/lapack-netlib/TESTING/LIN/zpbt02.f index 20f0375846..a8c1f383a8 100644 --- a/lapack-netlib/TESTING/LIN/zpbt02.f +++ b/lapack-netlib/TESTING/LIN/zpbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpbt05.f b/lapack-netlib/TESTING/LIN/zpbt05.f index 6f9521f489..489bdff502 100644 --- a/lapack-netlib/TESTING/LIN/zpbt05.f +++ b/lapack-netlib/TESTING/LIN/zpbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -171,10 +171,10 @@ SUBROUTINE ZPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpot01.f b/lapack-netlib/TESTING/LIN/zpot01.f index a9d5f72f0a..946c494387 100644 --- a/lapack-netlib/TESTING/LIN/zpot01.f +++ b/lapack-netlib/TESTING/LIN/zpot01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, N @@ -19,7 +19,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -94,22 +94,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpot02.f b/lapack-netlib/TESTING/LIN/zpot02.f index 6e521831f3..61cc94db22 100644 --- a/lapack-netlib/TESTING/LIN/zpot02.f +++ b/lapack-netlib/TESTING/LIN/zpot02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -127,10 +127,10 @@ SUBROUTINE ZPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpot03.f b/lapack-netlib/TESTING/LIN/zpot03.f index b55d23d153..5978d2ea2d 100644 --- a/lapack-netlib/TESTING/LIN/zpot03.f +++ b/lapack-netlib/TESTING/LIN/zpot03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpot05.f b/lapack-netlib/TESTING/LIN/zpot05.f index b5b549de07..9c29990eaf 100644 --- a/lapack-netlib/TESTING/LIN/zpot05.f +++ b/lapack-netlib/TESTING/LIN/zpot05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -152,12 +152,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -165,10 +165,10 @@ SUBROUTINE ZPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpot06.f b/lapack-netlib/TESTING/LIN/zpot06.f index 167e4a6411..c773cd4c39 100644 --- a/lapack-netlib/TESTING/LIN/zpot06.f +++ b/lapack-netlib/TESTING/LIN/zpot06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -127,10 +127,10 @@ SUBROUTINE ZPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zppt01.f b/lapack-netlib/TESTING/LIN/zppt01.f index 142bd74dd3..74c6d5116b 100644 --- a/lapack-netlib/TESTING/LIN/zppt01.f +++ b/lapack-netlib/TESTING/LIN/zppt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPPT01( UPLO, N, A, AFAC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER N @@ -19,7 +19,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), AFAC( * ) * .. -* +* * *> \par Purpose: * ============= @@ -83,22 +83,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZPPT01( UPLO, N, A, AFAC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zppt02.f b/lapack-netlib/TESTING/LIN/zppt02.f index 796b24ea5b..1b8b841598 100644 --- a/lapack-netlib/TESTING/LIN/zppt02.f +++ b/lapack-netlib/TESTING/LIN/zppt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -123,10 +123,10 @@ SUBROUTINE ZPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zppt03.f b/lapack-netlib/TESTING/LIN/zppt03.f index d412add14a..94801d8f1e 100644 --- a/lapack-netlib/TESTING/LIN/zppt03.f +++ b/lapack-netlib/TESTING/LIN/zppt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDWORK, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), AINV( * ), WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -110,10 +110,10 @@ SUBROUTINE ZPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zppt05.f b/lapack-netlib/TESTING/LIN/zppt05.f index f795d1fca2..5ce08570bf 100644 --- a/lapack-netlib/TESTING/LIN/zppt05.f +++ b/lapack-netlib/TESTING/LIN/zppt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, * LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 AP( * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -157,10 +157,10 @@ SUBROUTINE ZPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, $ LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zpst01.f b/lapack-netlib/TESTING/LIN/zpst01.f index ea7a298020..3225b0ec2d 100644 --- a/lapack-netlib/TESTING/LIN/zpst01.f +++ b/lapack-netlib/TESTING/LIN/zpst01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, * PIV, RWORK, RESID, RANK ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION RESID * INTEGER LDA, LDAFAC, LDPERM, N, RANK @@ -22,7 +22,7 @@ * DOUBLE PRECISION RWORK( * ) * INTEGER PIV( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, $ PIV, RWORK, RESID, RANK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION RESID diff --git a/lapack-netlib/TESTING/LIN/zptt01.f b/lapack-netlib/TESTING/LIN/zptt01.f index cd90a767e3..c9244a6cfc 100644 --- a/lapack-netlib/TESTING/LIN/zptt01.f +++ b/lapack-netlib/TESTING/LIN/zptt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPTT01( N, D, E, DF, EF, WORK, RESID ) -* +* * .. Scalar Arguments .. * INTEGER N * DOUBLE PRECISION RESID @@ -18,7 +18,7 @@ * DOUBLE PRECISION D( * ), DF( * ) * COMPLEX*16 E( * ), EF( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -80,22 +80,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZPTT01( N, D, E, DF, EF, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER N diff --git a/lapack-netlib/TESTING/LIN/zptt02.f b/lapack-netlib/TESTING/LIN/zptt02.f index df66f0fa70..90dec3bc9d 100644 --- a/lapack-netlib/TESTING/LIN/zptt02.f +++ b/lapack-netlib/TESTING/LIN/zptt02.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPTT02( UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -19,7 +19,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,22 +103,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZPTT02( UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zptt05.f b/lapack-netlib/TESTING/LIN/zptt05.f index d478670b8a..f7f2bd2842 100644 --- a/lapack-netlib/TESTING/LIN/zptt05.f +++ b/lapack-netlib/TESTING/LIN/zptt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, * FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * INTEGER LDB, LDX, LDXACT, N, NRHS * .. @@ -19,7 +19,7 @@ * COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -150,10 +150,10 @@ SUBROUTINE ZPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, $ FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDB, LDX, LDXACT, N, NRHS diff --git a/lapack-netlib/TESTING/LIN/zqlt01.f b/lapack-netlib/TESTING/LIN/zqlt01.f index 4bf0ec3709..5442fcae80 100644 --- a/lapack-netlib/TESTING/LIN/zqlt01.f +++ b/lapack-netlib/TESTING/LIN/zqlt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqlt02.f b/lapack-netlib/TESTING/LIN/zqlt02.f index ad2cffdb05..35adae9307 100644 --- a/lapack-netlib/TESTING/LIN/zqlt02.f +++ b/lapack-netlib/TESTING/LIN/zqlt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqlt03.f b/lapack-netlib/TESTING/LIN/zqlt03.f index 0edde76fc5..6489fa924c 100644 --- a/lapack-netlib/TESTING/LIN/zqlt03.f +++ b/lapack-netlib/TESTING/LIN/zqlt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqpt01.f b/lapack-netlib/TESTING/LIN/zqpt01.f index 54cabe10a7..eea178a2e7 100644 --- a/lapack-netlib/TESTING/LIN/zqpt01.f +++ b/lapack-netlib/TESTING/LIN/zqpt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -107,12 +107,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -120,10 +120,10 @@ DOUBLE PRECISION FUNCTION ZQPT01( M, N, K, A, AF, LDA, TAU, JPVT, $ WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqrt01.f b/lapack-netlib/TESTING/LIN/zqrt01.f index c7b8617bb9..4c55daf9d4 100644 --- a/lapack-netlib/TESTING/LIN/zqrt01.f +++ b/lapack-netlib/TESTING/LIN/zqrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqrt01p.f b/lapack-netlib/TESTING/LIN/zqrt01p.f index 8fe6d81422..676db6f271 100644 --- a/lapack-netlib/TESTING/LIN/zqrt01p.f +++ b/lapack-netlib/TESTING/LIN/zqrt01p.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZQRT01P( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqrt02.f b/lapack-netlib/TESTING/LIN/zqrt02.f index 619e4a0f44..9ca1e66cf0 100644 --- a/lapack-netlib/TESTING/LIN/zqrt02.f +++ b/lapack-netlib/TESTING/LIN/zqrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -122,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -135,10 +135,10 @@ SUBROUTINE ZQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqrt03.f b/lapack-netlib/TESTING/LIN/zqrt03.f index ce5fe51c2c..d809399bbc 100644 --- a/lapack-netlib/TESTING/LIN/zqrt03.f +++ b/lapack-netlib/TESTING/LIN/zqrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zqrt04.f b/lapack-netlib/TESTING/LIN/zqrt04.f index 274c51a09b..580f86a6fc 100644 --- a/lapack-netlib/TESTING/LIN/zqrt04.f +++ b/lapack-netlib/TESTING/LIN/zqrt04.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT04(M,N,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER M, N, NB, LDT * .. Return values .. * DOUBLE PRECISION RESULT(6) -* +* * *> \par Purpose: * ============= @@ -54,17 +54,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -74,7 +74,7 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -87,10 +87,11 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * ===================================================================== * * .. -* .. Local allocatable arrays +* .. Local allocatable arrays COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) + DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) * * .. Parameters .. DOUBLE PRECISION ZERO @@ -105,17 +106,17 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH + DOUBLE PRECISION DLAMCH DOUBLE PRECISION ZLANGE, ZLANSY LOGICAL LSAME EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN * .. * .. Data statements .. - DATA ISEED / 1988, 1989, 1990, 1991 / -* + DATA ISEED / 1988, 1989, 1990, 1991 / +* EPS = DLAMCH( 'Epsilon' ) K = MIN(M,N) L = MAX(M,N) @@ -123,8 +124,8 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * * Dynamically allocate local arrays * - ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), - $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), + ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L), + $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), $ D(N,M), DF(N,M) ) * * Put random numbers into A and copy to AF @@ -178,7 +179,7 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * * Apply Q to C as Q*C * - CALL ZGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, + CALL ZGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |Q*C - Q*C| / |C| @@ -197,7 +198,7 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * * Apply Q to C as QT*C * - CALL ZGEMQRT( 'L', 'C', M, N, K, NB, AF, M, T, NB, CF, M, + CALL ZGEMQRT( 'L', 'C', M, N, K, NB, AF, M, T, NB, CF, M, $ WORK, INFO) * * Compute |QT*C - QT*C| / |C| @@ -208,7 +209,7 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -220,8 +221,8 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * * Apply Q to D as D*Q * - CALL ZGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL ZGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*Q - D*Q| / |D| * @@ -239,8 +240,8 @@ SUBROUTINE ZQRT04(M,N,NB,RESULT) * * Apply Q to D as D*QT * - CALL ZGEMQRT( 'R', 'C', N, M, K, NB, AF, M, T, NB, DF, N, - $ WORK, INFO) + CALL ZGEMQRT( 'R', 'C', N, M, K, NB, AF, M, T, NB, DF, N, + $ WORK, INFO) * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/zqrt05.f b/lapack-netlib/TESTING/LIN/zqrt05.f index 8080a4522a..1985ea5065 100644 --- a/lapack-netlib/TESTING/LIN/zqrt05.f +++ b/lapack-netlib/TESTING/LIN/zqrt05.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT05(M,N,L,NB,RESULT) -* +* * .. Scalar Arguments .. * INTEGER LWORK, M, N, L, NB, LDT * .. Return values .. * DOUBLE PRECISION RESULT(6) -* +* * *> \par Purpose: * ============= @@ -45,7 +45,7 @@ *> The number of rows of the upper trapezoidal part the *> lower test matrix. 0 <= L <= M. *> \endverbatim -*> +*> *> \param[in] NB *> \verbatim *> NB is INTEGER @@ -61,17 +61,17 @@ *> RESULT(2) = | I - Q^H Q | *> RESULT(3) = | Q C - Q C | *> RESULT(4) = | Q^H C - Q^H C | -*> RESULT(5) = | C Q - C Q | +*> RESULT(5) = | C Q - C Q | *> RESULT(6) = | C Q^H - C Q^H | *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \date April 2012 * @@ -81,7 +81,7 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) IMPLICIT NONE * -* -- LAPACK test routine (version 3.4.1) -- +* -- 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..-- * April 2012 @@ -92,12 +92,13 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) DOUBLE PRECISION RESULT(6) * * ===================================================================== -* +* * .. -* .. Local allocatable arrays +* .. Local allocatable arrays COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), - $ R(:,:), RWORK(:), WORK( : ), T(:,:), + $ R(:,:), WORK( : ), T(:,:), $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) + DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) * * .. Parameters .. DOUBLE PRECISION ZERO @@ -112,14 +113,14 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) INTEGER ISEED( 4 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH + DOUBLE PRECISION DLAMCH DOUBLE PRECISION ZLANGE, ZLANSY LOGICAL LSAME EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME * .. * .. Data statements .. DATA ISEED / 1988, 1989, 1990, 1991 / -* +* EPS = DLAMCH( 'Epsilon' ) K = N M2 = M+N @@ -133,7 +134,7 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) * Dynamically allocate all arrays * ALLOCATE(A(M2,N),AF(M2,N),Q(M2,M2),R(M2,M2),RWORK(M2), - $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), + $ WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N), $ D(N,M2),DF(N,M2) ) * * Put random stuff into A @@ -188,7 +189,7 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) * Compute |I - Q'*Q| and store in RESULT(2) * CALL ZLASET( 'Full', M2, M2, CZERO, ONE, R, M2 ) - CALL ZHERK( 'U', 'C', M2, M2, DREAL(-ONE), Q, M2, DREAL(ONE), + CALL ZHERK( 'U', 'C', M2, M2, DREAL(-ONE), Q, M2, DREAL(ONE), $ R, M2 ) RESID = ZLANSY( '1', 'Upper', M2, R, M2, RWORK ) RESULT( 2 ) = RESID / (EPS*MAX(1,M2)) @@ -223,7 +224,7 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) * Apply Q to C as QT*C * CALL ZTPMQRT( 'L','C',M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,M2, - $ CF(NP1,1),M2,WORK,INFO) + $ CF(NP1,1),M2,WORK,INFO) * * Compute |QT*C - QT*C| / |C| * @@ -233,7 +234,7 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) RESULT( 4 ) = RESID / (EPS*MAX(1,M2)*CNORM) ELSE RESULT( 4 ) = ZERO - END IF + END IF * * Generate random n-by-m matrix D and a copy DF * @@ -265,8 +266,8 @@ SUBROUTINE ZQRT05(M,N,L,NB,RESULT) * Apply Q to D as D*QT * CALL ZTPMQRT('R','C',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N, - $ DF(1,NP1),N,WORK,INFO) - + $ DF(1,NP1),N,WORK,INFO) + * * Compute |D*QT - D*QT| / |D| * diff --git a/lapack-netlib/TESTING/LIN/zqrt11.f b/lapack-netlib/TESTING/LIN/zqrt11.f index efb9a6edb5..c633df2f69 100644 --- a/lapack-netlib/TESTING/LIN/zqrt11.f +++ b/lapack-netlib/TESTING/LIN/zqrt11.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZQRT11( M, K, A, LDA, TAU, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M * .. * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -86,22 +86,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== DOUBLE PRECISION FUNCTION ZQRT11( M, K, A, LDA, TAU, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M diff --git a/lapack-netlib/TESTING/LIN/zqrt12.f b/lapack-netlib/TESTING/LIN/zqrt12.f index 08f5382348..5428adbf30 100644 --- a/lapack-netlib/TESTING/LIN/zqrt12.f +++ b/lapack-netlib/TESTING/LIN/zqrt12.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, * RWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION RWORK( * ), S( * ) * COMPLEX*16 A( LDA, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -84,12 +84,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -97,10 +97,10 @@ DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, $ RWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N @@ -195,7 +195,7 @@ DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, $ WORK( M*N+1 ), WORK( M*N+MN+1 ), $ WORK( M*N+2*MN+1 ), INFO ) CALL DBDSQR( 'Upper', MN, 0, 0, 0, RWORK( 1 ), RWORK( MN+1 ), - $ DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ), + $ DUMMY, MN, DUMMY, 1, DUMMY, MN, RWORK( 2*MN+1 ), $ INFO ) * IF( ISCL.EQ.1 ) THEN diff --git a/lapack-netlib/TESTING/LIN/zqrt13.f b/lapack-netlib/TESTING/LIN/zqrt13.f index edcbbdac17..4e693c14e3 100644 --- a/lapack-netlib/TESTING/LIN/zqrt13.f +++ b/lapack-netlib/TESTING/LIN/zqrt13.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER LDA, M, N, SCALE * DOUBLE PRECISION NORMA @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -79,22 +79,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZQRT13( SCALE, M, N, A, LDA, NORMA, ISEED ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, SCALE diff --git a/lapack-netlib/TESTING/LIN/zqrt14.f b/lapack-netlib/TESTING/LIN/zqrt14.f index 8eea029b4f..369efc07de 100644 --- a/lapack-netlib/TESTING/LIN/zqrt14.f +++ b/lapack-netlib/TESTING/LIN/zqrt14.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZQRT14( TRANS, M, N, NRHS, A, LDA, X, * LDX, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDX, LWORK, M, N, NRHS @@ -18,7 +18,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -103,12 +103,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -116,10 +116,10 @@ DOUBLE PRECISION FUNCTION ZQRT14( TRANS, M, N, NRHS, A, LDA, X, $ LDX, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zqrt15.f b/lapack-netlib/TESTING/LIN/zqrt15.f index 04ab8aca44..0d17313e8f 100644 --- a/lapack-netlib/TESTING/LIN/zqrt15.f +++ b/lapack-netlib/TESTING/LIN/zqrt15.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, * RANK, NORMA, NORMB, ISEED, WORK, LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE * DOUBLE PRECISION NORMA, NORMB @@ -20,7 +20,7 @@ * DOUBLE PRECISION S( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -149,10 +149,10 @@ SUBROUTINE ZQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, $ RANK, NORMA, NORMB, ISEED, WORK, LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE diff --git a/lapack-netlib/TESTING/LIN/zqrt16.f b/lapack-netlib/TESTING/LIN/zqrt16.f index 1b16c4cb6b..e62e9a51d3 100644 --- a/lapack-netlib/TESTING/LIN/zqrt16.f +++ b/lapack-netlib/TESTING/LIN/zqrt16.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDA, LDB, LDX, M, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -120,12 +120,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -133,10 +133,10 @@ SUBROUTINE ZQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS diff --git a/lapack-netlib/TESTING/LIN/zqrt17.f b/lapack-netlib/TESTING/LIN/zqrt17.f index 37030904ef..ff694c7a18 100644 --- a/lapack-netlib/TESTING/LIN/zqrt17.f +++ b/lapack-netlib/TESTING/LIN/zqrt17.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZQRT17( TRANS, IRESID, M, N, NRHS, A, * LDA, X, LDX, B, LDB, C, WORK, LWORK ) -* +* * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDB, * ), * $ WORK( LWORK ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -137,12 +137,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -150,10 +150,10 @@ DOUBLE PRECISION FUNCTION ZQRT17( TRANS, IRESID, M, N, NRHS, A, $ LDA, X, LDX, B, LDB, C, WORK, LWORK ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. CHARACTER TRANS @@ -172,8 +172,7 @@ DOUBLE PRECISION FUNCTION ZQRT17( TRANS, IRESID, M, N, NRHS, A, * .. * .. Local Scalars .. INTEGER INFO, ISCL, NCOLS, NROWS - DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX, - $ SMLNUM + DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) diff --git a/lapack-netlib/TESTING/LIN/zrqt01.f b/lapack-netlib/TESTING/LIN/zrqt01.f index 58db74dbdb..88075ed5e1 100644 --- a/lapack-netlib/TESTING/LIN/zrqt01.f +++ b/lapack-netlib/TESTING/LIN/zrqt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zrqt02.f b/lapack-netlib/TESTING/LIN/zrqt02.f index 1dbe3d5552..ed1b608b2b 100644 --- a/lapack-netlib/TESTING/LIN/zrqt02.f +++ b/lapack-netlib/TESTING/LIN/zrqt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ), * $ R( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zrqt03.f b/lapack-netlib/TESTING/LIN/zrqt03.f index 9b74a6bb27..fc7046278b 100644 --- a/lapack-netlib/TESTING/LIN/zrqt03.f +++ b/lapack-netlib/TESTING/LIN/zrqt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, * RWORK, RESULT ) -* +* * .. Scalar Arguments .. * INTEGER K, LDA, LWORK, M, N * .. @@ -19,7 +19,7 @@ * COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ), * $ Q( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -123,12 +123,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -136,10 +136,10 @@ SUBROUTINE ZRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, $ RWORK, RESULT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zrzt01.f b/lapack-netlib/TESTING/LIN/zrzt01.f index b67cb84fb2..8763840692 100644 --- a/lapack-netlib/TESTING/LIN/zrzt01.f +++ b/lapack-netlib/TESTING/LIN/zrzt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZRZT01( M, N, A, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. @@ -18,7 +18,7 @@ * COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ), * $ WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -85,12 +85,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -98,10 +98,10 @@ DOUBLE PRECISION FUNCTION ZRZT01( M, N, A, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zrzt02.f b/lapack-netlib/TESTING/LIN/zrzt02.f index 93c34cba31..373ced982d 100644 --- a/lapack-netlib/TESTING/LIN/zrzt02.f +++ b/lapack-netlib/TESTING/LIN/zrzt02.f @@ -2,22 +2,22 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION ZRZT02( M, N, AF, LDA, TAU, WORK, * LWORK ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LWORK, M, N * .. * .. Array Arguments .. * COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK ) * .. -* +* * *> \par Purpose: * ============= @@ -78,12 +78,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -91,10 +91,10 @@ DOUBLE PRECISION FUNCTION ZRZT02( M, N, AF, LDA, TAU, WORK, $ LWORK ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LWORK, M, N diff --git a/lapack-netlib/TESTING/LIN/zsbmv.f b/lapack-netlib/TESTING/LIN/zsbmv.f index f36bfe5e57..005e288e09 100644 --- a/lapack-netlib/TESTING/LIN/zsbmv.f +++ b/lapack-netlib/TESTING/LIN/zsbmv.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, * INCY ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INCX, INCY, K, LDA, N @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. -* +* * *> \par Purpose: * ============= @@ -139,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -152,10 +152,10 @@ SUBROUTINE ZSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zspt01.f b/lapack-netlib/TESTING/LIN/zspt01.f index 31505d6be3..d212929ad9 100644 --- a/lapack-netlib/TESTING/LIN/zspt01.f +++ b/lapack-netlib/TESTING/LIN/zspt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDC, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), AFAC( * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zspt02.f b/lapack-netlib/TESTING/LIN/zspt02.f index 059236f8b8..985fda0c57 100644 --- a/lapack-netlib/TESTING/LIN/zspt02.f +++ b/lapack-netlib/TESTING/LIN/zspt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,12 +110,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -123,10 +123,10 @@ SUBROUTINE ZSPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zspt03.f b/lapack-netlib/TESTING/LIN/zspt03.f index 28f5563234..d37ce53861 100644 --- a/lapack-netlib/TESTING/LIN/zspt03.f +++ b/lapack-netlib/TESTING/LIN/zspt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDW, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( * ), AINV( * ), WORK( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,12 +97,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -110,10 +110,10 @@ SUBROUTINE ZSPT03( UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zsyt01_3.f b/lapack-netlib/TESTING/LIN/zsyt01_3.f new file mode 100644 index 0000000000..8922940757 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zsyt01_3.f @@ -0,0 +1,253 @@ +*> \brief \b ZSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by ZSYTRF_RK +*> (or ZSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZSYTRF_RK (or ZSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVSY_ROOK, ZSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVSY_ROOK again to multiply by U (or L ). +* + CALL ZLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of ZSYT01_3 +* + END diff --git a/lapack-netlib/TESTING/LIN/zsyt01_aa.f b/lapack-netlib/TESTING/LIN/zsyt01_aa.f new file mode 100644 index 0000000000..11d2e2fb53 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zsyt01_aa.f @@ -0,0 +1,265 @@ +*> \brief \b ZSYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYT01 reconstructs a hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by ZSYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZSYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is COMPLEX*16 +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +* @generated from LIN/dsyt01_aa.f, fortran d -> z, Thu Nov 17 13:01:50 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- 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 .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) + DOUBLE PRECISION RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = 0.0E+0, CONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVSY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL ZLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL ZLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF +* +* Call ZTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call ZTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL ZTRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF + ENDIF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of ZSYT01 +* + END diff --git a/lapack-netlib/TESTING/LIN/zsyt02.f b/lapack-netlib/TESTING/LIN/zsyt02.f index d8246b55ff..6f7d2498fc 100644 --- a/lapack-netlib/TESTING/LIN/zsyt02.f +++ b/lapack-netlib/TESTING/LIN/zsyt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -114,12 +114,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -127,10 +127,10 @@ SUBROUTINE ZSYT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zsyt03.f b/lapack-netlib/TESTING/LIN/zsyt03.f index fe164abc47..f63f016457 100644 --- a/lapack-netlib/TESTING/LIN/zsyt03.f +++ b/lapack-netlib/TESTING/LIN/zsyt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, * RWORK, RCOND, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAINV, LDWORK, N @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ), * $ WORK( LDWORK, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, $ RWORK, RCOND, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/ztbt02.f b/lapack-netlib/TESTING/LIN/ztbt02.f index d3784e00d7..a86923321b 100644 --- a/lapack-netlib/TESTING/LIN/ztbt02.f +++ b/lapack-netlib/TESTING/LIN/ztbt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, * LDX, B, LDB, WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -148,12 +148,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -161,10 +161,10 @@ SUBROUTINE ZTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, $ LDX, B, LDB, WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztbt03.f b/lapack-netlib/TESTING/LIN/ztbt03.f index e62eb17972..e33bff71cd 100644 --- a/lapack-netlib/TESTING/LIN/ztbt03.f +++ b/lapack-netlib/TESTING/LIN/ztbt03.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, * SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, * RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, N, NRHS @@ -22,7 +22,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -177,10 +177,10 @@ SUBROUTINE ZTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, $ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, $ RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztbt05.f b/lapack-netlib/TESTING/LIN/ztbt05.f index 8765edb3f2..1adeafdd44 100644 --- a/lapack-netlib/TESTING/LIN/ztbt05.f +++ b/lapack-netlib/TESTING/LIN/ztbt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -176,12 +176,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -189,10 +189,10 @@ SUBROUTINE ZTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztbt06.f b/lapack-netlib/TESTING/LIN/ztbt06.f index f4156fa911..8c59151f9d 100644 --- a/lapack-netlib/TESTING/LIN/ztbt06.f +++ b/lapack-netlib/TESTING/LIN/ztbt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, * RWORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER KD, LDAB, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AB( LDAB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, $ RWORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztpt01.f b/lapack-netlib/TESTING/LIN/ztpt01.f index b34cfe4f23..39a3922bbb 100644 --- a/lapack-netlib/TESTING/LIN/ztpt01.f +++ b/lapack-netlib/TESTING/LIN/ztpt01.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -19,7 +19,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AINVP( * ), AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -97,22 +97,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztpt02.f b/lapack-netlib/TESTING/LIN/ztpt02.f index a7041bd91a..31dec79771 100644 --- a/lapack-netlib/TESTING/LIN/ztpt02.f +++ b/lapack-netlib/TESTING/LIN/ztpt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, * WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -136,12 +136,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -149,10 +149,10 @@ SUBROUTINE ZTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, $ WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztpt03.f b/lapack-netlib/TESTING/LIN/ztpt03.f index bc617f1a03..fb8c814e15 100644 --- a/lapack-netlib/TESTING/LIN/ztpt03.f +++ b/lapack-netlib/TESTING/LIN/ztpt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, * TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, N, NRHS @@ -20,7 +20,7 @@ * DOUBLE PRECISION CNORM( * ) * COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -149,12 +149,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -162,10 +162,10 @@ SUBROUTINE ZTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, $ TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztpt05.f b/lapack-netlib/TESTING/LIN/ztpt05.f index da65cec95e..aa2348ae61 100644 --- a/lapack-netlib/TESTING/LIN/ztpt05.f +++ b/lapack-netlib/TESTING/LIN/ztpt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 AP( * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -162,12 +162,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -175,10 +175,10 @@ SUBROUTINE ZTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztpt06.f b/lapack-netlib/TESTING/LIN/ztpt06.f index 7458fa79be..30edfca71d 100644 --- a/lapack-netlib/TESTING/LIN/ztpt06.f +++ b/lapack-netlib/TESTING/LIN/ztpt06.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER N @@ -19,7 +19,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 AP( * ) * .. -* +* * *> \par Purpose: * ============= @@ -100,22 +100,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztrt01.f b/lapack-netlib/TESTING/LIN/ztrt01.f index bbf3edb923..99aa9db49c 100644 --- a/lapack-netlib/TESTING/LIN/ztrt01.f +++ b/lapack-netlib/TESTING/LIN/ztrt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, LDAINV, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -125,10 +125,10 @@ SUBROUTINE ZTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztrt02.f b/lapack-netlib/TESTING/LIN/ztrt02.f index 948a5d25b0..63e12c55a2 100644 --- a/lapack-netlib/TESTING/LIN/ztrt02.f +++ b/lapack-netlib/TESTING/LIN/ztrt02.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, * LDB, WORK, RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -144,12 +144,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -157,10 +157,10 @@ SUBROUTINE ZTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, $ LDB, WORK, RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztrt03.f b/lapack-netlib/TESTING/LIN/ztrt03.f index 2f368c5826..84aaf65eae 100644 --- a/lapack-netlib/TESTING/LIN/ztrt03.f +++ b/lapack-netlib/TESTING/LIN/ztrt03.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, * CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, N, NRHS @@ -21,7 +21,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), * $ X( LDX, * ) * .. -* +* * *> \par Purpose: * ============= @@ -158,12 +158,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -171,10 +171,10 @@ SUBROUTINE ZTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, $ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztrt05.f b/lapack-netlib/TESTING/LIN/ztrt05.f index 9082503f63..f31d614dc7 100644 --- a/lapack-netlib/TESTING/LIN/ztrt05.f +++ b/lapack-netlib/TESTING/LIN/ztrt05.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, XACT, LDXACT, FERR, BERR, RESLTS ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER LDA, LDB, LDX, LDXACT, N, NRHS @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ), * $ XACT( LDXACT, * ) * .. -* +* * *> \par Purpose: * ============= @@ -169,12 +169,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -182,10 +182,10 @@ SUBROUTINE ZTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, XACT, LDXACT, FERR, BERR, RESLTS ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztrt06.f b/lapack-netlib/TESTING/LIN/ztrt06.f index 7eecfec53b..2f5f5996bb 100644 --- a/lapack-netlib/TESTING/LIN/ztrt06.f +++ b/lapack-netlib/TESTING/LIN/ztrt06.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, * RAT ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER LDA, N @@ -20,7 +20,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_lin * @@ -122,10 +122,10 @@ SUBROUTINE ZTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, $ RAT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff --git a/lapack-netlib/TESTING/LIN/ztsqr01.f b/lapack-netlib/TESTING/LIN/ztsqr01.f new file mode 100644 index 0000000000..0944738886 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ztsqr01.f @@ -0,0 +1,462 @@ +*> \brief \b ZTSQR01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTSQR01(TSSW, M,N, MB, NB, RESULT) +* +* .. Scalar Arguments .. +* INTEGER M, N, MB +* .. Return values .. +* DOUBLE PRECISION RESULT(6) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTSQR01 tests ZGEQR , ZGELQ, ZGEMLQ and ZGEMQR. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TSSW +*> \verbatim +*> TSSW is CHARACTER +*> 'TS' for testing tall skinny QR +*> and anything else for testing short wide LQ +*> \endverbatim +*> \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] MB +*> \verbatim +*> MB is INTEGER +*> Number of row in row block in test matrix. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Number of columns in column block test matrix. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (6) +*> Results of each of the six tests below. +*> +*> RESULT(1) = | A - Q R | or | A - L Q | +*> RESULT(2) = | I - Q^H Q | or | I - Q Q^H | +*> RESULT(3) = | Q C - Q C | +*> RESULT(4) = | Q^H C - Q^H C | +*> RESULT(5) = | C Q - C Q | +*> RESULT(6) = | C Q^H - C Q^H | +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +* ===================================================================== + SUBROUTINE ZTSQR01(TSSW, M, N, MB, NB, RESULT) + 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..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER TSSW + INTEGER M, N, MB, NB +* .. Return values .. + DOUBLE PRECISION RESULT(6) +* +* ===================================================================== +* +* .. +* .. Local allocatable arrays + COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:), + $ R(:,:), RWORK(:), WORK( : ), T(:), + $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:) +* +* .. Parameters .. + DOUBLE PRECISION ZERO + COMPLEX*16 ONE, CZERO + PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) ) +* .. +* .. Local Scalars .. + LOGICAL TESTZEROS, TS + INTEGER INFO, J, K, L, LWORK, TSIZE, MNB + DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ) + COMPLEX*16 TQUERY( 5 ), WORKQUERY +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL DLAMCH, ZLANGE, ZLANSY, LSAME, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + CHARACTER*32 srnamt +* .. +* .. Common blocks .. + COMMON / srnamc / srnamt +* .. +* .. Data statements .. + DATA ISEED / 1988, 1989, 1990, 1991 / +* +* TEST TALL SKINNY OR SHORT WIDE +* + TS = LSAME(TSSW, 'TS') +* +* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS +* + TESTZEROS = .FALSE. +* + EPS = DLAMCH( 'Epsilon' ) + K = MIN(M,N) + L = MAX(M,N,1) + MNB = MAX ( MB, NB) + LWORK = MAX(3,L)*MNB +* +* 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), LQ(L,N) ) +* +* 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 ) +* + IF (TS) THEN +* +* Factor the matrix A in the array AF. +* + CALL ZGEQR( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'ZGEQR' + CALL ZGEQR( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* Generate the m-by-m matrix Q +* + CALL ZLASET( 'Full', M, M, CZERO, ONE, Q, M ) + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'N', M, M, K, AF, M, T, TSIZE, Q, M, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, R, M ) + CALL ZLACPY( 'Upper', M, N, AF, M, R, M ) +* +* Compute |R - Q'*A| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, 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 +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', M, M, CZERO, ONE, R, M ) + CALL ZHERK( 'U', 'C', M, M, DREAL(-ONE), Q, M, DREAL(ONE), R, M ) + RESID = ZLANSY( '1', 'Upper', M, R, M, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,M)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |Q*C - Q*C| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, 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 QT*C +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'L', 'C', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |QT*C - QT*C| / |C| +* + CALL ZGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, 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 +* + srnamt = 'ZGEMQR' + CALL ZGEMQR( 'R', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*Q - D*Q| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, 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 +* + CALL ZGEMQR( 'R', 'C', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |D*QT - D*QT| / |D| +* + CALL ZGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* +* Short and wide +* + ELSE + CALL ZGELQ( M, N, AF, M, TQUERY, -1, WORKQUERY, -1, INFO ) + TSIZE = INT( TQUERY( 1 ) ) + LWORK = INT( WORKQUERY ) + CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, TQUERY, TSIZE, Q, N, + $ WORKQUERY, -1, INFO ) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, TQUERY, TSIZE, DF, N, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, TQUERY, TSIZE, CF, M, + $ WORKQUERY, -1, INFO) + LWORK = MAX( LWORK, INT( WORKQUERY ) ) + ALLOCATE ( T( TSIZE ) ) + ALLOCATE ( WORK( LWORK ) ) + srnamt = 'ZGELQ' + CALL ZGELQ( M, N, AF, M, T, TSIZE, WORK, LWORK, INFO ) +* +* +* Generate the n-by-n matrix Q +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, Q, N ) + srnamt = 'ZGEMLQ' + CALL ZGEMLQ( 'R', 'N', N, N, K, AF, M, T, TSIZE, Q, N, + $ WORK, LWORK, INFO ) +* +* Copy R +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, LQ, L ) + CALL ZLACPY( 'Lower', M, N, AF, M, LQ, L ) +* +* Compute |L - A*Q'| / |A| and store in RESULT(1) +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, LQ, L ) + ANORM = ZLANGE( '1', M, N, A, M, RWORK ) + RESID = ZLANGE( '1', M, N, LQ, L, RWORK ) + IF( ANORM.GT.ZERO ) THEN + RESULT( 1 ) = RESID / (EPS*MAX(1,N)*ANORM) + ELSE + RESULT( 1 ) = ZERO + END IF +* +* Compute |I - Q'*Q| and store in RESULT(2) +* + CALL ZLASET( 'Full', N, N, CZERO, ONE, LQ, L ) + CALL ZHERK( 'U', 'C', N, N, DREAL(-ONE), Q, N, DREAL(ONE), LQ, L) + RESID = ZLANSY( '1', 'Upper', N, LQ, L, RWORK ) + RESULT( 2 ) = RESID / (EPS*MAX(1,N)) +* +* Generate random m-by-n matrix C and a copy CF +* + 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 C as Q*C +* + CALL ZGEMLQ( 'L', 'N', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |Q*D - Q*D| / |D| +* + CALL ZGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 3 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 3 ) = ZERO + END IF +* +* Copy D into DF again +* + CALL ZLACPY( 'Full', N, M, D, N, DF, N ) +* +* Apply Q to D as QT*D +* + CALL ZGEMLQ( 'L', 'C', N, M, K, AF, M, T, TSIZE, DF, N, + $ WORK, LWORK, INFO) +* +* Compute |QT*D - QT*D| / |D| +* + CALL ZGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( DNORM.GT.ZERO ) THEN + RESULT( 4 ) = RESID / (EPS*MAX(1,N)*DNORM) + ELSE + RESULT( 4 ) = ZERO + END IF +* +* Generate random n-by-m matrix D and a copy DF +* + 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 C*Q +* + CALL ZGEMLQ( 'R', 'N', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*Q - C*Q| / |C| +* + CALL ZGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', N, M, DF, N, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 5 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 5 ) = ZERO + END IF +* +* Copy C into CF again +* + CALL ZLACPY( 'Full', M, N, C, M, CF, M ) +* +* Apply Q to D as D*QT +* + CALL ZGEMLQ( 'R', 'C', M, N, K, AF, M, T, TSIZE, CF, M, + $ WORK, LWORK, INFO) +* +* Compute |C*QT - C*QT| / |C| +* + CALL ZGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) + RESID = ZLANGE( '1', M, N, CF, M, RWORK ) + IF( CNORM.GT.ZERO ) THEN + RESULT( 6 ) = RESID / (EPS*MAX(1,N)*CNORM) + ELSE + RESULT( 6 ) = ZERO + END IF +* + END IF +* +* Deallocate all arrays +* + DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF) +* + RETURN + END diff --git a/lapack-netlib/TESTING/MATGEN/CMakeLists.txt b/lapack-netlib/TESTING/MATGEN/CMakeLists.txt index 55258ddd0b..09b6e3b4bd 100644 --- a/lapack-netlib/TESTING/MATGEN/CMakeLists.txt +++ b/lapack-netlib/TESTING/MATGEN/CMakeLists.txt @@ -30,25 +30,25 @@ # make single FRC=FRC # ####################################################################### - -set(SCATGEN slatm1.f slaran.f slarnd.f) -set(SMATGEN slatms.f slatme.f slatmr.f slatmt.f - slagge.f slagsy.f slakf2.f slarge.f slaror.f slarot.f slatm2.f +set(SCATGEN slatm1.f slaran.f slarnd.f) + +set(SMATGEN slatms.f slatme.f slatmr.f slatmt.f + slagge.f slagsy.f slakf2.f slarge.f slaror.f slarot.f slatm2.f slatm3.f slatm5.f slatm6.f slatm7.f slahilb.f) -set(CMATGEN clatms.f clatme.f clatmr.f clatmt.f - clagge.f claghe.f clagsy.f clakf2.f clarge.f claror.f clarot.f +set(CMATGEN clatms.f clatme.f clatmr.f clatmt.f + clagge.f claghe.f clagsy.f clakf2.f clarge.f claror.f clarot.f clatm1.f clarnd.f clatm2.f clatm3.f clatm5.f clatm6.f clahilb.f slatm7.f) -set(DZATGEN dlatm1.f dlaran.f dlarnd.f) +set(DZATGEN dlatm1.f dlaran.f dlarnd.f) -set(DMATGEN dlatms.f dlatme.f dlatmr.f dlatmt.f - dlagge.f dlagsy.f dlakf2.f dlarge.f dlaror.f dlarot.f dlatm2.f +set(DMATGEN dlatms.f dlatme.f dlatmr.f dlatmt.f + dlagge.f dlagsy.f dlakf2.f dlarge.f dlaror.f dlarot.f dlatm2.f dlatm3.f dlatm5.f dlatm6.f dlatm7.f dlahilb.f) -set(ZMATGEN zlatms.f zlatme.f zlatmr.f zlatmt.f - zlagge.f zlaghe.f zlagsy.f zlakf2.f zlarge.f zlaror.f zlarot.f +set(ZMATGEN zlatms.f zlatme.f zlatmr.f zlatmt.f + zlagge.f zlaghe.f zlagsy.f zlakf2.f zlarge.f zlaror.f zlarot.f zlatm1.f zlarnd.f zlatm2.f zlatm3.f zlatm5.f zlatm6.f zlahilb.f dlatm7.f) if(BUILD_SINGLE) @@ -58,18 +58,18 @@ if(BUILD_DOUBLE) set(ALLOBJ ${ALLOBJ} ${DMATGEN} ${DZATGEN}) endif() if(BUILD_COMPLEX) - set(ALLOBJ ${ALLOBJ} ${CMATGEN} ${SCATGEN}) + set(ALLOBJ ${ALLOBJ} ${CMATGEN} ${SCATGEN}) endif() if(BUILD_COMPLEX16) set(ALLOBJ ${ALLOBJ} ${ZMATGEN} ${DZATGEN}) endif() -if (NOT ALLOBJ) -set(ALLOBJ ${SMATGEN} ${CMATGEN} ${SCATGEN} ${DMATGEN} ${ZMATGEN} - ${DZATGEN}) +if(NOT ALLOBJ) + set(ALLOBJ ${SMATGEN} ${CMATGEN} ${SCATGEN} ${DMATGEN} ${ZMATGEN} + ${DZATGEN}) else() list(REMOVE_DUPLICATES ALLOBJ) endif() -add_library(tmglib ${ALLOBJ} ) +add_library(tmglib ${ALLOBJ}) target_link_libraries(tmglib ${LAPACK_LIBRARIES}) lapack_install_library(tmglib) diff --git a/lapack-netlib/TESTING/MATGEN/Makefile b/lapack-netlib/TESTING/MATGEN/Makefile index ecd9aa5c16..34a6ff07eb 100644 --- a/lapack-netlib/TESTING/MATGEN/Makefile +++ b/lapack-netlib/TESTING/MATGEN/Makefile @@ -32,7 +32,7 @@ include ../../make.inc # make single FRC=FRC # ####################################################################### - + SCATGEN = slatm1.o slaran.o slarnd.o SMATGEN = slatms.o slatme.o slatmr.o slatmt.o \ @@ -53,9 +53,9 @@ ZMATGEN = zlatms.o zlatme.o zlatmr.o zlatmt.o \ zlagge.o zlaghe.o zlagsy.o zlakf2.o zlarge.o zlaror.o zlarot.o \ zlatm1.o zlarnd.o zlatm2.o zlatm3.o zlatm5.o zlatm6.o zlahilb.o -all: ../../$(TMGLIB) +all: ../../$(TMGLIB) -ALLOBJ = $(SMATGEN) $(CMATGEN) $(SCATGEN) $(DMATGEN) $(ZMATGEN) \ +ALLOBJ = $(SMATGEN) $(CMATGEN) $(SCATGEN) $(DMATGEN) $(ZMATGEN) \ $(DZATGEN) ../../$(TMGLIB): $(ALLOBJ) @@ -84,7 +84,7 @@ $(CMATGEN): $(FRC) $(DZATGEN): $(FRC) $(DMATGEN): $(FRC) $(ZMATGEN): $(FRC) - + FRC: @FRC=$(FRC) @@ -92,7 +92,7 @@ clean: rm -f *.o .f.o: - $(FORTRAN) $(OPTS) -c $< -o $@ + $(FORTRAN) $(OPTS) -c -o $@ $< -slaran.o: slaran.f ; $(FORTRAN) $(NOOPT) -c $< -dlaran.o: dlaran.f ; $(FORTRAN) $(NOOPT) -c $< +slaran.o: slaran.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< +dlaran.o: dlaran.f ; $(FORTRAN) $(NOOPT) -c -o $@ $< diff --git a/lapack-netlib/TESTING/MATGEN/clagge.f b/lapack-netlib/TESTING/MATGEN/clagge.f index a11b636291..f0d86fb50e 100644 --- a/lapack-netlib/TESTING/MATGEN/clagge.f +++ b/lapack-netlib/TESTING/MATGEN/clagge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDA, M, N * .. @@ -18,7 +18,7 @@ * REAL D( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N diff --git a/lapack-netlib/TESTING/MATGEN/claghe.f b/lapack-netlib/TESTING/MATGEN/claghe.f index 0e07ab5422..70a1620246 100644 --- a/lapack-netlib/TESTING/MATGEN/claghe.f +++ b/lapack-netlib/TESTING/MATGEN/claghe.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -18,7 +18,7 @@ * REAL D( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/clagsy.f b/lapack-netlib/TESTING/MATGEN/clagsy.f index aa0d8fd4b5..8c3885464d 100644 --- a/lapack-netlib/TESTING/MATGEN/clagsy.f +++ b/lapack-netlib/TESTING/MATGEN/clagsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -18,7 +18,7 @@ * REAL D( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/clahilb.f b/lapack-netlib/TESTING/MATGEN/clahilb.f index f318ee53e4..612c6c68f5 100644 --- a/lapack-netlib/TESTING/MATGEN/clahilb.f +++ b/lapack-netlib/TESTING/MATGEN/clahilb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, +* SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, * INFO, PATH) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. @@ -18,7 +18,7 @@ * COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -121,23 +121,23 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== - SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, + SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, $ INFO, PATH) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO @@ -165,15 +165,15 @@ SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) * d's are generated from random permuation 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 D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), $ (-.5,-.5),(.5,-.5),(.5,.5)/ DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), $ (-.5,.5),(.5,.5),(.5,-.5)/ - + * .. * .. External Functions EXTERNAL CLASET, LSAMEN @@ -221,7 +221,7 @@ SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, END DO * Generate the scaled Hilbert matrix in A -* If we are testing SY routines, take +* If we are testing SY routines, take * D1_i = D2_i, else, D1_i = D2_i* IF ( LSAMEN( 2, C2, 'SY' ) ) THEN DO J = 1, N @@ -252,15 +252,15 @@ SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) $ * (N +J -1) END DO - -* If we are testing SY routines, + +* If we are testing SY routines, * take D1_i = D2_i, else, D1_i = D2_i* IF ( LSAMEN( 2, C2, 'SY' ) ) THEN DO J = 1, NRHS DO I = 1, N - X(I, J) = + X(I, J) = $ INVD1(MOD(J,SIZE_D)+1) * - $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ ((WORK(I)*WORK(J)) / (I + J - 1)) $ * INVD1(MOD(I,SIZE_D)+1) END DO END DO @@ -275,4 +275,4 @@ SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, END DO END IF END - + diff --git a/lapack-netlib/TESTING/MATGEN/clakf2.f b/lapack-netlib/TESTING/MATGEN/clakf2.f index 524d2c5355..9c87e4ccdd 100644 --- a/lapack-netlib/TESTING/MATGEN/clakf2.f +++ b/lapack-netlib/TESTING/MATGEN/clakf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDZ, M, N * .. @@ -17,7 +17,7 @@ * COMPLEX A( LDA, * ), B( LDA, * ), D( LDA, * ), * $ E( LDA, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDZ, M, N diff --git a/lapack-netlib/TESTING/MATGEN/clarge.f b/lapack-netlib/TESTING/MATGEN/clarge.f index 9a186353d7..4c1d471370 100644 --- a/lapack-netlib/TESTING/MATGEN/clarge.f +++ b/lapack-netlib/TESTING/MATGEN/clarge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/clarnd.f b/lapack-netlib/TESTING/MATGEN/clarnd.f index 0490597c86..2236a2c7c1 100644 --- a/lapack-netlib/TESTING/MATGEN/clarnd.f +++ b/lapack-netlib/TESTING/MATGEN/clarnd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX FUNCTION CLARND( IDIST, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER IDIST * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -53,12 +53,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -75,10 +75,10 @@ * ===================================================================== COMPLEX FUNCTION CLARND( IDIST, ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST diff --git a/lapack-netlib/TESTING/MATGEN/claror.f b/lapack-netlib/TESTING/MATGEN/claror.f index 7684290763..6870c321aa 100644 --- a/lapack-netlib/TESTING/MATGEN/claror.f +++ b/lapack-netlib/TESTING/MATGEN/claror.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER INIT, SIDE * INTEGER INFO, LDA, M, N @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -70,7 +70,7 @@ *> columns will be orthogonal, the remaining columns being *> zero. *> For matrices where M > N, just use the previous -*> explaination, interchanging 'L' and 'R' and "rows" and +*> explanation, interchanging 'L' and 'R' and "rows" and *> "columns". *> *> Not modified. @@ -146,22 +146,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER INIT, SIDE diff --git a/lapack-netlib/TESTING/MATGEN/clarot.f b/lapack-netlib/TESTING/MATGEN/clarot.f index db93b3d448..b899c82745 100644 --- a/lapack-netlib/TESTING/MATGEN/clarot.f +++ b/lapack-netlib/TESTING/MATGEN/clarot.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, * XRIGHT ) -* +* * .. Scalar Arguments .. * LOGICAL LLEFT, LRIGHT, LROWS * INTEGER LDA, NL @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -216,12 +216,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -229,10 +229,10 @@ SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS diff --git a/lapack-netlib/TESTING/MATGEN/clatm1.f b/lapack-netlib/TESTING/MATGEN/clatm1.f index 2cc0c4d9c9..48d49897b3 100644 --- a/lapack-netlib/TESTING/MATGEN/clatm1.f +++ b/lapack-netlib/TESTING/MATGEN/clatm1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, INFO, IRSIGN, MODE, N * REAL COND @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,22 +125,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N diff --git a/lapack-netlib/TESTING/MATGEN/clatm2.f b/lapack-netlib/TESTING/MATGEN/clatm2.f index 588caaa418..01221e0cc1 100644 --- a/lapack-netlib/TESTING/MATGEN/clatm2.f +++ b/lapack-netlib/TESTING/MATGEN/clatm2.f @@ -2,27 +2,27 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D, * IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N * REAL SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * COMPLEX D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -30,7 +30,7 @@ *> \verbatim *> *> CLATM2 returns the (I,J) entry of a random matrix of dimension -*> (M, N) described by the other paramters. It is called by the +*> (M, N) described by the other parameters. It is called by the *> CLATMR routine in order to build random test matrices. No error *> checking on parameters is done, because this routine is called in *> a tight loop by CLATMR which has already checked the parameters. @@ -199,12 +199,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_matgen * @@ -212,10 +212,10 @@ COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D, $ IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/clatm3.f b/lapack-netlib/TESTING/MATGEN/clatm3.f index d3073bef79..3e07f3ec0a 100644 --- a/lapack-netlib/TESTING/MATGEN/clatm3.f +++ b/lapack-netlib/TESTING/MATGEN/clatm3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,20 +11,20 @@ * COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, * ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, * SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, * $ KU, M, N * REAL SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * COMPLEX D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -32,7 +32,7 @@ *> \verbatim *> *> CLATM3 returns the (ISUB,JSUB) entry of a random matrix of -*> dimension (M, N) described by the other paramters. (ISUB,JSUB) +*> dimension (M, N) described by the other parameters. (ISUB,JSUB) *> is the final position of the (I,J) entry after pivoting *> according to IPVTNG and IWORK. CLATM3 is called by the *> CLATMR routine in order to build random test matrices. No error @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_matgen * @@ -229,10 +229,10 @@ COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/clatm5.f b/lapack-netlib/TESTING/MATGEN/clatm5.f index 3f3eb956c9..8b3fe50d9e 100644 --- a/lapack-netlib/TESTING/MATGEN/clatm5.f +++ b/lapack-netlib/TESTING/MATGEN/clatm5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, * E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, * QBLCKB ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, * $ PRTYPE, QBLCKA, QBLCKB @@ -22,7 +22,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ L( LDL, * ), R( LDR, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,8 +48,8 @@ *> \param[in] PRTYPE *> \verbatim *> PRTYPE is INTEGER -*> "Points" to a certian type of the matrices to generate -*> (see futher details). +*> "Points" to a certain type of the matrices to generate +*> (see further details). *> \endverbatim *> *> \param[in] M @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex_matgen * @@ -268,10 +268,10 @@ SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, $ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, $ QBLCKB ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, diff --git a/lapack-netlib/TESTING/MATGEN/clatm6.f b/lapack-netlib/TESTING/MATGEN/clatm6.f index 1f80914d98..74684dbcf6 100644 --- a/lapack-netlib/TESTING/MATGEN/clatm6.f +++ b/lapack-netlib/TESTING/MATGEN/clatm6.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, * BETA, WX, WY, S, DIF ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, N, TYPE * COMPLEX ALPHA, BETA, WX, WY @@ -20,7 +20,7 @@ * COMPLEX A( LDA, * ), B( LDA, * ), X( LDX, * ), * $ Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,7 +71,7 @@ *> \param[in] TYPE *> \verbatim *> TYPE is INTEGER -*> Specifies the problem type (see futher details). +*> Specifies the problem type (see further details). *> \endverbatim *> *> \param[in] N @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -174,10 +174,10 @@ SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, $ BETA, WX, WY, S, DIF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, N, TYPE diff --git a/lapack-netlib/TESTING/MATGEN/clatme.f b/lapack-netlib/TESTING/MATGEN/clatme.f index eaceaa9399..a06f9bfbd6 100644 --- a/lapack-netlib/TESTING/MATGEN/clatme.f +++ b/lapack-netlib/TESTING/MATGEN/clatme.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX, -* RSIGN, -* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, -* A, +* RSIGN, +* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, +* A, * LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, RSIGN, SIM, UPPER * INTEGER INFO, KL, KU, LDA, MODE, MODES, N @@ -25,7 +25,7 @@ * REAL DS( * ) * COMPLEX A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -285,26 +285,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * * ===================================================================== SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX, - $ RSIGN, - $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, - $ A, + $ RSIGN, + $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, + $ A, $ LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER diff --git a/lapack-netlib/TESTING/MATGEN/clatmr.f b/lapack-netlib/TESTING/MATGEN/clatmr.f index 5af9118252..11d29a3d08 100644 --- a/lapack-netlib/TESTING/MATGEN/clatmr.f +++ b/lapack-netlib/TESTING/MATGEN/clatmr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, * CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, * PACK, A, LDA, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N @@ -23,7 +23,7 @@ * INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) * COMPLEX A( LDA, * ), D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -475,12 +475,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -490,10 +490,10 @@ SUBROUTINE CLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM diff --git a/lapack-netlib/TESTING/MATGEN/clatms.f b/lapack-netlib/TESTING/MATGEN/clatms.f index 0b81865076..9516f227f4 100644 --- a/lapack-netlib/TESTING/MATGEN/clatms.f +++ b/lapack-netlib/TESTING/MATGEN/clatms.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, PACK, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, N @@ -21,7 +21,7 @@ * REAL D( * ) * COMPLEX A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -319,12 +319,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -332,10 +332,10 @@ SUBROUTINE CLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM diff --git a/lapack-netlib/TESTING/MATGEN/clatmt.f b/lapack-netlib/TESTING/MATGEN/clatmt.f index 3005439643..bdad1b7ba6 100644 --- a/lapack-netlib/TESTING/MATGEN/clatmt.f +++ b/lapack-netlib/TESTING/MATGEN/clatmt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * RANK, KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL COND, DMAX * INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK @@ -21,7 +21,7 @@ * REAL D( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -327,12 +327,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex_matgen * @@ -340,10 +340,10 @@ SUBROUTINE CLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RANK, KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL COND, DMAX diff --git a/lapack-netlib/TESTING/MATGEN/dlagge.f b/lapack-netlib/TESTING/MATGEN/dlagge.f index fac06d98fe..44b1c25b47 100644 --- a/lapack-netlib/TESTING/MATGEN/dlagge.f +++ b/lapack-netlib/TESTING/MATGEN/dlagge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N diff --git a/lapack-netlib/TESTING/MATGEN/dlagsy.f b/lapack-netlib/TESTING/MATGEN/dlagsy.f index b5c4881a11..1c811e9941 100644 --- a/lapack-netlib/TESTING/MATGEN/dlagsy.f +++ b/lapack-netlib/TESTING/MATGEN/dlagsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/dlahilb.f b/lapack-netlib/TESTING/MATGEN/dlahilb.f index 53ce063f5d..7b2badabcd 100644 --- a/lapack-netlib/TESTING/MATGEN/dlahilb.f +++ b/lapack-netlib/TESTING/MATGEN/dlahilb.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. * DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) * .. -* +* * *> \par Purpose: * ============= @@ -26,8 +26,8 @@ *> NRHS right-hand sides in B and solutions in X such that A*X=B. *> *> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all -*> entries are integers. The right-hand sides are the first NRHS -*> columns of M * the identity matrix, and the solutions are the +*> entries are integers. The right-hand sides are the first NRHS +*> columns of M * the identity matrix, and the solutions are the *> first NRHS columns of the inverse Hilbert matrix. *> *> The condition number of the Hilbert matrix grows exponentially with @@ -36,7 +36,7 @@ *> generated exactly without extra precision. Precision is exhausted *> when the largest entry in the inverse Hilbert matrix is greater than *> 2 to the power of the number of bits in the fraction of the data type -*> used plus one, which is 24 for single precision. +*> used plus one, which is 24 for single precision. *> *> In single, the generated solution is exact for N <= 6 and has *> small componentwise error for 7 <= N <= 11. @@ -50,7 +50,7 @@ *> N is INTEGER *> The dimension of the matrix A. *> \endverbatim -*> +*> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO @@ -212,7 +212,7 @@ SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) $ * (N +J -1) END DO - + DO J = 1, NRHS DO I = 1, N X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1) diff --git a/lapack-netlib/TESTING/MATGEN/dlakf2.f b/lapack-netlib/TESTING/MATGEN/dlakf2.f index 01da0bf547..d50b8ac9ac 100644 --- a/lapack-netlib/TESTING/MATGEN/dlakf2.f +++ b/lapack-netlib/TESTING/MATGEN/dlakf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDZ, M, N * .. @@ -17,7 +17,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDA, * ), D( LDA, * ), * $ E( LDA, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDZ, M, N diff --git a/lapack-netlib/TESTING/MATGEN/dlaran.f b/lapack-netlib/TESTING/MATGEN/dlaran.f index 6dbb051802..16c9bf1d08 100644 --- a/lapack-netlib/TESTING/MATGEN/dlaran.f +++ b/lapack-netlib/TESTING/MATGEN/dlaran.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLARAN( ISEED ) -* +* * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -39,12 +39,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup list_temp * @@ -67,10 +67,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DLARAN( ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Array Arguments .. INTEGER ISEED( 4 ) @@ -128,7 +128,7 @@ DOUBLE PRECISION FUNCTION DLARAN( ISEED ) * If a real number has n bits of precision, and the first * n bits of the 48-bit integer above happen to be all 1 (which * will occur about once every 2**n calls), then DLARAN will -* be rounded to exactly 1.0. +* be rounded to exactly 1.0. * Since DLARAN is not supposed to return exactly 0.0 or 1.0 * (and some callers of DLARAN, such as CLARND, depend on that), * the statistically correct thing to do in this situation is diff --git a/lapack-netlib/TESTING/MATGEN/dlarge.f b/lapack-netlib/TESTING/MATGEN/dlarge.f index 075cdac510..fc8bcc4bed 100644 --- a/lapack-netlib/TESTING/MATGEN/dlarge.f +++ b/lapack-netlib/TESTING/MATGEN/dlarge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/dlarnd.f b/lapack-netlib/TESTING/MATGEN/dlarnd.f index ee0f8302a6..cd7415cb7e 100644 --- a/lapack-netlib/TESTING/MATGEN/dlarnd.f +++ b/lapack-netlib/TESTING/MATGEN/dlarnd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER IDIST * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -51,12 +51,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -73,10 +73,10 @@ * ===================================================================== DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST diff --git a/lapack-netlib/TESTING/MATGEN/dlaror.f b/lapack-netlib/TESTING/MATGEN/dlaror.f index 5be36bd149..a48129d25f 100644 --- a/lapack-netlib/TESTING/MATGEN/dlaror.f +++ b/lapack-netlib/TESTING/MATGEN/dlaror.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER INIT, SIDE * INTEGER INFO, LDA, M, N @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,22 +134,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER INIT, SIDE diff --git a/lapack-netlib/TESTING/MATGEN/dlarot.f b/lapack-netlib/TESTING/MATGEN/dlarot.f index 3e5917cf46..6655fa4819 100644 --- a/lapack-netlib/TESTING/MATGEN/dlarot.f +++ b/lapack-netlib/TESTING/MATGEN/dlarot.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, * XRIGHT ) -* +* * .. Scalar Arguments .. * LOGICAL LLEFT, LRIGHT, LROWS * INTEGER LDA, NL @@ -19,7 +19,7 @@ * .. Array Arguments .. * DOUBLE PRECISION A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -226,10 +226,10 @@ SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS diff --git a/lapack-netlib/TESTING/MATGEN/dlatm1.f b/lapack-netlib/TESTING/MATGEN/dlatm1.f index e95ac83adf..cfb144b105 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm1.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, INFO, IRSIGN, MODE, N * DOUBLE PRECISION COND @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N diff --git a/lapack-netlib/TESTING/MATGEN/dlatm2.f b/lapack-netlib/TESTING/MATGEN/dlatm2.f index 87ef4f423b..446f5a8011 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm2.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm2.f @@ -2,27 +2,27 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, * ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N * DOUBLE PRECISION SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * DOUBLE PRECISION D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -30,7 +30,7 @@ *> \verbatim *> *> DLATM2 returns the (I,J) entry of a random matrix of dimension -*> (M, N) described by the other paramters. It is called by the +*> (M, N) described by the other parameters. It is called by the *> DLATMR routine in order to build random test matrices. No error *> checking on parameters is done, because this routine is called in *> a tight loop by DLATMR which has already checked the parameters. @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_matgen * @@ -208,10 +208,10 @@ DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/dlatm3.f b/lapack-netlib/TESTING/MATGEN/dlatm3.f index b2c49823ee..cf6da10f8d 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm3.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,20 +11,20 @@ * DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, * IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, * SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, * $ KU, M, N * DOUBLE PRECISION SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * DOUBLE PRECISION D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -32,7 +32,7 @@ *> \verbatim *> *> DLATM3 returns the (ISUB,JSUB) entry of a random matrix of -*> dimension (M, N) described by the other paramters. (ISUB,JSUB) +*> dimension (M, N) described by the other parameters. (ISUB,JSUB) *> is the final position of the (I,J) entry after pivoting *> according to IPVTNG and IWORK. DLATM3 is called by the *> DLATMR routine in order to build random test matrices. No error @@ -212,12 +212,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_matgen * @@ -226,10 +226,10 @@ DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/dlatm5.f b/lapack-netlib/TESTING/MATGEN/dlatm5.f index 9c8ee380f6..37076efc84 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm5.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, * E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, * QBLCKB ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, * $ PRTYPE, QBLCKA, QBLCKB @@ -22,7 +22,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ L( LDL, * ), R( LDR, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,8 +48,8 @@ *> \param[in] PRTYPE *> \verbatim *> PRTYPE is INTEGER -*> "Points" to a certian type of the matrices to generate -*> (see futher details). +*> "Points" to a certain type of the matrices to generate +*> (see further details). *> \endverbatim *> *> \param[in] M @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup double_matgen * @@ -268,10 +268,10 @@ SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, $ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, $ QBLCKB ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, diff --git a/lapack-netlib/TESTING/MATGEN/dlatm6.f b/lapack-netlib/TESTING/MATGEN/dlatm6.f index ca64f862fc..462cce0b70 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm6.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm6.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, * BETA, WX, WY, S, DIF ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, N, TYPE * DOUBLE PRECISION ALPHA, BETA, WX, WY @@ -19,7 +19,7 @@ * DOUBLE PRECISION A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), * $ X( LDX, * ), Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,7 +73,7 @@ *> \param[in] TYPE *> \verbatim *> TYPE is INTEGER -*> Specifies the problem type (see futher details). +*> Specifies the problem type (see further details). *> \endverbatim *> *> \param[in] N @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -176,10 +176,10 @@ SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, $ BETA, WX, WY, S, DIF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, N, TYPE diff --git a/lapack-netlib/TESTING/MATGEN/dlatm7.f b/lapack-netlib/TESTING/MATGEN/dlatm7.f index a8c1a0cce7..70c2f98ba1 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatm7.f +++ b/lapack-netlib/TESTING/MATGEN/dlatm7.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, * RANK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION COND * INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK @@ -19,7 +19,7 @@ * DOUBLE PRECISION D( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -122,10 +122,10 @@ SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, $ RANK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION COND diff --git a/lapack-netlib/TESTING/MATGEN/dlatme.f b/lapack-netlib/TESTING/MATGEN/dlatme.f index e1dce5fa3c..2d124ef1f6 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatme.f +++ b/lapack-netlib/TESTING/MATGEN/dlatme.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, -* RSIGN, -* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, -* A, +* SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, +* RSIGN, +* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, +* A, * LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, RSIGN, SIM, UPPER * INTEGER INFO, KL, KU, LDA, MODE, MODES, N @@ -24,7 +24,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -316,26 +316,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * * ===================================================================== - SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, - $ RSIGN, - $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, - $ A, + SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, + $ RSIGN, + $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, + $ A, $ LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER diff --git a/lapack-netlib/TESTING/MATGEN/dlatmr.f b/lapack-netlib/TESTING/MATGEN/dlatmr.f index d38fddff73..e7ea41907a 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatmr.f +++ b/lapack-netlib/TESTING/MATGEN/dlatmr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, * CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, * PACK, A, LDA, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N @@ -22,7 +22,7 @@ * INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -456,12 +456,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -471,10 +471,10 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM diff --git a/lapack-netlib/TESTING/MATGEN/dlatms.f b/lapack-netlib/TESTING/MATGEN/dlatms.f index 38d2b96584..11b9c03894 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatms.f +++ b/lapack-netlib/TESTING/MATGEN/dlatms.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, PACK, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, N @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -308,12 +308,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -321,10 +321,10 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM diff --git a/lapack-netlib/TESTING/MATGEN/dlatmt.f b/lapack-netlib/TESTING/MATGEN/dlatmt.f index a2080a8c88..a5cf54e47a 100644 --- a/lapack-netlib/TESTING/MATGEN/dlatmt.f +++ b/lapack-netlib/TESTING/MATGEN/dlatmt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * RANK, KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION COND, DMAX * INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK @@ -20,7 +20,7 @@ * DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -318,12 +318,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup double_matgen * @@ -331,10 +331,10 @@ SUBROUTINE DLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RANK, KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION COND, DMAX diff --git a/lapack-netlib/TESTING/MATGEN/slagge.f b/lapack-netlib/TESTING/MATGEN/slagge.f index f93bb2c272..626039aa04 100644 --- a/lapack-netlib/TESTING/MATGEN/slagge.f +++ b/lapack-netlib/TESTING/MATGEN/slagge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDA, M, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -101,22 +101,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N diff --git a/lapack-netlib/TESTING/MATGEN/slagsy.f b/lapack-netlib/TESTING/MATGEN/slagsy.f index 6d80a9af21..5fa7484c45 100644 --- a/lapack-netlib/TESTING/MATGEN/slagsy.f +++ b/lapack-netlib/TESTING/MATGEN/slagsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -89,22 +89,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/slahilb.f b/lapack-netlib/TESTING/MATGEN/slahilb.f index fb9c837c66..170cce62f1 100644 --- a/lapack-netlib/TESTING/MATGEN/slahilb.f +++ b/lapack-netlib/TESTING/MATGEN/slahilb.f @@ -2,20 +2,20 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. * REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) * .. -* +* * *> \par Purpose: * ============= @@ -26,8 +26,8 @@ *> NRHS right-hand sides in B and solutions in X such that A*X=B. *> *> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all -*> entries are integers. The right-hand sides are the first NRHS -*> columns of M * the identity matrix, and the solutions are the +*> entries are integers. The right-hand sides are the first NRHS +*> columns of M * the identity matrix, and the solutions are the *> first NRHS columns of the inverse Hilbert matrix. *> *> The condition number of the Hilbert matrix grows exponentially with @@ -36,7 +36,7 @@ *> generated exactly without extra precision. Precision is exhausted *> when the largest entry in the inverse Hilbert matrix is greater than *> 2 to the power of the number of bits in the fraction of the data type -*> used plus one, which is 24 for single precision. +*> used plus one, which is 24 for single precision. *> *> In single, the generated solution is exact for N <= 6 and has *> small componentwise error for 7 <= N <= 11. @@ -50,7 +50,7 @@ *> N is INTEGER *> The dimension of the matrix A. *> \endverbatim -*> +*> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER @@ -112,22 +112,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO @@ -212,7 +212,7 @@ SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) $ * (N +J -1) END DO - + DO J = 1, NRHS DO I = 1, N X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1) diff --git a/lapack-netlib/TESTING/MATGEN/slakf2.f b/lapack-netlib/TESTING/MATGEN/slakf2.f index 6de710321a..d84d4d6c5f 100644 --- a/lapack-netlib/TESTING/MATGEN/slakf2.f +++ b/lapack-netlib/TESTING/MATGEN/slakf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDZ, M, N * .. @@ -17,7 +17,7 @@ * REAL A( LDA, * ), B( LDA, * ), D( LDA, * ), * $ E( LDA, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDZ, M, N diff --git a/lapack-netlib/TESTING/MATGEN/slaran.f b/lapack-netlib/TESTING/MATGEN/slaran.f index 9738d28e0b..b0d18fccd7 100644 --- a/lapack-netlib/TESTING/MATGEN/slaran.f +++ b/lapack-netlib/TESTING/MATGEN/slaran.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SLARAN( ISEED ) -* +* * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -39,12 +39,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -67,10 +67,10 @@ * ===================================================================== REAL FUNCTION SLARAN( ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Array Arguments .. INTEGER ISEED( 4 ) diff --git a/lapack-netlib/TESTING/MATGEN/slarge.f b/lapack-netlib/TESTING/MATGEN/slarge.f index 5184bb5254..3929489961 100644 --- a/lapack-netlib/TESTING/MATGEN/slarge.f +++ b/lapack-netlib/TESTING/MATGEN/slarge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/slarnd.f b/lapack-netlib/TESTING/MATGEN/slarnd.f index 126aa4ff01..15ae253688 100644 --- a/lapack-netlib/TESTING/MATGEN/slarnd.f +++ b/lapack-netlib/TESTING/MATGEN/slarnd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SLARND( IDIST, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER IDIST * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -51,12 +51,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -73,10 +73,10 @@ * ===================================================================== REAL FUNCTION SLARND( IDIST, ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST diff --git a/lapack-netlib/TESTING/MATGEN/slaror.f b/lapack-netlib/TESTING/MATGEN/slaror.f index 2c9657e9a8..d58902110f 100644 --- a/lapack-netlib/TESTING/MATGEN/slaror.f +++ b/lapack-netlib/TESTING/MATGEN/slaror.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER INIT, SIDE * INTEGER INFO, LDA, M, N @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,22 +134,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER INIT, SIDE diff --git a/lapack-netlib/TESTING/MATGEN/slarot.f b/lapack-netlib/TESTING/MATGEN/slarot.f index f243baf944..ed478cb21e 100644 --- a/lapack-netlib/TESTING/MATGEN/slarot.f +++ b/lapack-netlib/TESTING/MATGEN/slarot.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, * XRIGHT ) -* +* * .. Scalar Arguments .. * LOGICAL LLEFT, LRIGHT, LROWS * INTEGER LDA, NL @@ -19,7 +19,7 @@ * .. Array Arguments .. * REAL A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -213,12 +213,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -226,10 +226,10 @@ SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS diff --git a/lapack-netlib/TESTING/MATGEN/slatm1.f b/lapack-netlib/TESTING/MATGEN/slatm1.f index 461e34b0f2..8f9e164318 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm1.f +++ b/lapack-netlib/TESTING/MATGEN/slatm1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, INFO, IRSIGN, MODE, N * REAL COND @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * REAL D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -123,22 +123,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N diff --git a/lapack-netlib/TESTING/MATGEN/slatm2.f b/lapack-netlib/TESTING/MATGEN/slatm2.f index 88dcd64941..fc7e781264 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm2.f +++ b/lapack-netlib/TESTING/MATGEN/slatm2.f @@ -2,27 +2,27 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST, * ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N * REAL SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * REAL D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -30,7 +30,7 @@ *> \verbatim *> *> SLATM2 returns the (I,J) entry of a random matrix of dimension -*> (M, N) described by the other paramters. It is called by the +*> (M, N) described by the other parameters. It is called by the *> SLATMR routine in order to build random test matrices. No error *> checking on parameters is done, because this routine is called in *> a tight loop by SLATMR which has already checked the parameters. @@ -195,12 +195,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup real_matgen * @@ -208,10 +208,10 @@ REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/slatm3.f b/lapack-netlib/TESTING/MATGEN/slatm3.f index f90790cb99..e61c954bd6 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm3.f +++ b/lapack-netlib/TESTING/MATGEN/slatm3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,20 +11,20 @@ * REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, * IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, * SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, * $ KU, M, N * REAL SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * REAL D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -32,7 +32,7 @@ *> \verbatim *> *> SLATM3 returns the (ISUB,JSUB) entry of a random matrix of -*> dimension (M, N) described by the other paramters. (ISUB,JSUB) +*> dimension (M, N) described by the other parameters. (ISUB,JSUB) *> is the final position of the (I,J) entry after pivoting *> according to IPVTNG and IWORK. SLATM3 is called by the *> SLATMR routine in order to build random test matrices. No error @@ -212,12 +212,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup real_matgen * @@ -226,10 +226,10 @@ REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/slatm5.f b/lapack-netlib/TESTING/MATGEN/slatm5.f index ce0540c192..010413498d 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm5.f +++ b/lapack-netlib/TESTING/MATGEN/slatm5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, * E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, * QBLCKB ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, * $ PRTYPE, QBLCKA, QBLCKB @@ -22,7 +22,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ L( LDL, * ), R( LDR, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,8 +48,8 @@ *> \param[in] PRTYPE *> \verbatim *> PRTYPE is INTEGER -*> "Points" to a certian type of the matrices to generate -*> (see futher details). +*> "Points" to a certain type of the matrices to generate +*> (see further details). *> \endverbatim *> *> \param[in] M @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup real_matgen * @@ -268,10 +268,10 @@ SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, $ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, $ QBLCKB ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, diff --git a/lapack-netlib/TESTING/MATGEN/slatm6.f b/lapack-netlib/TESTING/MATGEN/slatm6.f index e606becfc7..57f660190d 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm6.f +++ b/lapack-netlib/TESTING/MATGEN/slatm6.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, * BETA, WX, WY, S, DIF ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, N, TYPE * REAL ALPHA, BETA, WX, WY @@ -19,7 +19,7 @@ * REAL A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), * $ X( LDX, * ), Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -73,7 +73,7 @@ *> \param[in] TYPE *> \verbatim *> TYPE is INTEGER -*> Specifies the problem type (see futher details). +*> Specifies the problem type (see further details). *> \endverbatim *> *> \param[in] N @@ -163,12 +163,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -176,10 +176,10 @@ SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, $ BETA, WX, WY, S, DIF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, N, TYPE diff --git a/lapack-netlib/TESTING/MATGEN/slatm7.f b/lapack-netlib/TESTING/MATGEN/slatm7.f index 7e19541511..098d1c2b70 100644 --- a/lapack-netlib/TESTING/MATGEN/slatm7.f +++ b/lapack-netlib/TESTING/MATGEN/slatm7.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, * RANK, INFO ) -* +* * .. Scalar Arguments .. * REAL COND * INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK @@ -19,7 +19,7 @@ * REAL D( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -109,12 +109,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date December 2016 * *> \ingroup real_matgen * @@ -122,10 +122,10 @@ SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, $ RANK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational 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..-- -* September 2012 +* December 2016 * * .. Scalar Arguments .. REAL COND diff --git a/lapack-netlib/TESTING/MATGEN/slatme.f b/lapack-netlib/TESTING/MATGEN/slatme.f index 88bfaae36c..8309bcd341 100644 --- a/lapack-netlib/TESTING/MATGEN/slatme.f +++ b/lapack-netlib/TESTING/MATGEN/slatme.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * -* SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, -* RSIGN, -* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, -* A, +* SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, +* RSIGN, +* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, +* A, * LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, RSIGN, SIM, UPPER * INTEGER INFO, KL, KU, LDA, MODE, MODES, N @@ -24,7 +24,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), D( * ), DS( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -316,26 +316,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * * ===================================================================== - SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, - $ RSIGN, - $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, - $ A, + SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, + $ RSIGN, + $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, + $ A, $ LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER diff --git a/lapack-netlib/TESTING/MATGEN/slatmr.f b/lapack-netlib/TESTING/MATGEN/slatmr.f index d53ddf847f..e4705994ab 100644 --- a/lapack-netlib/TESTING/MATGEN/slatmr.f +++ b/lapack-netlib/TESTING/MATGEN/slatmr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, * CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, * PACK, A, LDA, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N @@ -22,7 +22,7 @@ * INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) * REAL A( LDA, * ), D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -456,12 +456,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -471,10 +471,10 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM diff --git a/lapack-netlib/TESTING/MATGEN/slatms.f b/lapack-netlib/TESTING/MATGEN/slatms.f index 9480e40e4c..349bfe2eb0 100644 --- a/lapack-netlib/TESTING/MATGEN/slatms.f +++ b/lapack-netlib/TESTING/MATGEN/slatms.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, PACK, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, N @@ -20,7 +20,7 @@ * INTEGER ISEED( 4 ) * REAL A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -308,12 +308,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -321,10 +321,10 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM diff --git a/lapack-netlib/TESTING/MATGEN/slatmt.f b/lapack-netlib/TESTING/MATGEN/slatmt.f index 7bdfeffdd9..f69e1d6e55 100644 --- a/lapack-netlib/TESTING/MATGEN/slatmt.f +++ b/lapack-netlib/TESTING/MATGEN/slatmt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * RANK, KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * REAL COND, DMAX * INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK @@ -20,7 +20,7 @@ * REAL A( LDA, * ), D( * ), WORK( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -318,12 +318,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup real_matgen * @@ -331,10 +331,10 @@ SUBROUTINE SLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RANK, KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. REAL COND, DMAX diff --git a/lapack-netlib/TESTING/MATGEN/zlagge.f b/lapack-netlib/TESTING/MATGEN/zlagge.f index b175c4a9ea..c9d2bc2402 100644 --- a/lapack-netlib/TESTING/MATGEN/zlagge.f +++ b/lapack-netlib/TESTING/MATGEN/zlagge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDA, M, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -102,22 +102,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDA, M, N diff --git a/lapack-netlib/TESTING/MATGEN/zlaghe.f b/lapack-netlib/TESTING/MATGEN/zlaghe.f index e3f0907192..506035061e 100644 --- a/lapack-netlib/TESTING/MATGEN/zlaghe.f +++ b/lapack-netlib/TESTING/MATGEN/zlaghe.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/zlagsy.f b/lapack-netlib/TESTING/MATGEN/zlagsy.f index 4a793a01cf..e030a5f18e 100644 --- a/lapack-netlib/TESTING/MATGEN/zlagsy.f +++ b/lapack-netlib/TESTING/MATGEN/zlagsy.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, K, LDA, N * .. @@ -18,7 +18,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,22 +90,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/zlahilb.f b/lapack-netlib/TESTING/MATGEN/zlahilb.f index f30835df26..892109295e 100644 --- a/lapack-netlib/TESTING/MATGEN/zlahilb.f +++ b/lapack-netlib/TESTING/MATGEN/zlahilb.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, * INFO, PATH) -* +* * .. Scalar Arguments .. * INTEGER N, NRHS, LDA, LDX, LDB, INFO * .. Array Arguments .. @@ -18,7 +18,7 @@ * COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) * CHARACTER*3 PATH * .. -* +* * *> \par Purpose: * ============= @@ -121,12 +121,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -134,10 +134,10 @@ SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, $ INFO, PATH) * -* -- LAPACK test routine (version 3.6.0) -- +* -- 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER N, NRHS, LDA, LDX, LDB, INFO @@ -168,7 +168,7 @@ SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8) DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), $ (-.5,-.5),(.5,-.5),(.5,.5)/ DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), @@ -237,7 +237,7 @@ SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, END DO END DO END IF - + * Generate matrix B as simply the first NRHS columns of M * the * identity. TMP = DBLE(M) @@ -252,7 +252,7 @@ SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, $ * (N +J -1) END DO -* If we are testing SY routines, +* If we are testing SY routines, * take D1_i = D2_i, else, D1_i = D2_i* IF ( LSAMEN( 2, C2, 'SY' ) ) THEN DO J = 1, NRHS diff --git a/lapack-netlib/TESTING/MATGEN/zlakf2.f b/lapack-netlib/TESTING/MATGEN/zlakf2.f index 7e8fc479dd..4260d7caae 100644 --- a/lapack-netlib/TESTING/MATGEN/zlakf2.f +++ b/lapack-netlib/TESTING/MATGEN/zlakf2.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDZ, M, N * .. @@ -17,7 +17,7 @@ * COMPLEX*16 A( LDA, * ), B( LDA, * ), D( LDA, * ), * $ E( LDA, * ), Z( LDZ, * ) * .. -* +* * *> \par Purpose: * ============= @@ -93,22 +93,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDZ, M, N diff --git a/lapack-netlib/TESTING/MATGEN/zlarge.f b/lapack-netlib/TESTING/MATGEN/zlarge.f index e44c2faba7..4e1de110e1 100644 --- a/lapack-netlib/TESTING/MATGEN/zlarge.f +++ b/lapack-netlib/TESTING/MATGEN/zlarge.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO ) -* +* * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. @@ -17,7 +17,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -75,22 +75,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N diff --git a/lapack-netlib/TESTING/MATGEN/zlarnd.f b/lapack-netlib/TESTING/MATGEN/zlarnd.f index 563a453e67..2b0498bd3c 100644 --- a/lapack-netlib/TESTING/MATGEN/zlarnd.f +++ b/lapack-netlib/TESTING/MATGEN/zlarnd.f @@ -2,21 +2,21 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX*16 FUNCTION ZLARND( IDIST, ISEED ) -* +* * .. Scalar Arguments .. * INTEGER IDIST * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -53,12 +53,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -75,10 +75,10 @@ * ===================================================================== COMPLEX*16 FUNCTION ZLARND( IDIST, ISEED ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST diff --git a/lapack-netlib/TESTING/MATGEN/zlaror.f b/lapack-netlib/TESTING/MATGEN/zlaror.f index 2fd1e63de1..b8c4fdfa51 100644 --- a/lapack-netlib/TESTING/MATGEN/zlaror.f +++ b/lapack-netlib/TESTING/MATGEN/zlaror.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER INIT, SIDE * INTEGER INFO, LDA, M, N @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 A( LDA, * ), X( * ) * .. -* +* * *> \par Purpose: * ============= @@ -146,22 +146,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER INIT, SIDE diff --git a/lapack-netlib/TESTING/MATGEN/zlarot.f b/lapack-netlib/TESTING/MATGEN/zlarot.f index 0b2b9142db..ebb5d98f90 100644 --- a/lapack-netlib/TESTING/MATGEN/zlarot.f +++ b/lapack-netlib/TESTING/MATGEN/zlarot.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, * XRIGHT ) -* +* * .. Scalar Arguments .. * LOGICAL LLEFT, LRIGHT, LROWS * INTEGER LDA, NL @@ -19,7 +19,7 @@ * .. Array Arguments .. * COMPLEX*16 A( * ) * .. -* +* * *> \par Purpose: * ============= @@ -216,12 +216,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -229,10 +229,10 @@ SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, $ XRIGHT ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. LOGICAL LLEFT, LRIGHT, LROWS diff --git a/lapack-netlib/TESTING/MATGEN/zlatm1.f b/lapack-netlib/TESTING/MATGEN/zlatm1.f index 409a4de57d..a829d91191 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatm1.f +++ b/lapack-netlib/TESTING/MATGEN/zlatm1.f @@ -2,14 +2,14 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) -* +* * .. Scalar Arguments .. * INTEGER IDIST, INFO, IRSIGN, MODE, N * DOUBLE PRECISION COND @@ -18,7 +18,7 @@ * INTEGER ISEED( 4 ) * COMPLEX*16 D( * ) * .. -* +* * *> \par Purpose: * ============= @@ -125,22 +125,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2015 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) * -* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK auxiliary 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..-- -* November 2015 +* December 2016 * * .. Scalar Arguments .. INTEGER IDIST, INFO, IRSIGN, MODE, N diff --git a/lapack-netlib/TESTING/MATGEN/zlatm2.f b/lapack-netlib/TESTING/MATGEN/zlatm2.f index 920e43e832..2de69eecad 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatm2.f +++ b/lapack-netlib/TESTING/MATGEN/zlatm2.f @@ -2,27 +2,27 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * COMPLEX*16 FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST, * ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N * DOUBLE PRECISION SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * COMPLEX*16 D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -30,7 +30,7 @@ *> \verbatim *> *> ZLATM2 returns the (I,J) entry of a random matrix of dimension -*> (M, N) described by the other paramters. It is called by the +*> (M, N) described by the other parameters. It is called by the *> ZLATMR routine in order to build random test matrices. No error *> checking on parameters is done, because this routine is called in *> a tight loop by ZLATMR which has already checked the parameters. @@ -198,12 +198,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_matgen * @@ -211,10 +211,10 @@ COMPLEX*16 FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST, $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/zlatm3.f b/lapack-netlib/TESTING/MATGEN/zlatm3.f index 4c27ad3b81..42d58c853e 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatm3.f +++ b/lapack-netlib/TESTING/MATGEN/zlatm3.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,20 +11,20 @@ * COMPLEX*16 FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, * IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, * SPARSE ) -* +* * .. Scalar Arguments .. -* +* * INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, * $ KU, M, N * DOUBLE PRECISION SPARSE * .. -* +* * .. Array Arguments .. -* +* * INTEGER ISEED( 4 ), IWORK( * ) * COMPLEX*16 D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -32,7 +32,7 @@ *> \verbatim *> *> ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of -*> dimension (M, N) described by the other paramters. (ISUB,JSUB) +*> dimension (M, N) described by the other parameters. (ISUB,JSUB) *> is the final position of the (I,J) entry after pivoting *> according to IPVTNG and IWORK. ZLATM3 is called by the *> ZLATMR routine in order to build random test matrices. No error @@ -215,12 +215,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_matgen * @@ -229,10 +229,10 @@ COMPLEX*16 FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, $ SPARSE ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. * diff --git a/lapack-netlib/TESTING/MATGEN/zlatm5.f b/lapack-netlib/TESTING/MATGEN/zlatm5.f index 6b277268db..4ab3e276b3 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatm5.f +++ b/lapack-netlib/TESTING/MATGEN/zlatm5.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, * E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, * QBLCKB ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, * $ PRTYPE, QBLCKA, QBLCKB @@ -22,7 +22,7 @@ * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ L( LDL, * ), R( LDR, * ) * .. -* +* * *> \par Purpose: * ============= @@ -48,8 +48,8 @@ *> \param[in] PRTYPE *> \verbatim *> PRTYPE is INTEGER -*> "Points" to a certian type of the matrices to generate -*> (see futher details). +*> "Points" to a certain type of the matrices to generate +*> (see further details). *> \endverbatim *> *> \param[in] M @@ -187,12 +187,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date June 2016 * *> \ingroup complex16_matgen * @@ -268,10 +268,10 @@ SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, $ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, $ QBLCKB ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, diff --git a/lapack-netlib/TESTING/MATGEN/zlatm6.f b/lapack-netlib/TESTING/MATGEN/zlatm6.f index b11a5ea5a8..f000f52286 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatm6.f +++ b/lapack-netlib/TESTING/MATGEN/zlatm6.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, * BETA, WX, WY, S, DIF ) -* +* * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, N, TYPE * COMPLEX*16 ALPHA, BETA, WX, WY @@ -20,7 +20,7 @@ * COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ), * $ Y( LDY, * ) * .. -* +* * *> \par Purpose: * ============= @@ -71,7 +71,7 @@ *> \param[in] TYPE *> \verbatim *> TYPE is INTEGER -*> Specifies the problem type (see futher details). +*> Specifies the problem type (see further details). *> \endverbatim *> *> \param[in] N @@ -161,12 +161,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -174,10 +174,10 @@ SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, $ BETA, WX, WY, S, DIF ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, N, TYPE diff --git a/lapack-netlib/TESTING/MATGEN/zlatme.f b/lapack-netlib/TESTING/MATGEN/zlatme.f index eb52d14192..fee1eca6e4 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatme.f +++ b/lapack-netlib/TESTING/MATGEN/zlatme.f @@ -2,18 +2,18 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX, -* RSIGN, -* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, -* A, +* RSIGN, +* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, +* A, * LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, RSIGN, SIM, UPPER * INTEGER INFO, KL, KU, LDA, MODE, MODES, N @@ -25,7 +25,7 @@ * DOUBLE PRECISION DS( * ) * COMPLEX*16 A( LDA, * ), D( * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -285,26 +285,26 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * * ===================================================================== SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX, - $ RSIGN, - $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, - $ A, + $ RSIGN, + $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, + $ A, $ LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, RSIGN, SIM, UPPER diff --git a/lapack-netlib/TESTING/MATGEN/zlatmr.f b/lapack-netlib/TESTING/MATGEN/zlatmr.f index ed85d36089..6685a35705 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatmr.f +++ b/lapack-netlib/TESTING/MATGEN/zlatmr.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -12,7 +12,7 @@ * RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, * CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, * PACK, A, LDA, IWORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N @@ -23,7 +23,7 @@ * INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) * COMPLEX*16 A( LDA, * ), D( * ), DL( * ), DR( * ) * .. -* +* * *> \par Purpose: * ============= @@ -475,12 +475,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -490,10 +490,10 @@ SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, $ PACK, A, LDA, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM diff --git a/lapack-netlib/TESTING/MATGEN/zlatms.f b/lapack-netlib/TESTING/MATGEN/zlatms.f index 04a5386e59..9bad548604 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatms.f +++ b/lapack-netlib/TESTING/MATGEN/zlatms.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIST, PACK, SYM * INTEGER INFO, KL, KU, LDA, M, MODE, N @@ -21,7 +21,7 @@ * DOUBLE PRECISION D( * ) * COMPLEX*16 A( LDA, * ), WORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -319,12 +319,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -332,10 +332,10 @@ SUBROUTINE ZLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. CHARACTER DIST, PACK, SYM diff --git a/lapack-netlib/TESTING/MATGEN/zlatmt.f b/lapack-netlib/TESTING/MATGEN/zlatmt.f index 515d86b2a3..257c2627e3 100644 --- a/lapack-netlib/TESTING/MATGEN/zlatmt.f +++ b/lapack-netlib/TESTING/MATGEN/zlatmt.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * RANK, KL, KU, PACK, A, LDA, WORK, INFO ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION COND, DMAX * INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK @@ -21,7 +21,7 @@ * DOUBLE PRECISION D( * ) * INTEGER ISEED( 4 ) * .. -* +* * *> \par Purpose: * ============= @@ -327,12 +327,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16_matgen * @@ -340,10 +340,10 @@ SUBROUTINE ZLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RANK, KL, KU, PACK, A, LDA, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational 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..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION COND, DMAX diff --git a/lapack-netlib/TESTING/Makefile b/lapack-netlib/TESTING/Makefile index 9aaf07de7a..dfb5fc176f 100644 --- a/lapack-netlib/TESTING/Makefile +++ b/lapack-netlib/TESTING/Makefile @@ -38,21 +38,22 @@ include ../make.inc ifneq ($(strip $(VARLIB)),) - LAPACKLIB := $(VARLIB) ../$(LAPACKLIB) + LAPACKLIB := $(VARLIB) ../$(LAPACKLIB) endif -all: single complex double complex16 singleproto doubleproto complexproto complex16proto +all: single complex double complex16 singleproto doubleproto complexproto complex16proto SEIGTST= snep.out \ ssep.out \ + sse2.out \ ssvd.out \ sec.out \ sed.out \ sgg.out \ sgd.out \ ssb.out \ - ssg.out \ + ssg.out \ sbal.out \ sbak.out \ sgbal.out \ @@ -66,13 +67,14 @@ SEIGTST= snep.out \ CEIGTST= cnep.out \ csep.out \ + cse2.out \ csvd.out \ cec.out \ ced.out \ cgg.out \ cgd.out \ csb.out \ - csg.out \ + csg.out \ cbal.out \ cbak.out \ cgbal.out \ @@ -86,13 +88,14 @@ CEIGTST= cnep.out \ DEIGTST= dnep.out \ dsep.out \ + dse2.out \ dsvd.out \ dec.out \ ded.out \ dgg.out \ dgd.out \ dsb.out \ - dsg.out \ + dsg.out \ dbal.out \ dbak.out \ dgbal.out \ @@ -106,13 +109,14 @@ DEIGTST= dnep.out \ ZEIGTST= znep.out \ zsep.out \ + zse2.out \ zsvd.out \ zec.out \ zed.out \ zgg.out \ zgd.out \ zsb.out \ - zsg.out \ + zsg.out \ zbal.out \ zbak.out \ zgbal.out \ @@ -184,31 +188,31 @@ dstest.out: dstest.in xlintstds # ======== COMPLEX-COMPLEX16 LIN TESTS ======================== zctest.out: zctest.in xlintstzc - @echo Testing COMPLEX-COMPLEX16 LAPACK protoype linear equation routines + @echo Testing COMPLEX-COMPLEX16 LAPACK prototype linear equation routines ./xlintstzc < zctest.in > $@ 2>&1 # # ======== SINGLE RFP LIN TESTS ======================== stest_rfp.out: stest_rfp.in xlintstrfs - @echo Testing REAL LAPACK RFP protoype linear equation routines + @echo Testing REAL LAPACK RFP prototype linear equation routines ./xlintstrfs < stest_rfp.in > $@ 2>&1 # # ======== COMPLEX16 RFP LIN TESTS ======================== dtest_rfp.out: dtest_rfp.in xlintstrfd - @echo Testing DOUBLE PRECISION LAPACK RFP protoype linear equation routines + @echo Testing DOUBLE PRECISION LAPACK RFP prototype linear equation routines ./xlintstrfd < dtest_rfp.in > $@ 2>&1 # # ======== COMPLEX16 RFP LIN TESTS ======================== ctest_rfp.out: ctest_rfp.in xlintstrfc - @echo Testing COMPLEX LAPACK RFP protoype linear equation routines + @echo Testing COMPLEX LAPACK RFP prototype linear equation routines ./xlintstrfc < ctest_rfp.in > $@ 2>&1 # # ======== COMPLEX16 RFP LIN TESTS ======================== ztest_rfp.out: ztest_rfp.in xlintstrfz - @echo Testing COMPLEX16 LAPACK RFP protoype linear equation routines + @echo Testing COMPLEX16 LAPACK RFP prototype linear equation routines ./xlintstrfz < ztest_rfp.in > $@ 2>&1 # # @@ -223,6 +227,10 @@ ssep.out: sep.in xeigtsts @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtsts < sep.in > $@ 2>&1 +sse2.out: se2.in xeigtsts + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtsts < se2.in > $@ 2>&1 + ssvd.out: svd.in xeigtsts @echo SVD: Testing Singular Value Decomposition routines ./xeigtsts < svd.in > $@ 2>&1 @@ -268,7 +276,7 @@ sgbak.out: sgbak.in xeigtsts ./xeigtsts < sgbak.in > $@ 2>&1 sbb.out: sbb.in xeigtsts - @echo SBB: Testing banded Singular Value Decomposition routines + @echo SBB: Testing banded Singular Value Decomposition routines ./xeigtsts < sbb.in > $@ 2>&1 sglm.out: glm.in xeigtsts @@ -301,6 +309,10 @@ csep.out: sep.in xeigtstc @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstc < sep.in > $@ 2>&1 +cse2.out: se2.in xeigtstc + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstc < se2.in > $@ 2>&1 + csvd.out: svd.in xeigtstc @echo SVD: Testing Singular Value Decomposition routines ./xeigtstc < svd.in > $@ 2>&1 @@ -346,7 +358,7 @@ cgbak.out: cgbak.in xeigtstc ./xeigtstc < cgbak.in > $@ 2>&1 cbb.out: cbb.in xeigtstc - @echo CBB: Testing banded Singular Value Decomposition routines + @echo CBB: Testing banded Singular Value Decomposition routines ./xeigtstc < cbb.in > $@ 2>&1 cglm.out: glm.in xeigtstc @@ -379,6 +391,10 @@ dsep.out: sep.in xeigtstd @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstd < sep.in > $@ 2>&1 +dse2.out: se2.in xeigtstd + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstd < se2.in > $@ 2>&1 + dsvd.out: svd.in xeigtstd @echo SVD: Testing Singular Value Decomposition routines ./xeigtstd < svd.in > $@ 2>&1 @@ -412,7 +428,7 @@ dbal.out: dbal.in xeigtstd ./xeigtstd < dbal.in > $@ 2>&1 dbak.out: dbak.in xeigtstd - @echo DGEBAK: Testing the back transformation of a DOUBLE PRECISION balanced matrix + @echo DGEBAK: Testing the back transformation of a DOUBLE PRECISION balanced matrix ./xeigtstd < dbak.in > $@ 2>&1 dgbal.out: dgbal.in xeigtstd @@ -424,7 +440,7 @@ dgbak.out: dgbak.in xeigtstd ./xeigtstd < dgbak.in > $@ 2>&1 dbb.out: dbb.in xeigtstd - @echo DBB: Testing banded Singular Value Decomposition routines + @echo DBB: Testing banded Singular Value Decomposition routines ./xeigtstd < dbb.in > $@ 2>&1 dglm.out: glm.in xeigtstd @@ -457,6 +473,10 @@ zsep.out: sep.in xeigtstz @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstz < sep.in > $@ 2>&1 +zse2.out: se2.in xeigtstz + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstz < se2.in > $@ 2>&1 + zsvd.out: svd.in xeigtstz @echo SVD: Testing Singular Value Decomposition routines ./xeigtstz < svd.in > $@ 2>&1 @@ -526,46 +546,46 @@ zlse.out: lse.in xeigtstz ./xeigtstz < lse.in > $@ 2>&1 # ============================================================================== -xlintsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) single -xlintstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) complex -xlintstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) double -xlintstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) complex16 -xlintstrfs: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstrfs: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-single -xlintstrfc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstrfc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-complex -xlintstrfd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstrfd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-double -xlintstrfz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstrfz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-complex16 -xlintstds: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstds: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-double -xlintstzc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) +xlintstzc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC) cd LIN ; $(MAKE) proto-complex16 -xeigtsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) +xeigtsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) cd EIG ; $(MAKE) single -xeigtstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) +xeigtstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) cd EIG ; $(MAKE) complex -xeigtstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) +xeigtstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) cd EIG ; $(MAKE) double -xeigtstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) +xeigtstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC) cd EIG ; $(MAKE) complex16 clean: @@ -582,3 +602,5 @@ FRCEIG: FRC: @FRC=$(FRC) + +.NOTPARALLEL: diff --git a/lapack-netlib/TESTING/cbak.in b/lapack-netlib/TESTING/cbak.in index c6073bdc7d..ef364dc8a1 100644 --- a/lapack-netlib/TESTING/cbak.in +++ b/lapack-netlib/TESTING/cbak.in @@ -3,76 +3,76 @@ CBK: Tests CGEBAK 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) 5 1 1 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01 (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) -(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00) +(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25000E+00,0.00000E+00) (-.66667E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.22222E+00,0.00000E+00) -(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00) +(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.22222E+00,0.00000E+00) -(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00) +(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25000E+00,0.00000E+00) (-.66667E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) -(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00) +(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00) 5 1 1 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01 (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) -(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) +(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.36000E-34,0.00000E+00) -(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00) +(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.36000E-34,0.00000E+00) -(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00) +(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00) (0.00000E+00,0.00000E+00) (-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) -(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) +(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) 6 4 6 0.4000E+01 0.3000E+01 0.5000E+01 0.1000E+03 0.1000E+00 0.1000E+01 @@ -107,26 +107,26 @@ CBK: Tests CGEBAK 0.1000E+03 0.1000E+00 0.1000E-01 0.1000E+01 0.1000E+02 (0.13663E-03,0.00000E+00) (-.68290E-04,0.00000E+00) (0.12516E-03,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.19503E-14,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.19503E-14,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (-.27756E-16,0.00000E+00) -(0.36012E-05,0.00000E+00) (-.60728E-17,0.00000E+00) +(0.36012E-05,0.00000E+00) (-.60728E-17,0.00000E+00) (0.27355E+00,0.00000E+00) (-.13627E+00,0.00000E+00) (0.25030E+00,0.00000E+00) -(-.33221E-05,0.00000E+00) (-.20000E-02,0.00000E+00) +(-.33221E-05,0.00000E+00) (-.20000E-02,0.00000E+00) (0.69088E-02,0.00000E+00) (-.34434E-02,0.00000E+00) (0.61959E-02,0.00000E+00) -(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.38988E+00,0.00000E+00) (-.20327E+00,0.00000E+00) (-.34200E+00,0.00000E+00) -(-.10000E-02,0.00000E+00) (0.60004E-14,0.00000E+00) +(-.10000E-02,0.00000E+00) (0.60004E-14,0.00000E+00) (0.13663E-01,0.00000E+00) (-.68290E-02,0.00000E+00) (0.12516E-01,0.00000E+00) -(0.10000E+03,0.00000E+00) (0.19503E-12,0.00000E+00) +(0.10000E+03,0.00000E+00) (0.19503E-12,0.00000E+00) (0.10000E+00,0.00000E+00) (0.10000E+00,0.00000E+00) (-.27756E-17,0.00000E+00) -(0.36012E-06,0.00000E+00) (-.60728E-18,0.00000E+00) +(0.36012E-06,0.00000E+00) (-.60728E-18,0.00000E+00) (0.27355E-02,0.00000E+00) (-.13627E-02,0.00000E+00) (0.25030E-02,0.00000E+00) -(-.33221E-07,0.00000E+00) (-.20000E-04,0.00000E+00) +(-.33221E-07,0.00000E+00) (-.20000E-04,0.00000E+00) (0.69088E-02,0.00000E+00) (-.34434E-02,0.00000E+00) (0.61959E-02,0.00000E+00) -(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.38988E+01,0.00000E+00) (-.20327E+01,0.00000E+00) (-.34200E+01,0.00000E+00) -(-.10000E-01,0.00000E+00) (0.60004E-13,0.00000E+00) +(-.10000E-01,0.00000E+00) (0.60004E-13,0.00000E+00) 6 2 5 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01 @@ -163,19 +163,19 @@ CBK: Tests CGEBAK (0.10000E+01,0.00000E+00) (-.11048E-01,0.00000E+00) (0.37942E-01,0.00000E+00) (-.93781E-01,0.00000E+00) (-.34815E-01,0.00000E+00) (0.44651E+00,0.00000E+00) -(-.36016E-01,0.00000E+00) +(-.36016E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.45564E+00,0.00000E+00) (-.45447E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.46394E+00,0.00000E+00) (-.65116E+00,0.00000E+00) -(0.47808E+00,0.00000E+00) +(0.47808E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.27336E+00,0.00000E+00) (-.79459E+00,0.00000E+00) (0.63028E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.62791E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.69389E-17,0.00000E+00) (0.42585E-01,0.00000E+00) (-.64954E+00,0.00000E+00) (-.55814E+00,0.00000E+00) -(-.64516E+00,0.00000E+00) +(-.64516E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.39041E+00,0.00000E+00) (-.40294E+00,0.00000E+00) (-.16849E+00,0.00000E+00) (-.94294E+00,0.00000E+00) (0.10000E+01,0.00000E+00) -(-.93714E+00,0.00000E+00) +(-.93714E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25581E+00,0.00000E+00) (0.33085E-03,0.00000E+00) @@ -185,24 +185,24 @@ CBK: Tests CGEBAK (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25581E+00,0.00000E+00) -(0.33085E-03,0.00000E+00) +(0.33085E-03,0.00000E+00) (0.00000E+00,0.00000E+00) (-.45564E-03,0.00000E+00) (-.45447E-03,0.00000E+00) (0.10000E-02,0.00000E+00) (0.46394E-03,0.00000E+00) (-.65116E-03,0.00000E+00) -(0.47808E-03,0.00000E+00) +(0.47808E-03,0.00000E+00) (0.10000E+01,0.00000E+00) (-.11048E-01,0.00000E+00) (0.37942E-01,0.00000E+00) (-.93781E-01,0.00000E+00) (-.34815E-01,0.00000E+00) (0.44651E+00,0.00000E+00) -(-.36016E-01,0.00000E+00) +(-.36016E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+02,0.00000E+00) (-.69389E-16,0.00000E+00) (0.42585E+00,0.00000E+00) (-.64954E+01,0.00000E+00) (-.55814E+01,0.00000E+00) -(-.64516E+01,0.00000E+00) +(-.64516E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.39041E-01,0.00000E+00) (-.40294E-01,0.00000E+00) (-.16849E-01,0.00000E+00) (-.94294E-01,0.00000E+00) (0.10000E+00,0.00000E+00) -(-.93714E-01,0.00000E+00) +(-.93714E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(-.19851E-02,0.00000E+00) +(-.19851E-02,0.00000E+00) (0.00000E+00,0.00000E+00) (-.27336E-02,0.00000E+00) (-.79459E-02,0.00000E+00) (0.63028E-02,0.00000E+00) (0.10000E-01,0.00000E+00) (-.62791E-02,0.00000E+00) -(0.10000E-01,0.00000E+00) +(0.10000E-01,0.00000E+00) -0 0 0 +0 0 0 diff --git a/lapack-netlib/TESTING/cbal.in b/lapack-netlib/TESTING/cbal.in index 29b1459cba..909531c332 100644 --- a/lapack-netlib/TESTING/cbal.in +++ b/lapack-netlib/TESTING/cbal.in @@ -1,92 +1,92 @@ CBL: Tests CGEBAL 5 (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) +(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01) +(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01) 1 1 (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) +(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01) +(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01) 0.10000E+01 0.20000E+01 0.30000E+01 0.40000E+01 0.50000E+01 5 (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01) -(0.40000E+01,0.40000E+01) (0.00000E+00,0.00000E+00) +(0.40000E+01,0.40000E+01) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01) -(0.40000E+01,0.40000E+01) (0.50000E+01,0.50000E+01) +(0.40000E+01,0.40000E+01) (0.50000E+01,0.50000E+01) 1 1 (0.50000E+01,0.50000E+01) (0.40000E+01,0.40000E+01) (0.30000E+01,0.30000E+01) -(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) +(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.40000E+01,0.40000E+01) (0.30000E+01,0.30000E+01) -(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) +(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01) -(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) +(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) +(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) +(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) 0.10000E+01 0.20000E+01 0.30000E+01 0.20000E+01 0.10000E+01 5 (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) +(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01) +(0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01) 1 1 (0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) -(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00) +(0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) +(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) 0.10000E+01 0.20000E+01 0.30000E+01 0.20000E+01 0.10000E+01 4 (0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00) (0.10000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.10000E+00,0.00000E+00) +(0.10000E+00,0.00000E+00) (0.10000E+03,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.20000E+01,0.00000E+00) +(0.20000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+03,0.00000E+00) (0.20000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) - +(0.00000E+00,0.00000E+00) + 1 4 (0.0000E+00,0.00000E+00) (0.2000E+01,0.00000E+00) (0.3200E+01,0.00000E+00) (0.000E+00,0.00000E+00) @@ -131,25 +131,25 @@ CBL: Tests CGEBAL 5 (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.81920E+04,0.00000E+00) -(0.20000E+01,0.00000E+00) (0.40000E+01,0.00000E+00) +(0.20000E+01,0.00000E+00) (0.40000E+01,0.00000E+00) (0.25000E-03,0.00000E+00) (0.12500E-03,0.00000E+00) (0.40000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.64000E+02,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.64000E+02,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00) (0.10240E+04,0.10240E+01) -(0.40000E+01,0.00000E+00) (0.80000E+01,0.00000E+00) +(0.40000E+01,0.00000E+00) (0.80000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.81920E+04) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) 1 5 - ( 1.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) -( 0.0000e-003,0.00000E+00) (250.0000e-003,0.00000E+00) + ( 1.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) +( 0.0000e-003,0.00000E+00) (250.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 2.0000e+000, 1.0000e+000) ( 1.0240e+003,0.00000E+00) - ( 16.0000e+000,0.00000E+00) ( 16.0000e+000,0.00000E+00) + ( 16.0000e+000,0.00000E+00) ( 16.0000e+000,0.00000E+00) (256.0000e-003,0.00000E+00) ( 1.0000e-003,0.00000E+00) ( 4.0000e+000,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 2.0480e+003,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 2.0480e+003,0.00000E+00) ( 0.0000e-003,0.00000E+00) (250.0000e-003,0.00000E+00) ( 16.0000e+000,16.0000e-003) - ( 4.0000e+000,0.00000E+00) ( 4.0000e+000,0.00000E+00) + ( 4.0000e+000,0.00000E+00) ( 4.0000e+000,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003, 2.0480e+003) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 8.0000e+000,0.00000E+00) @@ -157,61 +157,61 @@ CBL: Tests CGEBAL 4 (0.10000E+01,0.10000E+01) (0.10000E+07,0.00000E+00) (0.10000E+07,0.00000E+00) -(0.10000E+07,0.00000E+00) +(0.10000E+07,0.00000E+00) (-.20000E+07,0.00000E+00) (0.30000E+01,0.10000E+01) (0.20000E-05,0.00000E+00) -(0.30000E-05,0.00000E+00) +(0.30000E-05,0.00000E+00) (-.30000E+07,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E-05,0.10000E+01) (0.20000E+01,0.00000E+00) (0.10000E+07,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E-05,0.00000E+00) -(0.40000E+07,0.10000E+01) +(0.40000E+07,0.10000E+01) 1 4 - ( 1.0000e+000, 1.0000e+000) ( 1.0000e+006,0.00000E+00) ( 2.0000e+006,0.00000E+00) ( 1.0000e+006,0.00000E+00) (250.0000e-003,0.00000E+00) - ( -2.0000e+006,0.00000E+00) ( 3.0000e+000, 1.0000e+000) ( 4.0000e-006,0.00000E+00) ( 3.0000e-006,0.00000E+00) ( 16.0000e+000,0.00000E+00) - ( -1.5000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 1.0000e-006, 1.0000e+000) ( 1.0000e+000,0.00000E+00) ( 2.0480e+003,0.00000E+00) - ( 1.0000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 6.0000e-006,0.00000E+00) ( 4.0000e+006, 1.0000e+000) ( 4.0000e+000,0.00000E+00) + ( 1.0000e+000, 1.0000e+000) ( 1.0000e+006,0.00000E+00) ( 2.0000e+006,0.00000E+00) ( 1.0000e+006,0.00000E+00) (250.0000e-003,0.00000E+00) + ( -2.0000e+006,0.00000E+00) ( 3.0000e+000, 1.0000e+000) ( 4.0000e-006,0.00000E+00) ( 3.0000e-006,0.00000E+00) ( 16.0000e+000,0.00000E+00) + ( -1.5000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 1.0000e-006, 1.0000e+000) ( 1.0000e+000,0.00000E+00) ( 2.0480e+003,0.00000E+00) + ( 1.0000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 6.0000e-006,0.00000E+00) ( 4.0000e+006, 1.0000e+000) ( 4.0000e+000,0.00000E+00) 1.0000e+000 1.0000e+000 2.0000e+000 1.0000e+000 4 (0.10000E+01,0.00000E+00) (0.00000E+00,0.10000E+05) (0.00000E+00,0.10000E+05) -(0.00000E+00,0.10000E+05) +(0.00000E+00,0.10000E+05) (-.20000E+05,0.00000E+00) (0.30000E+01,0.00000E+00) (0.20000E-02,0.00000E+00) -(0.30000E-02,0.00000E+00) +(0.30000E-02,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) -(-.30000E+05,0.00000E+00) +(-.30000E+05,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+05,0.00000E+00) -(0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) 1 4 - ( 1.0000e+000,0.00000E+00) ( 0.0000e-003,10.0000e+003) (0.0000e-003,10.0000e+003) (0.0000e-003,5.0000e+003) (250.0000e-003,0.00000E+00) - (-20.0000e+003,0.00000E+00) ( 3.0000e+000,0.00000E+00) ( 2.0000e-003,0.00000E+00) ( 1.5000e-003,0.00000E+00) ( 16.0000e+000,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 2.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) (-15.0000e+003,0.00000E+00) ( 2.0480e+003,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 20.0000e+003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 4.0000e+000,0.00000E+00) + ( 1.0000e+000,0.00000E+00) ( 0.0000e-003,10.0000e+003) (0.0000e-003,10.0000e+003) (0.0000e-003,5.0000e+003) (250.0000e-003,0.00000E+00) + (-20.0000e+003,0.00000E+00) ( 3.0000e+000,0.00000E+00) ( 2.0000e-003,0.00000E+00) ( 1.5000e-003,0.00000E+00) ( 16.0000e+000,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 2.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) (-15.0000e+003,0.00000E+00) ( 2.0480e+003,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 20.0000e+003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 4.0000e+000,0.00000E+00) 1.0000e+000 1.0000e+000 1.0000e+000 500.0000e-003 5 (0.10000E+01,0.00000E+00) (0.51200E+03,0.00000E+00) (0.40960E+04,0.00000E+00) -(0.32768E+05,0.00000E+00) (2.62144E+05,0.00000E+00) +(0.32768E+05,0.00000E+00) (2.62144E+05,0.00000E+00) (0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.80000E+01,0.80000E+01) -(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00) +(0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00) 1 5 - ( 1.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) -( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) - ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) -( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) -( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) -( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) - ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) + ( 1.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) +( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) + ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) +( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) +( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) +( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) + ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) 128.0000e+000 16.0000e+000 2.0000e+000 250.0000e-003 31.2500e-003 @@ -249,25 +249,25 @@ CBL: Tests CGEBAL 7 (0.60000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.40000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.25000E-03,0.00000E+00) (0.12500E-01,0.00000E+00) (0.20000E-01,0.00000E+00) -(0.12500E+00,0.00000E+00) +(0.12500E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.12800E+03,0.00000E+00) (0.64000E+02,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.20000E+01,0.00000E+00) -(0.16000E+02,0.00000E+00) +(0.16000E+02,0.00000E+00) (0.00000E+00,0.00000E+00) (0.16384E+05,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.40000E+03,0.00000E+00) (0.25600E+03,0.00000E+00) -(-.40000E+04,0.00000E+00) +(-.40000E+04,0.00000E+00) (-.20000E+01,0.00000E+00) (-.25600E+03,0.00000E+00) (0.00000E+00,0.00000E+00) (0.12500E-01,0.00000E+00) (0.20000E+01,0.00000E+00) (0.20000E+01,0.00000E+00) -(0.32000E+02,0.00000E+00) +(0.32000E+02,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) -(0.00000E+00,0.00000E+00) +(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.40000E-02,0.00000E+00) (0.12500E+00,0.00000E+00) (-.20000E+00,0.00000E+00) -(0.30000E+01,0.00000E+00) +(0.30000E+01,0.00000E+00) 2 5 (6.4000E+01,0.00000E+00) (2.5000E-01,0.00000E+00) (5.00000E-01,0.00000E+00) @@ -296,40 +296,40 @@ CBL: Tests CGEBAL 5 (0.10000E+04,0.00000E+00) (0.20000E+01,0.00000E+00) (0.30000E+01,0.00000E+00) -(0.40000E+01,0.00000E+00) (0.50000E+06,0.00000E+00) +(0.40000E+01,0.00000E+00) (0.50000E+06,0.00000E+00) (0.90000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E-03,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.30000E+01,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.30000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.30000E+03,0.00000E+00) (0.20000E+01,0.00000E+00) -(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) +(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.90000E+01,0.00000E+00) (0.20000E-02,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.10000E+01,0.00000E+00) (-.10000E+04,0.00000E+00) +(0.10000E+01,0.00000E+00) (-.10000E+04,0.00000E+00) (0.60000E+01,0.00000E+00) (0.20000E+03,0.00000E+00) (0.10000E+01,0.00000E+00) -(0.60000E+03,0.00000E+00) (0.30000E+01,0.00000E+00) +(0.60000E+03,0.00000E+00) (0.30000E+01,0.00000E+00) 1 5 - (1.0000E+03,0.00000E+00) (3.1250E-02,0.00000E+00) (3.7500E-01,0.00000E+00) + (1.0000E+03,0.00000E+00) (3.1250E-02,0.00000E+00) (3.7500E-01,0.00000E+00) (6.2500E-02,0.00000E+00) (3.90625E+03,0.00000E+00) - (5.7600E+02,0.00000E+00) (0.0000E+00,0.00000E+00) (1.6000E-03,0.00000E+00) + (5.7600E+02,0.00000E+00) (0.0000E+00,0.00000E+00) (1.6000E-03,0.00000E+00) (1.0000E+00,0.00000E+00) (1.5000E+00,0.00000E+00) - (0.0000E+00,0.00000E+00) (-3.7500E+01,0.00000E+00) (2.0000E+00,0.00000E+00) + (0.0000E+00,0.00000E+00) (-3.7500E+01,0.00000E+00) (2.0000E+00,0.00000E+00) (1.2500E-01,0.00000E+00) (6.2500E-02,0.00000E+00) - (5.7600E+02,0.00000E+00) (2.0000E-03,0.00000E+00) (8.0000E+00,0.00000E+00) + (5.7600E+02,0.00000E+00) (2.0000E-03,0.00000E+00) (8.0000E+00,0.00000E+00) (1.0000E+00,0.00000E+00) (-5.0000E+02,0.00000E+00) - (7.6800E+02,0.00000E+00) (4.0000E+02,0.00000E+00) (1.6000E+01,0.00000E+00) + (7.6800E+02,0.00000E+00) (4.0000E+02,0.00000E+00) (1.6000E+01,0.00000E+00) (1.2000E+03,0.00000E+00) (3.0000E+00,0.00000E+00) 1.2800E+02 2.0000E+00 1.6000E+01 2.0000E+00 1.0000E+00 5 -(1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00) +(1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) -(1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) +(1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) -(0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) +(0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00) -(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) +(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) -(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) +(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) 1 5 diff --git a/lapack-netlib/TESTING/ced.in b/lapack-netlib/TESTING/ced.in index dde30fa882..ef6c9e36e5 100644 --- a/lapack-netlib/TESTING/ced.in +++ b/lapack-netlib/TESTING/ced.in @@ -35,489 +35,489 @@ CSX 21 Use all matrix types 1.0000E+00 1.0000E+00 5 3 0 2 3 4 -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) 1.0000E+00 2.9582E-31 5 3 0 1 3 5 -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) 1.0000E+00 1.0000E+00 5 2 0 2 4 -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 4.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 4.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 5.0000E+00, 0.0000E+00) 1.0000E+00 1.0000E+00 6 3 1 3 4 6 -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 1.0000E+00) 1.0000E+00 2.0000E+00 6 3 0 1 3 5 -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) ( 0.0000E+00, 1.0000E+00) 1.0000E+00 2.0000E+00 4 2 0 3 4 -( 9.4480E-01, 1.0000E+00) -( 6.7670E-01, 1.0000E+00) -( 6.9080E-01, 1.0000E+00) +( 9.4480E-01, 1.0000E+00) +( 6.7670E-01, 1.0000E+00) +( 6.9080E-01, 1.0000E+00) ( 5.9650E-01, 1.0000E+00) -( 5.8760E-01, 1.0000E+00) -( 8.6420E-01, 1.0000E+00) -( 6.7690E-01, 1.0000E+00) +( 5.8760E-01, 1.0000E+00) +( 8.6420E-01, 1.0000E+00) +( 6.7690E-01, 1.0000E+00) ( 7.2600E-02, 1.0000E+00) -( 7.2560E-01, 1.0000E+00) -( 1.9430E-01, 1.0000E+00) -( 9.6870E-01, 1.0000E+00) +( 7.2560E-01, 1.0000E+00) +( 1.9430E-01, 1.0000E+00) +( 9.6870E-01, 1.0000E+00) ( 2.8310E-01, 1.0000E+00) -( 2.8490E-01, 1.0000E+00) -( 5.8000E-02, 1.0000E+00) -( 4.8450E-01, 1.0000E+00) +( 2.8490E-01, 1.0000E+00) +( 5.8000E-02, 1.0000E+00) +( 4.8450E-01, 1.0000E+00) ( 7.3610E-01, 1.0000E+00) 9.6350E-01 3.3122E-01 4 2 0 2 3 -( 2.1130E-01, 9.9330E-01) -( 8.0960E-01, 4.2370E-01) -( 4.8320E-01, 1.1670E-01) +( 2.1130E-01, 9.9330E-01) +( 8.0960E-01, 4.2370E-01) +( 4.8320E-01, 1.1670E-01) ( 6.5380E-01, 4.9430E-01) -( 8.2400E-02, 8.3600E-01) -( 8.4740E-01, 2.6130E-01) -( 6.1350E-01, 6.2500E-01) +( 8.2400E-02, 8.3600E-01) +( 8.4740E-01, 2.6130E-01) +( 6.1350E-01, 6.2500E-01) ( 4.8990E-01, 3.6500E-02) -( 7.5990E-01, 7.4690E-01) -( 4.5240E-01, 2.4030E-01) -( 2.7490E-01, 5.5100E-01) +( 7.5990E-01, 7.4690E-01) +( 4.5240E-01, 2.4030E-01) +( 2.7490E-01, 5.5100E-01) ( 7.7410E-01, 2.2600E-01) -( 8.7000E-03, 3.7800E-02) -( 8.0750E-01, 3.4050E-01) -( 8.8070E-01, 3.5500E-01) +( 8.7000E-03, 3.7800E-02) +( 8.0750E-01, 3.4050E-01) +( 8.8070E-01, 3.5500E-01) ( 9.6260E-01, 8.1590E-01) 8.4053E-01 7.4754E-01 3 2 0 2 3 -( 1.0000E+00, 2.0000E+00) -( 3.0000E+00, 4.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 3.0000E+00, 4.0000E+00) ( 2.1000E+01, 2.2000E+01) -( 4.3000E+01, 4.4000E+01) -( 1.3000E+01, 1.4000E+01) +( 4.3000E+01, 4.4000E+01) +( 1.3000E+01, 1.4000E+01) ( 1.5000E+01, 1.6000E+01) -( 5.0000E+00, 6.0000E+00) -( 7.0000E+00, 8.0000E+00) +( 5.0000E+00, 6.0000E+00) +( 7.0000E+00, 8.0000E+00) ( 2.5000E+01, 2.6000E+01) 3.9550E-01 2.0464E+01 4 2 0 1 3 -( 5.0000E+00, 9.0000E+00) -( 5.0000E+00, 5.0000E+00) -(-6.0000E+00,-6.0000E+00) +( 5.0000E+00, 9.0000E+00) +( 5.0000E+00, 5.0000E+00) +(-6.0000E+00,-6.0000E+00) (-7.0000E+00,-7.0000E+00) -( 3.0000E+00, 3.0000E+00) -( 6.0000E+00, 1.0000E+01) -(-5.0000E+00,-5.0000E+00) +( 3.0000E+00, 3.0000E+00) +( 6.0000E+00, 1.0000E+01) +(-5.0000E+00,-5.0000E+00) (-6.0000E+00,-6.0000E+00) -( 2.0000E+00, 2.0000E+00) -( 3.0000E+00, 3.0000E+00) -(-1.0000E+00, 3.0000E+00) +( 2.0000E+00, 2.0000E+00) +( 3.0000E+00, 3.0000E+00) +(-1.0000E+00, 3.0000E+00) (-5.0000E+00,-5.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 2.0000E+00, 2.0000E+00) -(-3.0000E+00,-3.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 2.0000E+00, 2.0000E+00) +(-3.0000E+00,-3.0000E+00) ( 0.0000E+00, 4.0000E+00) 3.3333E-01 1.2569E-01 4 3 0 1 3 4 -( 3.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 2.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 0.0000E+00,-2.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00,-2.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 2.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00,-2.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 2.0000E+00) -( 1.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) -( 0.0000E+00,-2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) 1.0000E+00 8.2843E-01 4 2 0 2 3 -( 7.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 1.0000E+00, 2.0000E+00) +( 7.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 1.0000E+00, 2.0000E+00) (-1.0000E+00, 2.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 7.0000E+00, 0.0000E+00) -( 1.0000E+00,-2.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 7.0000E+00, 0.0000E+00) +( 1.0000E+00,-2.0000E+00) +(-1.0000E+00,-2.0000E+00) +( 1.0000E+00,-2.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 7.0000E+00, 0.0000E+00) +(-3.0000E+00, 0.0000E+00) (-1.0000E+00,-2.0000E+00) -( 1.0000E+00,-2.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 7.0000E+00, 0.0000E+00) +(-2.0000E+00, 2.0000E+00) (-3.0000E+00, 0.0000E+00) -(-1.0000E+00,-2.0000E+00) -(-2.0000E+00, 2.0000E+00) -(-3.0000E+00, 0.0000E+00) ( 7.0000E+00, 0.0000E+00) 9.8985E-01 4.1447E+00 5 2 1 2 3 -( 1.0000E+00, 2.0000E+00) -( 3.0000E+00, 4.0000E+00) -( 2.1000E+01, 2.2000E+01) -( 2.3000E+01, 2.4000E+01) +( 1.0000E+00, 2.0000E+00) +( 3.0000E+00, 4.0000E+00) +( 2.1000E+01, 2.2000E+01) +( 2.3000E+01, 2.4000E+01) ( 4.1000E+01, 4.2000E+01) -( 4.3000E+01, 4.4000E+01) -( 1.3000E+01, 1.4000E+01) -( 1.5000E+01, 1.6000E+01) -( 3.3000E+01, 3.4000E+01) +( 4.3000E+01, 4.4000E+01) +( 1.3000E+01, 1.4000E+01) +( 1.5000E+01, 1.6000E+01) +( 3.3000E+01, 3.4000E+01) ( 3.5000E+01, 3.6000E+01) -( 5.0000E+00, 6.0000E+00) -( 7.0000E+00, 8.0000E+00) -( 2.5000E+01, 2.6000E+01) -( 2.7000E+01, 2.8000E+01) +( 5.0000E+00, 6.0000E+00) +( 7.0000E+00, 8.0000E+00) +( 2.5000E+01, 2.6000E+01) +( 2.7000E+01, 2.8000E+01) ( 4.5000E+01, 4.6000E+01) -( 4.7000E+01, 4.8000E+01) -( 1.7000E+01, 1.8000E+01) -( 1.9000E+01, 2.0000E+01) -( 3.7000E+01, 3.8000E+01) +( 4.7000E+01, 4.8000E+01) +( 1.7000E+01, 1.8000E+01) +( 1.9000E+01, 2.0000E+01) +( 3.7000E+01, 3.8000E+01) ( 3.9000E+01, 4.0000E+01) -( 9.0000E+00, 1.0000E+01) -( 1.1000E+01, 1.2000E+01) -( 2.9000E+01, 3.0000E+01) -( 3.1000E+01, 3.2000E+01) +( 9.0000E+00, 1.0000E+01) +( 1.1000E+01, 1.2000E+01) +( 2.9000E+01, 3.0000E+01) +( 3.1000E+01, 3.2000E+01) ( 4.9000E+01, 5.0000E+01) 3.1088E-01 4.6912E+00 3 2 0 1 2 -( 1.0000E+00, 1.0000E+00) -(-1.0000E+00,-1.0000E+00) +( 1.0000E+00, 1.0000E+00) +(-1.0000E+00,-1.0000E+00) ( 2.0000E+00, 2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -(-1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +(-1.0000E+00, 0.0000E+00) ( 3.0000E+00, 1.0000E+00) 2.2361E-01 1.0000E+00 4 2 1 1 3 -(-4.0000E+00,-2.0000E+00) -(-5.0000E+00,-6.0000E+00) -(-2.0000E+00,-6.0000E+00) +(-4.0000E+00,-2.0000E+00) +(-5.0000E+00,-6.0000E+00) +(-2.0000E+00,-6.0000E+00) ( 0.0000E+00,-2.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) 7.2803E-05 1.1947E-04 7 4 0 1 4 6 7 -( 2.0000E+00, 4.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 6.0000E+00, 2.0000E+00) -( 3.0000E+00, 3.0000E+00) -( 5.0000E+00, 5.0000E+00) -( 2.0000E+00, 6.0000E+00) +( 2.0000E+00, 4.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 6.0000E+00, 2.0000E+00) +( 3.0000E+00, 3.0000E+00) +( 5.0000E+00, 5.0000E+00) +( 2.0000E+00, 6.0000E+00) ( 1.0000E+00, 1.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 1.0000E+00, 3.0000E+00) -( 3.0000E+00, 1.0000E+00) -( 5.0000E+00,-4.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 7.0000E+00, 2.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 1.0000E+00, 3.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 5.0000E+00,-4.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 7.0000E+00, 2.0000E+00) ( 2.0000E+00, 3.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 3.0000E+00,-2.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 6.0000E+00, 3.0000E+00) -( 2.0000E+00, 1.0000E+00) -( 1.0000E+00, 4.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 3.0000E+00,-2.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 6.0000E+00, 3.0000E+00) ( 2.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00, 3.0000E+00) -( 3.0000E+00, 1.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 2.0000E+00, 2.0000E+00) +( 1.0000E+00, 4.0000E+00) +( 2.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00, 3.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 2.0000E+00, 2.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00,-1.0000E+00) +( 2.0000E+00, 2.0000E+00) ( 3.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00,-1.0000E+00) -( 2.0000E+00, 2.0000E+00) -( 3.0000E+00, 1.0000E+00) ( 1.0000E+00, 3.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00,-1.0000E+00) -( 2.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00,-1.0000E+00) +( 2.0000E+00, 1.0000E+00) ( 2.0000E+00, 2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00,-2.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00,-2.0000E+00) ( 1.0000E+00, 1.0000E+00) 3.7241E-01 5.2080E-01 5 3 1 1 3 5 -( 0.0000E+00, 5.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 2.0000E+00, 3.0000E+00) -(-3.0000E+00, 6.0000E+00) +( 0.0000E+00, 5.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 2.0000E+00, 3.0000E+00) +(-3.0000E+00, 6.0000E+00) ( 6.0000E+00, 0.0000E+00) -(-1.0000E+00, 2.0000E+00) -( 0.0000E+00, 6.0000E+00) -( 4.0000E+00, 5.0000E+00) -(-3.0000E+00,-2.0000E+00) +(-1.0000E+00, 2.0000E+00) +( 0.0000E+00, 6.0000E+00) +( 4.0000E+00, 5.0000E+00) +(-3.0000E+00,-2.0000E+00) ( 5.0000E+00, 0.0000E+00) -(-2.0000E+00, 3.0000E+00) -(-4.0000E+00, 5.0000E+00) -( 0.0000E+00, 7.0000E+00) -( 3.0000E+00, 0.0000E+00) +(-2.0000E+00, 3.0000E+00) +(-4.0000E+00, 5.0000E+00) +( 0.0000E+00, 7.0000E+00) +( 3.0000E+00, 0.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 3.0000E+00, 6.0000E+00) -( 3.0000E+00,-2.0000E+00) -(-3.0000E+00, 0.0000E+00) -( 0.0000E+00,-5.0000E+00) +( 3.0000E+00, 6.0000E+00) +( 3.0000E+00,-2.0000E+00) +(-3.0000E+00, 0.0000E+00) +( 0.0000E+00,-5.0000E+00) ( 2.0000E+00, 1.0000E+00) -(-6.0000E+00, 0.0000E+00) -(-5.0000E+00, 0.0000E+00) -(-2.0000E+00, 0.0000E+00) -(-2.0000E+00, 1.0000E+00) +(-6.0000E+00, 0.0000E+00) +(-5.0000E+00, 0.0000E+00) +(-2.0000E+00, 0.0000E+00) +(-2.0000E+00, 1.0000E+00) ( 0.0000E+00, 2.0000E+00) 1.0000E+00 4.5989E+00 8 4 1 1 2 3 4 -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 2.0000E+00) -( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 2.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 2.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00, 2.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 3.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 0.0000E+00, 3.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 3.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00, 3.0000E+00) ( 3.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 4.0000E+00) -( 4.0000E+00, 0.0000E+00) -( 0.0000E+00, 4.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 4.0000E+00) +( 4.0000E+00, 0.0000E+00) +( 0.0000E+00, 4.0000E+00) ( 4.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 9.5000E-01) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 9.5000E-01) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 9.5000E-01) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 9.5000E-01) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 9.5000E-01) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 9.5000E-01) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 9.5000E-01) 9.5269E-12 2.9360E-11 3 2 0 2 3 -( 2.0000E+00, 0.0000E+00) -( 0.0000E+00,-1.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00,-1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 2.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) ( 3.0000E+00, 0.0000E+00) 1.0000E+00 2.0000E+00 0 0 0 @@ -537,51 +537,51 @@ CVX 21 Use all matrix types ( 0.0000E+00, 1.0000E+00) 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 2 0 -( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 2 0 -( 3.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 2.0000E+00, 0.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 2.0000E+00, 0.0000E+00) ( 3.0000E+00, 0.0000E+00) 1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00 5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00 2 0 -( 3.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00, 2.0000E+00) ( 0.0000E+00, 2.0000E+00) -( 0.0000E+00, 2.0000E+00) ( 3.0000E+00, 0.0000E+00) 3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00 3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00 5 0 -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 @@ -589,30 +589,30 @@ CVX 21 Use all matrix types 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 5 0 -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 @@ -620,30 +620,30 @@ CVX 21 Use all matrix types 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 5 0 -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 4.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 4.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 5.0000E+00, 0.0000E+00) 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 @@ -651,41 +651,41 @@ CVX 21 Use all matrix types 4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 6 0 -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 1.0000E+00) 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00 @@ -694,41 +694,41 @@ CVX 21 Use all matrix types 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00 6 0 -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) ( 0.0000E+00, 1.0000E+00) 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00 @@ -737,148 +737,148 @@ CVX 21 Use all matrix types 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00 4 0 -( 9.4480E-01, 1.0000E+00) -( 6.7670E-01, 1.0000E+00) -( 6.9080E-01, 1.0000E+00) +( 9.4480E-01, 1.0000E+00) +( 6.7670E-01, 1.0000E+00) +( 6.9080E-01, 1.0000E+00) ( 5.9650E-01, 1.0000E+00) -( 5.8760E-01, 1.0000E+00) -( 8.6420E-01, 1.0000E+00) -( 6.7690E-01, 1.0000E+00) +( 5.8760E-01, 1.0000E+00) +( 8.6420E-01, 1.0000E+00) +( 6.7690E-01, 1.0000E+00) ( 7.2600E-02, 1.0000E+00) -( 7.2560E-01, 1.0000E+00) -( 1.9430E-01, 1.0000E+00) -( 9.6870E-01, 1.0000E+00) +( 7.2560E-01, 1.0000E+00) +( 1.9430E-01, 1.0000E+00) +( 9.6870E-01, 1.0000E+00) ( 2.8310E-01, 1.0000E+00) -( 2.8490E-01, 1.0000E+00) -( 5.8000E-02, 1.0000E+00) -( 4.8450E-01, 1.0000E+00) +( 2.8490E-01, 1.0000E+00) +( 5.8000E-02, 1.0000E+00) +( 4.8450E-01, 1.0000E+00) ( 7.3610E-01, 1.0000E+00) 2.6014E-01 -1.7813E-01 8.5279E-01 3.2881E-01 2.8961E-01 2.0772E-01 8.4871E-01 3.2358E-01 7.3990E-01 -4.6522E-04 9.7398E-01 3.4994E-01 2.2242E+00 3.9709E+00 9.8325E-01 4.1429E+00 4 0 -( 2.1130E-01, 9.9330E-01) -( 8.0960E-01, 4.2370E-01) -( 4.8320E-01, 1.1670E-01) +( 2.1130E-01, 9.9330E-01) +( 8.0960E-01, 4.2370E-01) +( 4.8320E-01, 1.1670E-01) ( 6.5380E-01, 4.9430E-01) -( 8.2400E-02, 8.3600E-01) -( 8.4740E-01, 2.6130E-01) -( 6.1350E-01, 6.2500E-01) +( 8.2400E-02, 8.3600E-01) +( 8.4740E-01, 2.6130E-01) +( 6.1350E-01, 6.2500E-01) ( 4.8990E-01, 3.6500E-02) -( 7.5990E-01, 7.4690E-01) -( 4.5240E-01, 2.4030E-01) -( 2.7490E-01, 5.5100E-01) +( 7.5990E-01, 7.4690E-01) +( 4.5240E-01, 2.4030E-01) +( 2.7490E-01, 5.5100E-01) ( 7.7410E-01, 2.2600E-01) -( 8.7000E-03, 3.7800E-02) -( 8.0750E-01, 3.4050E-01) -( 8.8070E-01, 3.5500E-01) +( 8.7000E-03, 3.7800E-02) +( 8.0750E-01, 3.4050E-01) +( 8.8070E-01, 3.5500E-01) ( 9.6260E-01, 8.1590E-01) -6.2157E-01 6.0607E-01 8.7533E-01 8.1980E-01 2.8890E-01 -2.6354E-01 8.2538E-01 8.1086E-01 3.8017E-01 5.4217E-01 7.4771E-01 7.0323E-01 2.2487E+00 1.7368E+00 9.2372E-01 2.2178E+00 3 0 -( 1.0000E+00, 2.0000E+00) -( 3.0000E+00, 4.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 3.0000E+00, 4.0000E+00) ( 2.1000E+01, 2.2000E+01) -( 4.3000E+01, 4.4000E+01) -( 1.3000E+01, 1.4000E+01) +( 4.3000E+01, 4.4000E+01) +( 1.3000E+01, 1.4000E+01) ( 1.5000E+01, 1.6000E+01) -( 5.0000E+00, 6.0000E+00) -( 7.0000E+00, 8.0000E+00) +( 5.0000E+00, 6.0000E+00) +( 7.0000E+00, 8.0000E+00) ( 2.5000E+01, 2.6000E+01) -7.4775E+00 6.8803E+00 3.9550E-01 1.6583E+01 6.7009E+00 -7.8760E+00 3.9828E-01 1.6312E+01 3.9777E+01 4.2996E+01 7.9686E-01 3.7399E+01 4 0 -( 5.0000E+00, 9.0000E+00) -( 5.0000E+00, 5.0000E+00) -(-6.0000E+00,-6.0000E+00) +( 5.0000E+00, 9.0000E+00) +( 5.0000E+00, 5.0000E+00) +(-6.0000E+00,-6.0000E+00) (-7.0000E+00,-7.0000E+00) -( 3.0000E+00, 3.0000E+00) -( 6.0000E+00, 1.0000E+01) -(-5.0000E+00,-5.0000E+00) +( 3.0000E+00, 3.0000E+00) +( 6.0000E+00, 1.0000E+01) +(-5.0000E+00,-5.0000E+00) (-6.0000E+00,-6.0000E+00) -( 2.0000E+00, 2.0000E+00) -( 3.0000E+00, 3.0000E+00) -(-1.0000E+00, 3.0000E+00) +( 2.0000E+00, 2.0000E+00) +( 3.0000E+00, 3.0000E+00) +(-1.0000E+00, 3.0000E+00) (-5.0000E+00,-5.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 2.0000E+00, 2.0000E+00) -(-3.0000E+00,-3.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 2.0000E+00, 2.0000E+00) +(-3.0000E+00,-3.0000E+00) ( 0.0000E+00, 4.0000E+00) 1.0000E+00 5.0000E+00 2.1822E-01 7.4651E-01 2.0000E+00 6.0000E+00 2.1822E-01 3.0893E-01 3.0000E+00 7.0000E+00 2.1822E-01 1.8315E-01 4.0000E+00 8.0000E+00 2.1822E-01 6.6350E-01 4 0 -( 3.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 2.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 0.0000E+00,-2.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 0.0000E+00,-2.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 2.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00,-2.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 2.0000E+00) -( 1.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) -( 0.0000E+00,-2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) ( 1.0000E+00, 0.0000E+00) -8.2843E-01 1.6979E-07 1.0000E+00 8.2843E-01 4.1744E-07 7.1526E-08 1.0000E+00 8.2843E-01 4.0000E+00 1.6690E-07 1.0000E+00 8.2843E-01 4.8284E+00 6.8633E-08 1.0000E+00 8.2843E-01 4 0 -( 7.0000E+00, 0.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 1.0000E+00, 2.0000E+00) +( 7.0000E+00, 0.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 1.0000E+00, 2.0000E+00) (-1.0000E+00, 2.0000E+00) -( 3.0000E+00, 0.0000E+00) -( 7.0000E+00, 0.0000E+00) -( 1.0000E+00,-2.0000E+00) +( 3.0000E+00, 0.0000E+00) +( 7.0000E+00, 0.0000E+00) +( 1.0000E+00,-2.0000E+00) +(-1.0000E+00,-2.0000E+00) +( 1.0000E+00,-2.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 7.0000E+00, 0.0000E+00) +(-3.0000E+00, 0.0000E+00) (-1.0000E+00,-2.0000E+00) -( 1.0000E+00,-2.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 7.0000E+00, 0.0000E+00) +(-2.0000E+00, 2.0000E+00) (-3.0000E+00, 0.0000E+00) -(-1.0000E+00,-2.0000E+00) -(-2.0000E+00, 2.0000E+00) -(-3.0000E+00, 0.0000E+00) ( 7.0000E+00, 0.0000E+00) -8.0767E-03 -2.5211E-01 9.9864E-01 7.7961E+00 7.7723E+00 2.4349E-01 7.0272E-01 3.3337E-01 8.0000E+00 -3.4273E-07 7.0711E-01 3.3337E-01 1.2236E+01 8.6188E-03 9.9021E-01 3.9429E+00 5 0 -( 1.0000E+00, 2.0000E+00) -( 3.0000E+00, 4.0000E+00) -( 2.1000E+01, 2.2000E+01) -( 2.3000E+01, 2.4000E+01) +( 1.0000E+00, 2.0000E+00) +( 3.0000E+00, 4.0000E+00) +( 2.1000E+01, 2.2000E+01) +( 2.3000E+01, 2.4000E+01) ( 4.1000E+01, 4.2000E+01) -( 4.3000E+01, 4.4000E+01) -( 1.3000E+01, 1.4000E+01) -( 1.5000E+01, 1.6000E+01) -( 3.3000E+01, 3.4000E+01) +( 4.3000E+01, 4.4000E+01) +( 1.3000E+01, 1.4000E+01) +( 1.5000E+01, 1.6000E+01) +( 3.3000E+01, 3.4000E+01) ( 3.5000E+01, 3.6000E+01) -( 5.0000E+00, 6.0000E+00) -( 7.0000E+00, 8.0000E+00) -( 2.5000E+01, 2.6000E+01) -( 2.7000E+01, 2.8000E+01) +( 5.0000E+00, 6.0000E+00) +( 7.0000E+00, 8.0000E+00) +( 2.5000E+01, 2.6000E+01) +( 2.7000E+01, 2.8000E+01) ( 4.5000E+01, 4.6000E+01) -( 4.7000E+01, 4.8000E+01) -( 1.7000E+01, 1.8000E+01) -( 1.9000E+01, 2.0000E+01) -( 3.7000E+01, 3.8000E+01) +( 4.7000E+01, 4.8000E+01) +( 1.7000E+01, 1.8000E+01) +( 1.9000E+01, 2.0000E+01) +( 3.7000E+01, 3.8000E+01) ( 3.9000E+01, 4.0000E+01) -( 9.0000E+00, 1.0000E+01) -( 1.1000E+01, 1.2000E+01) -( 2.9000E+01, 3.0000E+01) -( 3.1000E+01, 3.2000E+01) +( 9.0000E+00, 1.0000E+01) +( 1.1000E+01, 1.2000E+01) +( 2.9000E+01, 3.0000E+01) +( 3.1000E+01, 3.2000E+01) ( 4.9000E+01, 5.0000E+01) -9.4600E+00 7.2802E+00 3.1053E-01 1.1937E+01 -7.7912E-06 -1.2743E-05 2.9408E-01 1.6030E-05 @@ -886,88 +886,88 @@ CVX 21 Use all matrix types 7.0733E+00 -9.5584E+00 3.0911E-01 1.1891E+01 1.2739E+02 1.3228E+02 9.2770E-01 1.2111E+02 3 0 -( 1.0000E+00, 1.0000E+00) -(-1.0000E+00,-1.0000E+00) +( 1.0000E+00, 1.0000E+00) +(-1.0000E+00,-1.0000E+00) ( 2.0000E+00, 2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -(-1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +(-1.0000E+00, 0.0000E+00) ( 3.0000E+00, 1.0000E+00) 1.0000E+00 1.0000E+00 3.0151E-01 0.0000E+00 1.0000E+00 1.0000E+00 3.1623E-01 0.0000E+00 2.0000E+00 1.0000E+00 2.2361E-01 1.0000E+00 4 1 -(-4.0000E+00,-2.0000E+00) -(-5.0000E+00,-6.0000E+00) -(-2.0000E+00,-6.0000E+00) +(-4.0000E+00,-2.0000E+00) +(-5.0000E+00,-6.0000E+00) +(-2.0000E+00,-6.0000E+00) ( 0.0000E+00,-2.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -9.9883E-01 -1.0006E+00 1.3180E-04 2.4106E-04 -1.0012E+00 -9.9945E-01 1.3140E-04 2.4041E-04 -9.9947E-01 -6.8325E-04 1.3989E-04 8.7487E-05 -1.0005E+00 6.8556E-04 1.4010E-04 8.7750E-05 7 0 -( 2.0000E+00, 4.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 6.0000E+00, 2.0000E+00) -( 3.0000E+00, 3.0000E+00) -( 5.0000E+00, 5.0000E+00) -( 2.0000E+00, 6.0000E+00) +( 2.0000E+00, 4.0000E+00) ( 1.0000E+00, 1.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 1.0000E+00, 3.0000E+00) -( 3.0000E+00, 1.0000E+00) -( 5.0000E+00,-4.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 7.0000E+00, 2.0000E+00) +( 6.0000E+00, 2.0000E+00) +( 3.0000E+00, 3.0000E+00) +( 5.0000E+00, 5.0000E+00) +( 2.0000E+00, 6.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 1.0000E+00, 3.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 5.0000E+00,-4.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 7.0000E+00, 2.0000E+00) ( 2.0000E+00, 3.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 3.0000E+00,-2.0000E+00) -( 1.0000E+00, 1.0000E+00) -( 6.0000E+00, 3.0000E+00) -( 2.0000E+00, 1.0000E+00) -( 1.0000E+00, 4.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 3.0000E+00,-2.0000E+00) +( 1.0000E+00, 1.0000E+00) +( 6.0000E+00, 3.0000E+00) +( 2.0000E+00, 1.0000E+00) +( 1.0000E+00, 4.0000E+00) ( 2.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00, 3.0000E+00) -( 3.0000E+00, 1.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 2.0000E+00, 2.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00, 3.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 2.0000E+00, 2.0000E+00) +( 3.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00,-1.0000E+00) +( 2.0000E+00, 2.0000E+00) ( 3.0000E+00, 1.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00,-1.0000E+00) -( 2.0000E+00, 2.0000E+00) -( 3.0000E+00, 1.0000E+00) ( 1.0000E+00, 3.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 1.0000E+00,-1.0000E+00) -( 2.0000E+00, 1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 1.0000E+00,-1.0000E+00) +( 2.0000E+00, 1.0000E+00) ( 2.0000E+00, 2.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 2.0000E+00,-2.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 2.0000E+00,-2.0000E+00) ( 1.0000E+00, 1.0000E+00) -2.7081E+00 -2.8029E+00 6.9734E-01 3.9279E+00 -1.1478E+00 8.0176E-01 6.5772E-01 9.4243E-01 @@ -977,30 +977,30 @@ CVX 21 Use all matrix types 5.3138E+00 1.2242E+00 3.0213E-01 7.1268E-01 8.2674E+00 3.7047E+00 2.8270E-01 3.2849E+00 5 1 -( 0.0000E+00, 5.0000E+00) -( 1.0000E+00, 2.0000E+00) -( 2.0000E+00, 3.0000E+00) -(-3.0000E+00, 6.0000E+00) +( 0.0000E+00, 5.0000E+00) +( 1.0000E+00, 2.0000E+00) +( 2.0000E+00, 3.0000E+00) +(-3.0000E+00, 6.0000E+00) ( 6.0000E+00, 0.0000E+00) -(-1.0000E+00, 2.0000E+00) -( 0.0000E+00, 6.0000E+00) -( 4.0000E+00, 5.0000E+00) -(-3.0000E+00,-2.0000E+00) +(-1.0000E+00, 2.0000E+00) +( 0.0000E+00, 6.0000E+00) +( 4.0000E+00, 5.0000E+00) +(-3.0000E+00,-2.0000E+00) ( 5.0000E+00, 0.0000E+00) -(-2.0000E+00, 3.0000E+00) -(-4.0000E+00, 5.0000E+00) -( 0.0000E+00, 7.0000E+00) -( 3.0000E+00, 0.0000E+00) +(-2.0000E+00, 3.0000E+00) +(-4.0000E+00, 5.0000E+00) +( 0.0000E+00, 7.0000E+00) +( 3.0000E+00, 0.0000E+00) ( 2.0000E+00, 0.0000E+00) -( 3.0000E+00, 6.0000E+00) -( 3.0000E+00,-2.0000E+00) -(-3.0000E+00, 0.0000E+00) -( 0.0000E+00,-5.0000E+00) +( 3.0000E+00, 6.0000E+00) +( 3.0000E+00,-2.0000E+00) +(-3.0000E+00, 0.0000E+00) +( 0.0000E+00,-5.0000E+00) ( 2.0000E+00, 1.0000E+00) -(-6.0000E+00, 0.0000E+00) -(-5.0000E+00, 0.0000E+00) -(-2.0000E+00, 0.0000E+00) -(-2.0000E+00, 1.0000E+00) +(-6.0000E+00, 0.0000E+00) +(-5.0000E+00, 0.0000E+00) +(-2.0000E+00, 0.0000E+00) +(-2.0000E+00, 1.0000E+00) ( 0.0000E+00, 2.0000E+00) -4.1735E-08 -1.0734E+01 1.0000E+00 7.7345E+00 -2.6397E-07 -2.9991E+00 1.0000E+00 4.5989E+00 @@ -1008,14 +1008,14 @@ CVX 21 Use all matrix types -4.4369E-07 9.3159E+00 1.0000E+00 7.7161E+00 4.0937E-09 1.7817E+01 1.0000E+00 8.5013E+00 3 0 -( 2.0000E+00, 0.0000E+00) -( 0.0000E+00,-1.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00,-1.0000E+00) +( 0.0000E+00, 0.0000E+00) +( 0.0000E+00, 1.0000E+00) +( 2.0000E+00, 0.0000E+00) +( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 1.0000E+00) -( 2.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) -( 0.0000E+00, 0.0000E+00) ( 3.0000E+00, 0.0000E+00) 1.0000E+00 0.0000E+00 1.0000E+00 2.0000E+00 3.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 diff --git a/lapack-netlib/TESTING/cgbak.in b/lapack-netlib/TESTING/cgbak.in index 970fb26d67..0f6a3f5808 100644 --- a/lapack-netlib/TESTING/cgbak.in +++ b/lapack-netlib/TESTING/cgbak.in @@ -443,4 +443,4 @@ CGK: Tests CGGBAK (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) -0 0 +0 0 diff --git a/lapack-netlib/TESTING/cgbal.in b/lapack-netlib/TESTING/cgbal.in index 6fa3155052..51ce6931cc 100644 --- a/lapack-netlib/TESTING/cgbal.in +++ b/lapack-netlib/TESTING/cgbal.in @@ -657,4 +657,4 @@ CGL: Tests CGGBAL 0.2000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.5000E+01 0.5000E+01 -0 +0 diff --git a/lapack-netlib/TESTING/cgd.in b/lapack-netlib/TESTING/cgd.in index da7d4a42e0..a030a78a4d 100644 --- a/lapack-netlib/TESTING/cgd.in +++ b/lapack-netlib/TESTING/cgd.in @@ -1,6 +1,6 @@ CGV Data for the Complex Nonsymmetric Eigenvalue Driver 6 Number of matrix dimensions -2 6 8 10 12 20 Matrix dimensions +2 6 8 10 12 20 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -8,7 +8,7 @@ CGV Data for the Complex Nonsymmetric Eigenvalue Driver CGV 26 Test all 26 matrix types CGS Data for the Complex Nonsymmetric Schur Form Driver 5 Number of matrix dimensions -2 6 10 12 20 30 Matrix dimensions +2 6 10 12 20 30 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -32,11 +32,11 @@ CGX Data for the Complex Nonsymmetric Schur Form Expert Driver 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed - 4 + 4 2 ( 2.0000E+00, 6.0000E+00) ( 2.0000E+00, 5.0000E+00) -( 3.0000E+00,-1.0000E+01) +( 3.0000E+00,-1.0000E+01) ( 4.0000E+00, 7.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 9.0000E+00, 2.0000E+00) @@ -50,7 +50,7 @@ CGX Data for the Complex Nonsymmetric Schur Form Expert Driver ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 1.0000E+01,-1.6000E+01) -(-9.0000E+00, 1.0000E+00) +(-9.0000E+00, 1.0000E+00) (-1.0000E+00,-8.0000E+00) (-1.0000E+00, 1.0000E+01) ( 2.0000E+00,-6.0000E+00) @@ -67,12 +67,12 @@ CGX Data for the Complex Nonsymmetric Schur Form Expert Driver ( 0.0000E+00, 0.0000E+00) ( 8.0000E+00, 4.0000E+00) 7.6883E-02 2.1007E-01 Condition #'s for cluster selected from lower 2x2 - 4 + 4 2 ( 1.0000E+00, 8.0000E+00) ( 2.0000E+00, 4.0000E+00) ( 3.0000E+00,-1.3000E+01) -( 4.0000E+00, 4.0000E+00) +( 4.0000E+00, 4.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 5.0000E+00, 7.0000E+00) ( 6.0000E+00,-2.4000E+01) @@ -112,7 +112,7 @@ CXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver 4 ( 2.0000E+00, 6.0000E+00) ( 2.0000E+00, 5.0000E+00) -( 3.0000E+00,-1.0000E+01) +( 3.0000E+00,-1.0000E+01) ( 4.0000E+00, 7.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 9.0000E+00, 2.0000E+00) @@ -126,7 +126,7 @@ CXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 1.0000E+01,-1.6000E+01) -(-9.0000E+00, 1.0000E+00) +(-9.0000E+00, 1.0000E+00) (-1.0000E+00,-8.0000E+00) (-1.0000E+00, 1.0000E+01) ( 2.0000E+00,-6.0000E+00) @@ -144,11 +144,11 @@ CXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver ( 8.0000E+00, 4.0000E+00) 5.2612E+00 8.0058E-01 1.4032E+00 4.0073E+00 condition #'s for eigenvalues 1.1787E+00 3.3139E+00 1.1835E+00 2.0777E+00 condition #'s for eigenvectors - 4 + 4 ( 1.0000E+00, 8.0000E+00) ( 2.0000E+00, 4.0000E+00) ( 3.0000E+00,-1.3000E+01) -( 4.0000E+00, 4.0000E+00) +( 4.0000E+00, 4.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 5.0000E+00, 7.0000E+00) ( 6.0000E+00,-2.4000E+01) diff --git a/lapack-netlib/TESTING/ctest.in b/lapack-netlib/TESTING/ctest.in index e46549310e..c5ed21fde7 100644 --- a/lapack-netlib/TESTING/ctest.in +++ b/lapack-netlib/TESTING/ctest.in @@ -24,9 +24,12 @@ CPB 8 List types on next line if 0 < NTYPES < 8 CPT 12 List types on next line if 0 < NTYPES < 12 CHE 10 List types on next line if 0 < NTYPES < 10 CHR 10 List types on next line if 0 < NTYPES < 10 +CHK 10 List types on next line if 0 < NTYPES < 10 +CHA 10 List types on next line if 0 < NTYPES < 10 CHP 10 List types on next line if 0 < NTYPES < 10 CSY 11 List types on next line if 0 < NTYPES < 11 CSR 11 List types on next line if 0 < NTYPES < 11 +CSK 11 List types on next line if 0 < NTYPES < 11 CSP 11 List types on next line if 0 < NTYPES < 11 CTR 18 List types on next line if 0 < NTYPES < 18 CTP 18 List types on next line if 0 < NTYPES < 18 @@ -41,3 +44,6 @@ CLS 6 List types on next line if 0 < NTYPES < 6 CEQ CQT CQX +CXQ +CTQ +CTS diff --git a/lapack-netlib/TESTING/ctest_rfp.in b/lapack-netlib/TESTING/ctest_rfp.in index 2975f225de..d6988f2a75 100644 --- a/lapack-netlib/TESTING/ctest_rfp.in +++ b/lapack-netlib/TESTING/ctest_rfp.in @@ -5,5 +5,5 @@ Data file for testing COMPLEX LAPACK linear equation routines RFP format 1 2 15 Values of NRHS (number of right hand sides) 9 Number of matrix types (list types on next line if 0 < NTYPES < 9) 1 2 3 4 5 6 7 8 9 Matrix Types -60.0 Threshold value of test ratio +30.0 Threshold value of test ratio T Put T to test the error exits diff --git a/lapack-netlib/TESTING/dbak.in b/lapack-netlib/TESTING/dbak.in index cb69cb34a2..fc93a32db7 100644 --- a/lapack-netlib/TESTING/dbak.in +++ b/lapack-netlib/TESTING/dbak.in @@ -127,4 +127,4 @@ DBK: Tests DGEBAK 0.0000D+00 -0.2734D-02 -0.7946D-02 0.6303D-02 0.1000D-01 -0.6279D-02 0.1000D-01 - 0 0 0 + 0 0 0 diff --git a/lapack-netlib/TESTING/dbal.in b/lapack-netlib/TESTING/dbal.in index 103d090538..94268a117b 100644 --- a/lapack-netlib/TESTING/dbal.in +++ b/lapack-netlib/TESTING/dbal.in @@ -106,9 +106,9 @@ DBL: Tests DGEBAL -2.0000D+06 3.0000D+00 4.0000D-06 3.0000D-06 -1.5000D+06 0.0000D-03 1.0000D-06 1.0000D+00 1.0000D+06 0.0000D-03 6.0000D-06 4.0000D+06 - + 1.0000D+00 1.0000D+00 2.0000D+00 1.0000D+00 - + 4 0.1000D+01 0.1000D+05 0.1000D+05 0.1000D+05 -0.2000D+05 0.3000D+01 0.2000D-02 0.3000D-02 @@ -122,7 +122,7 @@ DBL: Tests DGEBAL 0.0000D-03 0.0000D-03 20.0000D+03 0.0000D-03 1.0000D+00 1.0000D+00 1.0000D+00 500.0000D-03 - + 5 0.1000D+01 0.5120D+03 0.4096D+04 3.2768D+04 2.62144D+05 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 diff --git a/lapack-netlib/TESTING/dgbak.in b/lapack-netlib/TESTING/dgbak.in index 633ec77abb..edf304d8db 100644 --- a/lapack-netlib/TESTING/dgbak.in +++ b/lapack-netlib/TESTING/dgbak.in @@ -263,4 +263,4 @@ DGK: Tests DGGBAK 0.5000D+02 0.5000D+02 0.6000D+02 0.6000D+02 -0 0 +0 0 diff --git a/lapack-netlib/TESTING/dgd.in b/lapack-netlib/TESTING/dgd.in index 42ff716ab0..ca24dd2a04 100644 --- a/lapack-netlib/TESTING/dgd.in +++ b/lapack-netlib/TESTING/dgd.in @@ -1,6 +1,6 @@ DGS Data for the Real Nonsymmetric Schur Form Driver 5 Number of matrix dimensions -2 6 10 12 20 30 Matrix dimensions +2 6 10 12 20 30 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -8,25 +8,25 @@ DGS Data for the Real Nonsymmetric Schur Form Driver DGS 26 Test all 26 matrix types DGV Data for the Real Nonsymmetric Eigenvalue Problem Driver 6 Number of matrix dimensions -2 6 8 10 15 20 Matrix dimensions +2 6 8 10 15 20 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold value .TRUE. Put T to test the error exits 0 Code to interpret the seed DGV 26 Test all 26 matrix types -DGX Data for the Real Nonsymmetric Schur Form Expert Driver +DGX Data for the Real Nonsymmetric Schur Form Expert Driver 2 Largest matrix dimension (0 <= NSIZE <= 5) 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed -DGX Data for the Real Nonsymmetric Schur Form Expert Driver +DGX Data for the Real Nonsymmetric Schur Form Expert Driver 0 Largest matrix dimension 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed - 4 + 4 2 8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A 0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00 @@ -37,7 +37,7 @@ DGX Data for the Real Nonsymmetric Schur Form Expert Driver 0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 2.5901D-01 1.7592D+00 Condition #'s for cluster selected from lower 2x2 - 4 + 4 2 1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A 0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00 @@ -49,13 +49,13 @@ DGX Data for the Real Nonsymmetric Schur Form Expert Driver 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 9.8173D-01 6.3649D-01 Condition #'s for cluster selected from lower 2x2 0 -DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver +DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver 5 Largest matrix dimension 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed -DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver +DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver 0 Largest matrix dimension 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in index 467a01c802..d05a27ca73 100644 --- a/lapack-netlib/TESTING/dtest.in +++ b/lapack-netlib/TESTING/dtest.in @@ -24,6 +24,8 @@ DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 DSY 10 List types on next line if 0 < NTYPES < 10 DSR 10 List types on next line if 0 < NTYPES < 10 +DSK 10 List types on next line if 0 < NTYPES < 10 +DSA 10 List types on next line if 0 < NTYPES < 10 DSP 10 List types on next line if 0 < NTYPES < 10 DTR 18 List types on next line if 0 < NTYPES < 18 DTP 18 List types on next line if 0 < NTYPES < 18 @@ -38,3 +40,6 @@ DLS 6 List types on next line if 0 < NTYPES < 6 DEQ DQT DQX +DXQ +DTQ +DTS diff --git a/lapack-netlib/TESTING/glm.in b/lapack-netlib/TESTING/glm.in index 4fddc61c9d..f3fd54b7e2 100644 --- a/lapack-netlib/TESTING/glm.in +++ b/lapack-netlib/TESTING/glm.in @@ -1,9 +1,9 @@ GLM: Data file for testing Generalized Linear Regression Model routines 6 Number of values of M, P, and N -0 5 8 15 20 40 Values of M (row dimension) -9 0 15 12 15 30 Values of P (row dimension) +0 5 8 15 20 40 Values of M (row dimension) +9 0 15 12 15 30 Values of P (row dimension) 5 5 10 25 30 40 Values of N (col dimension), M <= N <= M+P 20.0 Threshold value of test ratio T Put T to test the error exits 1 Code to interpret the seed -GLM 8 List types on next line if 0 < NTYPES < 8 +GLM 8 List types on next line if 0 < NTYPES < 8 diff --git a/lapack-netlib/TESTING/gqr.in b/lapack-netlib/TESTING/gqr.in index ccd861caab..449d428890 100644 --- a/lapack-netlib/TESTING/gqr.in +++ b/lapack-netlib/TESTING/gqr.in @@ -1,9 +1,9 @@ GQR: Data file for testing Generalized QR and RQ routines 3 Number of values of M, P and N -0 3 10 Values of M -0 5 20 Values of P +0 3 10 Values of M +0 5 20 Values of P 0 3 30 Values of N 20.0 Threshold value of test ratio T Put T to test the error exits 1 Code to interpret the seed -GQR 8 List types on next line if 0 < NTYPES < 8 +GQR 8 List types on next line if 0 < NTYPES < 8 diff --git a/lapack-netlib/TESTING/lse.in b/lapack-netlib/TESTING/lse.in index 59598545e7..a1b5677cc1 100644 --- a/lapack-netlib/TESTING/lse.in +++ b/lapack-netlib/TESTING/lse.in @@ -1,7 +1,7 @@ LSE: Data file for testing Constrained Linear Least Squares routines 6 Number of values of M, P, and N -6 0 5 8 10 30 Values of M -0 5 5 5 8 20 Values of P +6 0 5 8 10 30 Values of M +0 5 5 5 8 20 Values of P 5 5 6 8 12 40 Values of N, note P<= N <= P+M 20.0 Threshold value of test ratio T Put T to test the error exits diff --git a/lapack-netlib/TESTING/nep.in b/lapack-netlib/TESTING/nep.in index af427fbde4..c4a414910b 100644 --- a/lapack-netlib/TESTING/nep.in +++ b/lapack-netlib/TESTING/nep.in @@ -10,7 +10,7 @@ NEP: Data file for testing Nonsymmetric Eigenvalue Problem routines 0 5 7 3 200 Values of INIBL (nibble crossover point) 1 2 4 2 1 Values of ISHFTS (number of simultaneous shifts) 0 1 2 0 1 Values of IACC22 (select structured matrix multiply: 0, 1 or 2) -40.0 Threshold value +20.0 Threshold value T Put T to test the error exits 1 Code to interpret the seed NEP 21 diff --git a/lapack-netlib/TESTING/runtest.cmake b/lapack-netlib/TESTING/runtest.cmake index 2c96a2b18e..30807c1a68 100644 --- a/lapack-netlib/TESTING/runtest.cmake +++ b/lapack-netlib/TESTING/runtest.cmake @@ -21,7 +21,7 @@ if(DEFINED INPUT) endif() message("Running: ${TEST}") message("ARGS= ${ARGS}") -execute_process(COMMAND "${TEST}" +execute_process(COMMAND "${TEST}" ${ARGS} RESULT_VARIABLE RET) if(DEFINED OUTPUT) diff --git a/lapack-netlib/TESTING/sbak.in b/lapack-netlib/TESTING/sbak.in index 8bfeda3299..0ec11c17c8 100644 --- a/lapack-netlib/TESTING/sbak.in +++ b/lapack-netlib/TESTING/sbak.in @@ -127,4 +127,4 @@ SBK: Tests SGEBAK 0.0000E+00 -0.2734E-02 -0.7946E-02 0.6303E-02 0.1000E-01 -0.6279E-02 0.1000E-01 - 0 0 0 + 0 0 0 diff --git a/lapack-netlib/TESTING/sbal.in b/lapack-netlib/TESTING/sbal.in index 9f7cfd5b35..fac6f8eaeb 100644 --- a/lapack-netlib/TESTING/sbal.in +++ b/lapack-netlib/TESTING/sbal.in @@ -105,9 +105,9 @@ SBL: Tests SGEBAL -2.0000E+06 3.0000E+00 4.0000E-06 3.0000E-06 -1.5000E+06 0.0000E-03 1.0000E-06 1.0000E+00 1.0000E+06 0.0000E-03 6.0000E-06 4.0000E+06 - + 1.0000E+00 1.0000E+00 2.0000E+00 1.0000E+00 - + 4 0.1000E+01 0.1000E+05 0.1000E+05 0.1000E+05 -0.2000E+05 0.3000E+01 0.2000E-02 0.3000E-02 @@ -121,7 +121,7 @@ SBL: Tests SGEBAL 0.0000E-03 0.0000E-03 20.0000E+03 0.0000E-03 1.0000E+00 1.0000E+00 1.0000E+00 500.0000E-03 - + 5 0.1000E+01 0.5120E+03 0.4096E+04 3.2768E+04 2.62144E+05 0.8000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 @@ -209,5 +209,5 @@ SBL: Tests SGEBAL 5.0706024E+30 3.6028797E+16 1.2800000E+02 2.2737368E-13 2.0194839E-28 - + 0 diff --git a/lapack-netlib/TESTING/se2.in b/lapack-netlib/TESTING/se2.in new file mode 100644 index 0000000000..e20649c9df --- /dev/null +++ b/lapack-netlib/TESTING/se2.in @@ -0,0 +1,15 @@ +SE2: Data file for testing Symmetric Eigenvalue Problem routines +6 Number of values of N +0 1 2 3 5 20 Values of N (dimension) +5 Number of values of NB +1 3 3 3 10 Values of NB (blocksize) +2 2 2 2 2 Values of NBMIN (minimum blocksize) +1 0 5 9 1 Values of NX (crossover point) +50.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed +SE2 20 +1 2 3 4 5 6 7 8 10 11 12 13 14 15 16 17 18 19 20 21 + diff --git a/lapack-netlib/TESTING/sep.in b/lapack-netlib/TESTING/sep.in index 2116c7f2ba..7f9f54f525 100644 --- a/lapack-netlib/TESTING/sep.in +++ b/lapack-netlib/TESTING/sep.in @@ -1,11 +1,11 @@ SEP: Data file for testing Symmetric Eigenvalue Problem routines -8 Number of values of N -0 1 2 3 5 16 19 20 Values of N (dimension) +6 Number of values of N +0 1 2 3 5 20 Values of N (dimension) 5 Number of values of NB 1 3 3 3 10 Values of NB (blocksize) 2 2 2 2 2 Values of NBMIN (minimum blocksize) 1 0 5 9 1 Values of NX (crossover point) -600.0 Threshold value +50.0 Threshold value T Put T to test the LAPACK routines T Put T to test the driver routines T Put T to test the error exits diff --git a/lapack-netlib/TESTING/sgbak.in b/lapack-netlib/TESTING/sgbak.in index 6e6622a8ec..cea16b4068 100644 --- a/lapack-netlib/TESTING/sgbak.in +++ b/lapack-netlib/TESTING/sgbak.in @@ -263,4 +263,4 @@ SGK: Tests SGGBAK 0.5000E+02 0.5000E+02 0.6000E+02 0.6000E+02 -0 0 +0 0 diff --git a/lapack-netlib/TESTING/sgd.in b/lapack-netlib/TESTING/sgd.in index 79a70bc07c..164b3cc35c 100644 --- a/lapack-netlib/TESTING/sgd.in +++ b/lapack-netlib/TESTING/sgd.in @@ -1,6 +1,6 @@ SGS Data for the Real Nonsymmetric Schur Form Driver 5 Number of matrix dimensions -2 6 10 12 20 30 Matrix dimensions +2 6 10 12 20 30 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -8,25 +8,25 @@ SGS Data for the Real Nonsymmetric Schur Form Driver SGS 26 Test all 26 matrix types SGV Data for the Real Nonsymmetric Eigenvalue Problem Driver 6 Number of matrix dimensions -2 6 8 10 15 20 Matrix dimensions +2 6 8 10 15 20 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold value .TRUE. Put T to test the error exits 0 Code to interpret the seed SGV 26 Test all 26 matrix types -SGX Data for the Real Nonsymmetric Schur Form Expert Driver +SGX Data for the Real Nonsymmetric Schur Form Expert Driver 2 Largest matrix dimension (0 <= NSIZE <= 5) 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed -SGX Data for the Real Nonsymmetric Schur Form Expert Driver +SGX Data for the Real Nonsymmetric Schur Form Expert Driver 0 Largest matrix dimension (0 <= NSIZE <= 5) 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed - 4 + 4 2 8.0000E+00 4.0000E+00 -1.3000E+01 4.0000E+00 Input matrix A 0.0000E+00 7.0000E+00 -2.4000E+01 -3.0000E+00 @@ -37,7 +37,7 @@ SGX Data for the Real Nonsymmetric Schur Form Expert Driver 0.0000E+00 0.0000E+00 -1.1000E+01 6.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00 2.5901E-01 1.7592E+00 Condition #'s for cluster selected from lower 2x2 - 4 + 4 2 1.0000E+00 2.0000E+00 3.0000E+00 4.0000E+00 Input matrix A 0.0000E+00 5.0000E+00 6.0000E+00 7.0000E+00 @@ -49,13 +49,13 @@ SGX Data for the Real Nonsymmetric Schur Form Expert Driver 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 9.8173E-01 6.3649E-01 Condition #'s for cluster selected from lower 2x2 0 -SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver +SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver 5 Largest matrix dimension 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed -SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver +SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver 0 Largest matrix dimension 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in index bd7f884ba7..30f1c4704d 100644 --- a/lapack-netlib/TESTING/stest.in +++ b/lapack-netlib/TESTING/stest.in @@ -24,6 +24,8 @@ SPB 8 List types on next line if 0 < NTYPES < 8 SPT 12 List types on next line if 0 < NTYPES < 12 SSY 10 List types on next line if 0 < NTYPES < 10 SSR 10 List types on next line if 0 < NTYPES < 10 +SSK 10 List types on next line if 0 < NTYPES < 10 +SSA 10 List types on next line if 0 < NTYPES < 10 SSP 10 List types on next line if 0 < NTYPES < 10 STR 18 List types on next line if 0 < NTYPES < 18 STP 18 List types on next line if 0 < NTYPES < 18 @@ -38,3 +40,6 @@ SLS 6 List types on next line if 0 < NTYPES < 6 SEQ SQT SQX +SXQ +STQ +STS diff --git a/lapack-netlib/TESTING/svd.in b/lapack-netlib/TESTING/svd.in index 225b826587..bc0ae2d2ec 100644 --- a/lapack-netlib/TESTING/svd.in +++ b/lapack-netlib/TESTING/svd.in @@ -7,7 +7,7 @@ SVD: Data file for testing Singular Value Decomposition routines 2 2 2 2 2 Values of NBMIN (minimum blocksize) 1 0 5 9 1 Values of NX (crossover point) 2 0 2 2 2 Values of NRHS -100.0 Threshold value +50.0 Threshold value T Put T to test the LAPACK routines T Put T to test the driver routines T Put T to test the error exits diff --git a/lapack-netlib/TESTING/zbak.in b/lapack-netlib/TESTING/zbak.in index 624df47d00..6a98a89890 100644 --- a/lapack-netlib/TESTING/zbak.in +++ b/lapack-netlib/TESTING/zbak.in @@ -3,76 +3,76 @@ ZBK: Tests ZGEBAK 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) 5 1 1 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01 (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) -(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00) +(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25000D+00,0.00000D+00) (-.66667D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.22222D+00,0.00000D+00) -(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00) +(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.22222D+00,0.00000D+00) -(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00) +(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25000D+00,0.00000D+00) (-.66667D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) -(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00) +(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00) 5 1 1 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01 (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) -(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) +(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.36000D-34,0.00000D+00) -(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00) +(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.36000D-34,0.00000D+00) -(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00) +(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00) (0.00000D+00,0.00000D+00) (-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) -(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) +(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) 6 4 6 0.4000D+01 0.3000D+01 0.5000D+01 0.1000D+03 0.1000D+00 0.1000D+01 @@ -107,26 +107,26 @@ ZBK: Tests ZGEBAK 0.1000D+03 0.1000D+00 0.1000D-01 0.1000D+01 0.1000D+02 (0.13663D-03,0.00000D+00) (-.68290D-04,0.00000D+00) (0.12516D-03,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.19503D-14,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.19503D-14,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (-.27756D-16,0.00000D+00) -(0.36012D-05,0.00000D+00) (-.60728D-17,0.00000D+00) +(0.36012D-05,0.00000D+00) (-.60728D-17,0.00000D+00) (0.27355D+00,0.00000D+00) (-.13627D+00,0.00000D+00) (0.25030D+00,0.00000D+00) -(-.33221D-05,0.00000D+00) (-.20000D-02,0.00000D+00) +(-.33221D-05,0.00000D+00) (-.20000D-02,0.00000D+00) (0.69088D-02,0.00000D+00) (-.34434D-02,0.00000D+00) (0.61959D-02,0.00000D+00) -(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.38988D+00,0.00000D+00) (-.20327D+00,0.00000D+00) (-.34200D+00,0.00000D+00) -(-.10000D-02,0.00000D+00) (0.60004D-14,0.00000D+00) +(-.10000D-02,0.00000D+00) (0.60004D-14,0.00000D+00) (0.13663D-01,0.00000D+00) (-.68290D-02,0.00000D+00) (0.12516D-01,0.00000D+00) -(0.10000D+03,0.00000D+00) (0.19503D-12,0.00000D+00) +(0.10000D+03,0.00000D+00) (0.19503D-12,0.00000D+00) (0.10000D+00,0.00000D+00) (0.10000D+00,0.00000D+00) (-.27756D-17,0.00000D+00) -(0.36012D-06,0.00000D+00) (-.60728D-18,0.00000D+00) +(0.36012D-06,0.00000D+00) (-.60728D-18,0.00000D+00) (0.27355D-02,0.00000D+00) (-.13627D-02,0.00000D+00) (0.25030D-02,0.00000D+00) -(-.33221D-07,0.00000D+00) (-.20000D-04,0.00000D+00) +(-.33221D-07,0.00000D+00) (-.20000D-04,0.00000D+00) (0.69088D-02,0.00000D+00) (-.34434D-02,0.00000D+00) (0.61959D-02,0.00000D+00) -(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.38988D+01,0.00000D+00) (-.20327D+01,0.00000D+00) (-.34200D+01,0.00000D+00) -(-.10000D-01,0.00000D+00) (0.60004D-13,0.00000D+00) +(-.10000D-01,0.00000D+00) (0.60004D-13,0.00000D+00) 6 2 5 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01 @@ -163,19 +163,19 @@ ZBK: Tests ZGEBAK (0.10000D+01,0.00000D+00) (-.11048D-01,0.00000D+00) (0.37942D-01,0.00000D+00) (-.93781D-01,0.00000D+00) (-.34815D-01,0.00000D+00) (0.44651D+00,0.00000D+00) -(-.36016D-01,0.00000D+00) +(-.36016D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.45564D+00,0.00000D+00) (-.45447D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.46394D+00,0.00000D+00) (-.65116D+00,0.00000D+00) -(0.47808D+00,0.00000D+00) +(0.47808D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.27336D+00,0.00000D+00) (-.79459D+00,0.00000D+00) (0.63028D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.62791D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.69389D-17,0.00000D+00) (0.42585D-01,0.00000D+00) (-.64954D+00,0.00000D+00) (-.55814D+00,0.00000D+00) -(-.64516D+00,0.00000D+00) +(-.64516D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.39041D+00,0.00000D+00) (-.40294D+00,0.00000D+00) (-.16849D+00,0.00000D+00) (-.94294D+00,0.00000D+00) (0.10000D+01,0.00000D+00) -(-.93714D+00,0.00000D+00) +(-.93714D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25581D+00,0.00000D+00) (0.33085D-03,0.00000D+00) @@ -185,24 +185,24 @@ ZBK: Tests ZGEBAK (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25581D+00,0.00000D+00) -(0.33085D-03,0.00000D+00) +(0.33085D-03,0.00000D+00) (0.00000D+00,0.00000D+00) (-.45564D-03,0.00000D+00) (-.45447D-03,0.00000D+00) (0.10000D-02,0.00000D+00) (0.46394D-03,0.00000D+00) (-.65116D-03,0.00000D+00) -(0.47808D-03,0.00000D+00) +(0.47808D-03,0.00000D+00) (0.10000D+01,0.00000D+00) (-.11048D-01,0.00000D+00) (0.37942D-01,0.00000D+00) (-.93781D-01,0.00000D+00) (-.34815D-01,0.00000D+00) (0.44651D+00,0.00000D+00) -(-.36016D-01,0.00000D+00) +(-.36016D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+02,0.00000D+00) (-.69389D-16,0.00000D+00) (0.42585D+00,0.00000D+00) (-.64954D+01,0.00000D+00) (-.55814D+01,0.00000D+00) -(-.64516D+01,0.00000D+00) +(-.64516D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.39041D-01,0.00000D+00) (-.40294D-01,0.00000D+00) (-.16849D-01,0.00000D+00) (-.94294D-01,0.00000D+00) (0.10000D+00,0.00000D+00) -(-.93714D-01,0.00000D+00) +(-.93714D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(-.19851D-02,0.00000D+00) +(-.19851D-02,0.00000D+00) (0.00000D+00,0.00000D+00) (-.27336D-02,0.00000D+00) (-.79459D-02,0.00000D+00) (0.63028D-02,0.00000D+00) (0.10000D-01,0.00000D+00) (-.62791D-02,0.00000D+00) -(0.10000D-01,0.00000D+00) +(0.10000D-01,0.00000D+00) -0 0 0 +0 0 0 diff --git a/lapack-netlib/TESTING/zbal.in b/lapack-netlib/TESTING/zbal.in index c742723ff5..1efb5f2fc7 100644 --- a/lapack-netlib/TESTING/zbal.in +++ b/lapack-netlib/TESTING/zbal.in @@ -1,91 +1,91 @@ ZBL: Tests ZGEBAL 5 (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) +(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01) +(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01) 1 1 (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) +(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01) +(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01) 0.10000D+01 0.20000D+01 0.30000D+01 0.40000D+01 0.50000D+01 5 (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01) -(0.40000D+01,0.40000D+01) (0.00000D+00,0.00000D+00) +(0.40000D+01,0.40000D+01) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01) -(0.40000D+01,0.40000D+01) (0.50000D+01,0.50000D+01) +(0.40000D+01,0.40000D+01) (0.50000D+01,0.50000D+01) 1 1 (0.50000D+01,0.50000D+01) (0.40000D+01,0.40000D+01) (0.30000D+01,0.30000D+01) -(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) +(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.40000D+01,0.40000D+01) (0.30000D+01,0.30000D+01) -(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) +(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01) -(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) +(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) +(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) +(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) 0.10000D+01 0.20000D+01 0.30000D+01 0.20000D+01 0.10000D+01 5 (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) +(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01) +(0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01) 1 1 (0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) -(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00) +(0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) +(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) 0.10000D+01 0.20000D+01 0.30000D+01 0.20000D+01 0.10000D+01 4 (0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00) (0.10000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.10000D+00,0.00000D+00) +(0.10000D+00,0.00000D+00) (0.10000D+03,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.20000D+01,0.00000D+00) +(0.20000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+03,0.00000D+00) (0.20000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) 1 4 (0.0000D+00,0.00000D+00) (0.2000D+01,0.00000D+00) (0.3200D+01,0.00000D+00) @@ -131,25 +131,25 @@ ZBL: Tests ZGEBAL 5 (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.81920D+04,0.00000D+00) -(0.20000D+01,0.00000D+00) (0.40000D+01,0.00000D+00) +(0.20000D+01,0.00000D+00) (0.40000D+01,0.00000D+00) (0.25000D-03,0.00000D+00) (0.12500D-03,0.00000D+00) (0.40000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.64000D+02,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.64000D+02,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00) (0.10240D+04,0.10240D+01) -(0.40000D+01,0.00000D+00) (0.80000D+01,0.00000D+00) +(0.40000D+01,0.00000D+00) (0.80000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.81920D+04) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) 1 5 - ( 1.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) -( 0.0000D-003,0.00000D+00) (250.0000D-003,0.00000D+00) + ( 1.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) +( 0.0000D-003,0.00000D+00) (250.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 2.0000D+000, 1.0000D+000) ( 1.0240D+003,0.00000D+00) - ( 16.0000D+000,0.00000D+00) ( 16.0000D+000,0.00000D+00) + ( 16.0000D+000,0.00000D+00) ( 16.0000D+000,0.00000D+00) (256.0000D-003,0.00000D+00) ( 1.0000D-003,0.00000D+00) ( 4.0000D+000,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 2.0480D+003,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 2.0480D+003,0.00000D+00) ( 0.0000D-003,0.00000D+00) (250.0000D-003,0.00000D+00) ( 16.0000D+000,16.0000D-003) - ( 4.0000D+000,0.00000D+00) ( 4.0000D+000,0.00000D+00) + ( 4.0000D+000,0.00000D+00) ( 4.0000D+000,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003, 2.0480D+003) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 8.0000D+000,0.00000D+00) @@ -157,62 +157,62 @@ ZBL: Tests ZGEBAL 4 (0.10000D+01,0.10000D+01) (0.10000D+07,0.00000D+00) (0.10000D+07,0.00000D+00) -(0.10000D+07,0.00000D+00) +(0.10000D+07,0.00000D+00) (-.20000D+07,0.00000D+00) (0.30000D+01,0.10000D+01) (0.20000D-05,0.00000D+00) -(0.30000D-05,0.00000D+00) +(0.30000D-05,0.00000D+00) (-.30000D+07,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D-05,0.10000D+01) (0.20000D+01,0.00000D+00) (0.10000D+07,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D-05,0.00000D+00) -(0.40000D+07,0.10000D+01) +(0.40000D+07,0.10000D+01) 1 4 - ( 1.0000D+000, 1.0000D+000) ( 1.0000D+006,0.00000D+00) ( 2.0000D+006,0.00000D+00) ( 1.0000D+006,0.00000D+00) (250.0000D-003,0.00000D+00) - ( -2.0000D+006,0.00000D+00) ( 3.0000D+000, 1.0000D+000) ( 4.0000D-006,0.00000D+00) ( 3.0000D-006,0.00000D+00) ( 16.0000D+000,0.00000D+00) - ( -1.5000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 1.0000D-006, 1.0000D+000) ( 1.0000D+000,0.00000D+00) ( 2.0480D+003,0.00000D+00) - ( 1.0000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 6.0000D-006,0.00000D+00) ( 4.0000D+006, 1.0000D+000) ( 4.0000D+000,0.00000D+00) + ( 1.0000D+000, 1.0000D+000) ( 1.0000D+006,0.00000D+00) ( 2.0000D+006,0.00000D+00) ( 1.0000D+006,0.00000D+00) (250.0000D-003,0.00000D+00) + ( -2.0000D+006,0.00000D+00) ( 3.0000D+000, 1.0000D+000) ( 4.0000D-006,0.00000D+00) ( 3.0000D-006,0.00000D+00) ( 16.0000D+000,0.00000D+00) + ( -1.5000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 1.0000D-006, 1.0000D+000) ( 1.0000D+000,0.00000D+00) ( 2.0480D+003,0.00000D+00) + ( 1.0000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 6.0000D-006,0.00000D+00) ( 4.0000D+006, 1.0000D+000) ( 4.0000D+000,0.00000D+00) 1.0000D+000 1.0000D+000 2.0000D+000 1.0000D+000 4 (0.10000D+01,0.00000D+00) (0.00000D+00,0.10000D+05) (0.00000D+00,0.10000D+05) -(0.00000D+00,0.10000D+05) +(0.00000D+00,0.10000D+05) (-.20000D+05,0.00000D+00) (0.30000D+01,0.00000D+00) (0.20000D-02,0.00000D+00) -(0.30000D-02,0.00000D+00) +(0.30000D-02,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) -(-.30000D+05,0.00000D+00) +(-.30000D+05,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+05,0.00000D+00) -(0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) 1 4 - ( 1.0000D+000,0.00000D+00) ( 0.0000D-003,10.0000D+003) (0.0000D-003,10.0000D+003) (0.0000D-003,5.0000D+003) (250.0000D-003,0.00000D+00) - (-20.0000D+003,0.00000D+00) ( 3.0000D+000,0.00000D+00) ( 2.0000D-003,0.00000D+00) ( 1.5000D-003,0.00000D+00) ( 16.0000D+000,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 2.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) (-15.0000D+003,0.00000D+00) ( 2.0480D+003,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 20.0000D+003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 4.0000D+000,0.00000D+00) + ( 1.0000D+000,0.00000D+00) ( 0.0000D-003,10.0000D+003) (0.0000D-003,10.0000D+003) (0.0000D-003,5.0000D+003) (250.0000D-003,0.00000D+00) + (-20.0000D+003,0.00000D+00) ( 3.0000D+000,0.00000D+00) ( 2.0000D-003,0.00000D+00) ( 1.5000D-003,0.00000D+00) ( 16.0000D+000,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 2.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) (-15.0000D+003,0.00000D+00) ( 2.0480D+003,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 20.0000D+003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 4.0000D+000,0.00000D+00) 1.0000D+000 1.0000D+000 1.0000D+000 500.0000D-003 5 (0.10000D+01,0.00000D+00) (0.51200D+03,0.00000D+00) (0.40960D+04,0.00000D+00) -(0.32768D+05,0.00000D+00) (2.62144D+05,0.00000D+00) +(0.32768D+05,0.00000D+00) (2.62144D+05,0.00000D+00) (0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.80000D+01,0.80000D+01) -(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00) +(0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00) 1 5 - ( 1.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) -( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) - ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) -( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) -( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) -( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) - ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) + ( 1.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) +( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) + ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) +( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) +( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) +( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) + ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) 128.0000D+000 16.0000D+000 2.0000D+000 250.0000D-003 31.2500D-003 @@ -250,25 +250,25 @@ ZBL: Tests ZGEBAL 7 (0.60000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.40000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.25000D-03,0.00000D+00) (0.12500D-01,0.00000D+00) (0.20000D-01,0.00000D+00) -(0.12500D+00,0.00000D+00) +(0.12500D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.12800D+03,0.00000D+00) (0.64000D+02,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.20000D+01,0.00000D+00) -(0.16000D+02,0.00000D+00) +(0.16000D+02,0.00000D+00) (0.00000D+00,0.00000D+00) (0.16384D+05,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.40000D+03,0.00000D+00) (0.25600D+03,0.00000D+00) -(-.40000D+04,0.00000D+00) +(-.40000D+04,0.00000D+00) (-.20000D+01,0.00000D+00) (-.25600D+03,0.00000D+00) (0.00000D+00,0.00000D+00) (0.12500D-01,0.00000D+00) (0.20000D+01,0.00000D+00) (0.20000D+01,0.00000D+00) -(0.32000D+02,0.00000D+00) +(0.32000D+02,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) -(0.00000D+00,0.00000D+00) +(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.40000D-02,0.00000D+00) (0.12500D+00,0.00000D+00) (-.20000D+00,0.00000D+00) -(0.30000D+01,0.00000D+00) +(0.30000D+01,0.00000D+00) 2 5 (6.4000D+01,0.00000D+00) (2.5000D-01,0.00000D+00) (5.00000D-01,0.00000D+00) @@ -297,26 +297,26 @@ ZBL: Tests ZGEBAL 5 (0.10000D+04,0.00000D+00) (0.20000D+01,0.00000D+00) (0.30000D+01,0.00000D+00) -(0.40000D+01,0.00000D+00) (0.50000D+06,0.00000D+00) +(0.40000D+01,0.00000D+00) (0.50000D+06,0.00000D+00) (0.90000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D-03,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.30000D+01,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.30000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.30000D+03,0.00000D+00) (0.20000D+01,0.00000D+00) -(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) +(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.90000D+01,0.00000D+00) (0.20000D-02,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.10000D+01,0.00000D+00) (-.10000D+04,0.00000D+00) +(0.10000D+01,0.00000D+00) (-.10000D+04,0.00000D+00) (0.60000D+01,0.00000D+00) (0.20000D+03,0.00000D+00) (0.10000D+01,0.00000D+00) -(0.60000D+03,0.00000D+00) (0.30000D+01,0.00000D+00) +(0.60000D+03,0.00000D+00) (0.30000D+01,0.00000D+00) 1 5 - (1.0000D+03,0.00000D+00) (3.1250D-02,0.00000D+00) (3.7500D-01,0.00000D+00) + (1.0000D+03,0.00000D+00) (3.1250D-02,0.00000D+00) (3.7500D-01,0.00000D+00) (6.2500D-02,0.00000D+00) (3.90625D+03,0.00000D+00) - (5.7600D+02,0.00000D+00) (0.0000D+00,0.00000D+00) (1.6000D-03,0.00000D+00) + (5.7600D+02,0.00000D+00) (0.0000D+00,0.00000D+00) (1.6000D-03,0.00000D+00) (1.0000D+00,0.00000D+00) (1.5000D+00,0.00000D+00) - (0.0000D+00,0.00000D+00) (-3.7500D+01,0.00000D+00) (2.0000D+00,0.00000D+00) + (0.0000D+00,0.00000D+00) (-3.7500D+01,0.00000D+00) (2.0000D+00,0.00000D+00) (1.2500D-01,0.00000D+00) (6.2500D-02,0.00000D+00) - (5.7600D+02,0.00000D+00) (2.0000D-03,0.00000D+00) (8.0000D+00,0.00000D+00) + (5.7600D+02,0.00000D+00) (2.0000D-03,0.00000D+00) (8.0000D+00,0.00000D+00) (1.0000D+00,0.00000D+00) (-5.0000D+02,0.00000D+00) - (7.6800D+02,0.00000D+00) (4.0000D+02,0.00000D+00) (1.6000D+01,0.00000D+00) + (7.6800D+02,0.00000D+00) (4.0000D+02,0.00000D+00) (1.6000D+01,0.00000D+00) (1.2000D+03,0.00000D+00) (3.0000D+00,0.00000D+00) 1.2800D+02 2.0000D+00 1.6000D+01 2.0000D+00 1.0000D+00 diff --git a/lapack-netlib/TESTING/zed.in b/lapack-netlib/TESTING/zed.in index 880ae19738..538d8b0a22 100644 --- a/lapack-netlib/TESTING/zed.in +++ b/lapack-netlib/TESTING/zed.in @@ -35,489 +35,489 @@ ZSX 21 Use all matrix types 1.0000D+00 1.0000D+00 5 3 0 2 3 4 -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) 1.0000D+00 2.9582D-31 5 3 0 1 3 5 -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) 1.0000D+00 1.0000D+00 5 2 0 2 4 -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 4.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 4.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 5.0000D+00, 0.0000D+00) 1.0000D+00 1.0000D+00 6 3 1 3 4 6 -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 1.0000D+00) 1.0000D+00 2.0000D+00 6 3 0 1 3 5 -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) ( 0.0000D+00, 1.0000D+00) 1.0000D+00 2.0000D+00 4 2 0 3 4 -( 9.4480D-01, 1.0000D+00) -( 6.7670D-01, 1.0000D+00) -( 6.9080D-01, 1.0000D+00) +( 9.4480D-01, 1.0000D+00) +( 6.7670D-01, 1.0000D+00) +( 6.9080D-01, 1.0000D+00) ( 5.9650D-01, 1.0000D+00) -( 5.8760D-01, 1.0000D+00) -( 8.6420D-01, 1.0000D+00) -( 6.7690D-01, 1.0000D+00) +( 5.8760D-01, 1.0000D+00) +( 8.6420D-01, 1.0000D+00) +( 6.7690D-01, 1.0000D+00) ( 7.2600D-02, 1.0000D+00) -( 7.2560D-01, 1.0000D+00) -( 1.9430D-01, 1.0000D+00) -( 9.6870D-01, 1.0000D+00) +( 7.2560D-01, 1.0000D+00) +( 1.9430D-01, 1.0000D+00) +( 9.6870D-01, 1.0000D+00) ( 2.8310D-01, 1.0000D+00) -( 2.8490D-01, 1.0000D+00) -( 5.8000D-02, 1.0000D+00) -( 4.8450D-01, 1.0000D+00) +( 2.8490D-01, 1.0000D+00) +( 5.8000D-02, 1.0000D+00) +( 4.8450D-01, 1.0000D+00) ( 7.3610D-01, 1.0000D+00) 9.6350D-01 3.3122D-01 4 2 0 2 3 -( 2.1130D-01, 9.9330D-01) -( 8.0960D-01, 4.2370D-01) -( 4.8320D-01, 1.1670D-01) +( 2.1130D-01, 9.9330D-01) +( 8.0960D-01, 4.2370D-01) +( 4.8320D-01, 1.1670D-01) ( 6.5380D-01, 4.9430D-01) -( 8.2400D-02, 8.3600D-01) -( 8.4740D-01, 2.6130D-01) -( 6.1350D-01, 6.2500D-01) +( 8.2400D-02, 8.3600D-01) +( 8.4740D-01, 2.6130D-01) +( 6.1350D-01, 6.2500D-01) ( 4.8990D-01, 3.6500D-02) -( 7.5990D-01, 7.4690D-01) -( 4.5240D-01, 2.4030D-01) -( 2.7490D-01, 5.5100D-01) +( 7.5990D-01, 7.4690D-01) +( 4.5240D-01, 2.4030D-01) +( 2.7490D-01, 5.5100D-01) ( 7.7410D-01, 2.2600D-01) -( 8.7000D-03, 3.7800D-02) -( 8.0750D-01, 3.4050D-01) -( 8.8070D-01, 3.5500D-01) +( 8.7000D-03, 3.7800D-02) +( 8.0750D-01, 3.4050D-01) +( 8.8070D-01, 3.5500D-01) ( 9.6260D-01, 8.1590D-01) 8.4053D-01 7.4754D-01 3 2 0 2 3 -( 1.0000D+00, 2.0000D+00) -( 3.0000D+00, 4.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 3.0000D+00, 4.0000D+00) ( 2.1000D+01, 2.2000D+01) -( 4.3000D+01, 4.4000D+01) -( 1.3000D+01, 1.4000D+01) +( 4.3000D+01, 4.4000D+01) +( 1.3000D+01, 1.4000D+01) ( 1.5000D+01, 1.6000D+01) -( 5.0000D+00, 6.0000D+00) -( 7.0000D+00, 8.0000D+00) +( 5.0000D+00, 6.0000D+00) +( 7.0000D+00, 8.0000D+00) ( 2.5000D+01, 2.6000D+01) 3.9550D-01 2.0464D+01 4 2 0 1 3 -( 5.0000D+00, 9.0000D+00) -( 5.0000D+00, 5.0000D+00) -(-6.0000D+00,-6.0000D+00) +( 5.0000D+00, 9.0000D+00) +( 5.0000D+00, 5.0000D+00) +(-6.0000D+00,-6.0000D+00) (-7.0000D+00,-7.0000D+00) -( 3.0000D+00, 3.0000D+00) -( 6.0000D+00, 1.0000D+01) -(-5.0000D+00,-5.0000D+00) +( 3.0000D+00, 3.0000D+00) +( 6.0000D+00, 1.0000D+01) +(-5.0000D+00,-5.0000D+00) (-6.0000D+00,-6.0000D+00) -( 2.0000D+00, 2.0000D+00) -( 3.0000D+00, 3.0000D+00) -(-1.0000D+00, 3.0000D+00) +( 2.0000D+00, 2.0000D+00) +( 3.0000D+00, 3.0000D+00) +(-1.0000D+00, 3.0000D+00) (-5.0000D+00,-5.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 2.0000D+00, 2.0000D+00) -(-3.0000D+00,-3.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 2.0000D+00, 2.0000D+00) +(-3.0000D+00,-3.0000D+00) ( 0.0000D+00, 4.0000D+00) 3.3333D-01 1.2569D-01 4 3 0 1 3 4 -( 3.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 2.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 0.0000D+00,-2.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00,-2.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 2.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00,-2.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 2.0000D+00) -( 1.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) -( 0.0000D+00,-2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) 1.0000D+00 8.2843D-01 4 2 0 2 3 -( 7.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 1.0000D+00, 2.0000D+00) +( 7.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 1.0000D+00, 2.0000D+00) (-1.0000D+00, 2.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 7.0000D+00, 0.0000D+00) -( 1.0000D+00,-2.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 7.0000D+00, 0.0000D+00) +( 1.0000D+00,-2.0000D+00) +(-1.0000D+00,-2.0000D+00) +( 1.0000D+00,-2.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 7.0000D+00, 0.0000D+00) +(-3.0000D+00, 0.0000D+00) (-1.0000D+00,-2.0000D+00) -( 1.0000D+00,-2.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 7.0000D+00, 0.0000D+00) +(-2.0000D+00, 2.0000D+00) (-3.0000D+00, 0.0000D+00) -(-1.0000D+00,-2.0000D+00) -(-2.0000D+00, 2.0000D+00) -(-3.0000D+00, 0.0000D+00) ( 7.0000D+00, 0.0000D+00) 9.8985D-01 4.1447D+00 5 2 1 2 3 -( 1.0000D+00, 2.0000D+00) -( 3.0000D+00, 4.0000D+00) -( 2.1000D+01, 2.2000D+01) -( 2.3000D+01, 2.4000D+01) +( 1.0000D+00, 2.0000D+00) +( 3.0000D+00, 4.0000D+00) +( 2.1000D+01, 2.2000D+01) +( 2.3000D+01, 2.4000D+01) ( 4.1000D+01, 4.2000D+01) -( 4.3000D+01, 4.4000D+01) -( 1.3000D+01, 1.4000D+01) -( 1.5000D+01, 1.6000D+01) -( 3.3000D+01, 3.4000D+01) +( 4.3000D+01, 4.4000D+01) +( 1.3000D+01, 1.4000D+01) +( 1.5000D+01, 1.6000D+01) +( 3.3000D+01, 3.4000D+01) ( 3.5000D+01, 3.6000D+01) -( 5.0000D+00, 6.0000D+00) -( 7.0000D+00, 8.0000D+00) -( 2.5000D+01, 2.6000D+01) -( 2.7000D+01, 2.8000D+01) +( 5.0000D+00, 6.0000D+00) +( 7.0000D+00, 8.0000D+00) +( 2.5000D+01, 2.6000D+01) +( 2.7000D+01, 2.8000D+01) ( 4.5000D+01, 4.6000D+01) -( 4.7000D+01, 4.8000D+01) -( 1.7000D+01, 1.8000D+01) -( 1.9000D+01, 2.0000D+01) -( 3.7000D+01, 3.8000D+01) +( 4.7000D+01, 4.8000D+01) +( 1.7000D+01, 1.8000D+01) +( 1.9000D+01, 2.0000D+01) +( 3.7000D+01, 3.8000D+01) ( 3.9000D+01, 4.0000D+01) -( 9.0000D+00, 1.0000D+01) -( 1.1000D+01, 1.2000D+01) -( 2.9000D+01, 3.0000D+01) -( 3.1000D+01, 3.2000D+01) +( 9.0000D+00, 1.0000D+01) +( 1.1000D+01, 1.2000D+01) +( 2.9000D+01, 3.0000D+01) +( 3.1000D+01, 3.2000D+01) ( 4.9000D+01, 5.0000D+01) 3.1088D-01 4.6912D+00 3 2 0 1 2 -( 1.0000D+00, 1.0000D+00) -(-1.0000D+00,-1.0000D+00) +( 1.0000D+00, 1.0000D+00) +(-1.0000D+00,-1.0000D+00) ( 2.0000D+00, 2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -(-1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +(-1.0000D+00, 0.0000D+00) ( 3.0000D+00, 1.0000D+00) 2.2361D-01 1.0000D+00 4 2 1 1 3 -(-4.0000D+00,-2.0000D+00) -(-5.0000D+00,-6.0000D+00) -(-2.0000D+00,-6.0000D+00) +(-4.0000D+00,-2.0000D+00) +(-5.0000D+00,-6.0000D+00) +(-2.0000D+00,-6.0000D+00) ( 0.0000D+00,-2.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) 7.2803D-05 1.1947D-04 7 4 0 1 4 6 7 -( 2.0000D+00, 4.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 6.0000D+00, 2.0000D+00) -( 3.0000D+00, 3.0000D+00) -( 5.0000D+00, 5.0000D+00) -( 2.0000D+00, 6.0000D+00) +( 2.0000D+00, 4.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 6.0000D+00, 2.0000D+00) +( 3.0000D+00, 3.0000D+00) +( 5.0000D+00, 5.0000D+00) +( 2.0000D+00, 6.0000D+00) ( 1.0000D+00, 1.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 1.0000D+00, 3.0000D+00) -( 3.0000D+00, 1.0000D+00) -( 5.0000D+00,-4.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 7.0000D+00, 2.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 1.0000D+00, 3.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 5.0000D+00,-4.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 7.0000D+00, 2.0000D+00) ( 2.0000D+00, 3.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 3.0000D+00,-2.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 6.0000D+00, 3.0000D+00) -( 2.0000D+00, 1.0000D+00) -( 1.0000D+00, 4.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 3.0000D+00,-2.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 6.0000D+00, 3.0000D+00) ( 2.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00, 3.0000D+00) -( 3.0000D+00, 1.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 2.0000D+00, 2.0000D+00) +( 1.0000D+00, 4.0000D+00) +( 2.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00, 3.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 2.0000D+00, 2.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00,-1.0000D+00) +( 2.0000D+00, 2.0000D+00) ( 3.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00,-1.0000D+00) -( 2.0000D+00, 2.0000D+00) -( 3.0000D+00, 1.0000D+00) ( 1.0000D+00, 3.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00,-1.0000D+00) -( 2.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00,-1.0000D+00) +( 2.0000D+00, 1.0000D+00) ( 2.0000D+00, 2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00,-2.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00,-2.0000D+00) ( 1.0000D+00, 1.0000D+00) 3.7241D-01 5.2080D-01 5 3 1 1 3 5 -( 0.0000D+00, 5.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 2.0000D+00, 3.0000D+00) -(-3.0000D+00, 6.0000D+00) +( 0.0000D+00, 5.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 2.0000D+00, 3.0000D+00) +(-3.0000D+00, 6.0000D+00) ( 6.0000D+00, 0.0000D+00) -(-1.0000D+00, 2.0000D+00) -( 0.0000D+00, 6.0000D+00) -( 4.0000D+00, 5.0000D+00) -(-3.0000D+00,-2.0000D+00) +(-1.0000D+00, 2.0000D+00) +( 0.0000D+00, 6.0000D+00) +( 4.0000D+00, 5.0000D+00) +(-3.0000D+00,-2.0000D+00) ( 5.0000D+00, 0.0000D+00) -(-2.0000D+00, 3.0000D+00) -(-4.0000D+00, 5.0000D+00) -( 0.0000D+00, 7.0000D+00) -( 3.0000D+00, 0.0000D+00) +(-2.0000D+00, 3.0000D+00) +(-4.0000D+00, 5.0000D+00) +( 0.0000D+00, 7.0000D+00) +( 3.0000D+00, 0.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 3.0000D+00, 6.0000D+00) -( 3.0000D+00,-2.0000D+00) -(-3.0000D+00, 0.0000D+00) -( 0.0000D+00,-5.0000D+00) +( 3.0000D+00, 6.0000D+00) +( 3.0000D+00,-2.0000D+00) +(-3.0000D+00, 0.0000D+00) +( 0.0000D+00,-5.0000D+00) ( 2.0000D+00, 1.0000D+00) -(-6.0000D+00, 0.0000D+00) -(-5.0000D+00, 0.0000D+00) -(-2.0000D+00, 0.0000D+00) -(-2.0000D+00, 1.0000D+00) +(-6.0000D+00, 0.0000D+00) +(-5.0000D+00, 0.0000D+00) +(-2.0000D+00, 0.0000D+00) +(-2.0000D+00, 1.0000D+00) ( 0.0000D+00, 2.0000D+00) 1.0000D+00 4.5989D+00 8 4 1 1 2 3 4 -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 2.0000D+00) -( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 2.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 2.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00, 2.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 3.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 0.0000D+00, 3.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 3.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00, 3.0000D+00) ( 3.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 4.0000D+00) -( 4.0000D+00, 0.0000D+00) -( 0.0000D+00, 4.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 4.0000D+00) +( 4.0000D+00, 0.0000D+00) +( 0.0000D+00, 4.0000D+00) ( 4.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 9.5000D-01) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 9.5000D-01) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 9.5000D-01) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 9.5000D-01) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 9.5000D-01) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 9.5000D-01) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 9.5000D-01) 9.5269D-12 2.9360D-11 3 2 0 2 3 -( 2.0000D+00, 0.0000D+00) -( 0.0000D+00,-1.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00,-1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 2.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) ( 3.0000D+00, 0.0000D+00) 1.0000D+00 2.0000D+00 0 0 0 @@ -537,51 +537,51 @@ ZVX 21 Use all matrix types ( 0.0000D+00, 1.0000D+00) 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 2 0 -( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 2 0 -( 3.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 2.0000D+00, 0.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 2.0000D+00, 0.0000D+00) ( 3.0000D+00, 0.0000D+00) 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00 2 0 -( 3.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00, 2.0000D+00) ( 0.0000D+00, 2.0000D+00) -( 0.0000D+00, 2.0000D+00) ( 3.0000D+00, 0.0000D+00) 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00 5 0 -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 @@ -589,30 +589,30 @@ ZVX 21 Use all matrix types 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 5 0 -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 @@ -620,30 +620,30 @@ ZVX 21 Use all matrix types 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 5 0 -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 4.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 4.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 5.0000D+00, 0.0000D+00) 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 @@ -651,41 +651,41 @@ ZVX 21 Use all matrix types 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 6 0 -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 1.0000D+00) 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00 @@ -694,41 +694,41 @@ ZVX 21 Use all matrix types 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00 6 0 -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) ( 0.0000D+00, 1.0000D+00) 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00 @@ -737,148 +737,148 @@ ZVX 21 Use all matrix types 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00 4 0 -( 9.4480D-01, 1.0000D+00) -( 6.7670D-01, 1.0000D+00) -( 6.9080D-01, 1.0000D+00) +( 9.4480D-01, 1.0000D+00) +( 6.7670D-01, 1.0000D+00) +( 6.9080D-01, 1.0000D+00) ( 5.9650D-01, 1.0000D+00) -( 5.8760D-01, 1.0000D+00) -( 8.6420D-01, 1.0000D+00) -( 6.7690D-01, 1.0000D+00) +( 5.8760D-01, 1.0000D+00) +( 8.6420D-01, 1.0000D+00) +( 6.7690D-01, 1.0000D+00) ( 7.2600D-02, 1.0000D+00) -( 7.2560D-01, 1.0000D+00) -( 1.9430D-01, 1.0000D+00) -( 9.6870D-01, 1.0000D+00) +( 7.2560D-01, 1.0000D+00) +( 1.9430D-01, 1.0000D+00) +( 9.6870D-01, 1.0000D+00) ( 2.8310D-01, 1.0000D+00) -( 2.8490D-01, 1.0000D+00) -( 5.8000D-02, 1.0000D+00) -( 4.8450D-01, 1.0000D+00) +( 2.8490D-01, 1.0000D+00) +( 5.8000D-02, 1.0000D+00) +( 4.8450D-01, 1.0000D+00) ( 7.3610D-01, 1.0000D+00) 2.6014D-01 -1.7813D-01 8.5279D-01 3.2881D-01 2.8961D-01 2.0772D-01 8.4871D-01 3.2358D-01 7.3990D-01 -4.6522D-04 9.7398D-01 3.4994D-01 2.2242D+00 3.9709D+00 9.8325D-01 4.1429D+00 4 0 -( 2.1130D-01, 9.9330D-01) -( 8.0960D-01, 4.2370D-01) -( 4.8320D-01, 1.1670D-01) +( 2.1130D-01, 9.9330D-01) +( 8.0960D-01, 4.2370D-01) +( 4.8320D-01, 1.1670D-01) ( 6.5380D-01, 4.9430D-01) -( 8.2400D-02, 8.3600D-01) -( 8.4740D-01, 2.6130D-01) -( 6.1350D-01, 6.2500D-01) +( 8.2400D-02, 8.3600D-01) +( 8.4740D-01, 2.6130D-01) +( 6.1350D-01, 6.2500D-01) ( 4.8990D-01, 3.6500D-02) -( 7.5990D-01, 7.4690D-01) -( 4.5240D-01, 2.4030D-01) -( 2.7490D-01, 5.5100D-01) +( 7.5990D-01, 7.4690D-01) +( 4.5240D-01, 2.4030D-01) +( 2.7490D-01, 5.5100D-01) ( 7.7410D-01, 2.2600D-01) -( 8.7000D-03, 3.7800D-02) -( 8.0750D-01, 3.4050D-01) -( 8.8070D-01, 3.5500D-01) +( 8.7000D-03, 3.7800D-02) +( 8.0750D-01, 3.4050D-01) +( 8.8070D-01, 3.5500D-01) ( 9.6260D-01, 8.1590D-01) -6.2157D-01 6.0607D-01 8.7533D-01 8.1980D-01 2.8890D-01 -2.6354D-01 8.2538D-01 8.1086D-01 3.8017D-01 5.4217D-01 7.4771D-01 7.0323D-01 2.2487D+00 1.7368D+00 9.2372D-01 2.2178D+00 3 0 -( 1.0000D+00, 2.0000D+00) -( 3.0000D+00, 4.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 3.0000D+00, 4.0000D+00) ( 2.1000D+01, 2.2000D+01) -( 4.3000D+01, 4.4000D+01) -( 1.3000D+01, 1.4000D+01) +( 4.3000D+01, 4.4000D+01) +( 1.3000D+01, 1.4000D+01) ( 1.5000D+01, 1.6000D+01) -( 5.0000D+00, 6.0000D+00) -( 7.0000D+00, 8.0000D+00) +( 5.0000D+00, 6.0000D+00) +( 7.0000D+00, 8.0000D+00) ( 2.5000D+01, 2.6000D+01) -7.4775D+00 6.8803D+00 3.9550D-01 1.6583D+01 6.7009D+00 -7.8760D+00 3.9828D-01 1.6312D+01 3.9777D+01 4.2996D+01 7.9686D-01 3.7399D+01 4 0 -( 5.0000D+00, 9.0000D+00) -( 5.0000D+00, 5.0000D+00) -(-6.0000D+00,-6.0000D+00) +( 5.0000D+00, 9.0000D+00) +( 5.0000D+00, 5.0000D+00) +(-6.0000D+00,-6.0000D+00) (-7.0000D+00,-7.0000D+00) -( 3.0000D+00, 3.0000D+00) -( 6.0000D+00, 1.0000D+01) -(-5.0000D+00,-5.0000D+00) +( 3.0000D+00, 3.0000D+00) +( 6.0000D+00, 1.0000D+01) +(-5.0000D+00,-5.0000D+00) (-6.0000D+00,-6.0000D+00) -( 2.0000D+00, 2.0000D+00) -( 3.0000D+00, 3.0000D+00) -(-1.0000D+00, 3.0000D+00) +( 2.0000D+00, 2.0000D+00) +( 3.0000D+00, 3.0000D+00) +(-1.0000D+00, 3.0000D+00) (-5.0000D+00,-5.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 2.0000D+00, 2.0000D+00) -(-3.0000D+00,-3.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 2.0000D+00, 2.0000D+00) +(-3.0000D+00,-3.0000D+00) ( 0.0000D+00, 4.0000D+00) 1.0000D+00 5.0000D+00 2.1822D-01 7.4651D-01 2.0000D+00 6.0000D+00 2.1822D-01 3.0893D-01 3.0000D+00 7.0000D+00 2.1822D-01 1.8315D-01 4.0000D+00 8.0000D+00 2.1822D-01 6.6350D-01 4 0 -( 3.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 2.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 0.0000D+00,-2.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 0.0000D+00,-2.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 2.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00,-2.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 2.0000D+00) -( 1.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) -( 0.0000D+00,-2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) ( 1.0000D+00, 0.0000D+00) -8.2843D-01 1.6979D-07 1.0000D+00 8.2843D-01 4.1744D-07 7.1526D-08 1.0000D+00 8.2843D-01 4.0000D+00 1.6690D-07 1.0000D+00 8.2843D-01 4.8284D+00 6.8633D-08 1.0000D+00 8.2843D-01 4 0 -( 7.0000D+00, 0.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 1.0000D+00, 2.0000D+00) +( 7.0000D+00, 0.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 1.0000D+00, 2.0000D+00) (-1.0000D+00, 2.0000D+00) -( 3.0000D+00, 0.0000D+00) -( 7.0000D+00, 0.0000D+00) -( 1.0000D+00,-2.0000D+00) +( 3.0000D+00, 0.0000D+00) +( 7.0000D+00, 0.0000D+00) +( 1.0000D+00,-2.0000D+00) +(-1.0000D+00,-2.0000D+00) +( 1.0000D+00,-2.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 7.0000D+00, 0.0000D+00) +(-3.0000D+00, 0.0000D+00) (-1.0000D+00,-2.0000D+00) -( 1.0000D+00,-2.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 7.0000D+00, 0.0000D+00) +(-2.0000D+00, 2.0000D+00) (-3.0000D+00, 0.0000D+00) -(-1.0000D+00,-2.0000D+00) -(-2.0000D+00, 2.0000D+00) -(-3.0000D+00, 0.0000D+00) ( 7.0000D+00, 0.0000D+00) -8.0767D-03 -2.5211D-01 9.9864D-01 7.7961D+00 7.7723D+00 2.4349D-01 7.0272D-01 3.3337D-01 8.0000D+00 -3.4273D-07 7.0711D-01 3.3337D-01 1.2236D+01 8.6188D-03 9.9021D-01 3.9429D+00 5 0 -( 1.0000D+00, 2.0000D+00) -( 3.0000D+00, 4.0000D+00) -( 2.1000D+01, 2.2000D+01) -( 2.3000D+01, 2.4000D+01) +( 1.0000D+00, 2.0000D+00) +( 3.0000D+00, 4.0000D+00) +( 2.1000D+01, 2.2000D+01) +( 2.3000D+01, 2.4000D+01) ( 4.1000D+01, 4.2000D+01) -( 4.3000D+01, 4.4000D+01) -( 1.3000D+01, 1.4000D+01) -( 1.5000D+01, 1.6000D+01) -( 3.3000D+01, 3.4000D+01) +( 4.3000D+01, 4.4000D+01) +( 1.3000D+01, 1.4000D+01) +( 1.5000D+01, 1.6000D+01) +( 3.3000D+01, 3.4000D+01) ( 3.5000D+01, 3.6000D+01) -( 5.0000D+00, 6.0000D+00) -( 7.0000D+00, 8.0000D+00) -( 2.5000D+01, 2.6000D+01) -( 2.7000D+01, 2.8000D+01) +( 5.0000D+00, 6.0000D+00) +( 7.0000D+00, 8.0000D+00) +( 2.5000D+01, 2.6000D+01) +( 2.7000D+01, 2.8000D+01) ( 4.5000D+01, 4.6000D+01) -( 4.7000D+01, 4.8000D+01) -( 1.7000D+01, 1.8000D+01) -( 1.9000D+01, 2.0000D+01) -( 3.7000D+01, 3.8000D+01) +( 4.7000D+01, 4.8000D+01) +( 1.7000D+01, 1.8000D+01) +( 1.9000D+01, 2.0000D+01) +( 3.7000D+01, 3.8000D+01) ( 3.9000D+01, 4.0000D+01) -( 9.0000D+00, 1.0000D+01) -( 1.1000D+01, 1.2000D+01) -( 2.9000D+01, 3.0000D+01) -( 3.1000D+01, 3.2000D+01) +( 9.0000D+00, 1.0000D+01) +( 1.1000D+01, 1.2000D+01) +( 2.9000D+01, 3.0000D+01) +( 3.1000D+01, 3.2000D+01) ( 4.9000D+01, 5.0000D+01) -9.4600D+00 7.2802D+00 3.1053D-01 1.1937D+01 -7.7912D-06 -1.2743D-05 2.9408D-01 1.6030D-05 @@ -886,88 +886,88 @@ ZVX 21 Use all matrix types 7.0733D+00 -9.5584D+00 3.0911D-01 1.1891D+01 1.2739D+02 1.3228D+02 9.2770D-01 1.2111D+02 3 0 -( 1.0000D+00, 1.0000D+00) -(-1.0000D+00,-1.0000D+00) +( 1.0000D+00, 1.0000D+00) +(-1.0000D+00,-1.0000D+00) ( 2.0000D+00, 2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -(-1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +(-1.0000D+00, 0.0000D+00) ( 3.0000D+00, 1.0000D+00) 1.0000D+00 1.0000D+00 3.0151D-01 0.0000D+00 1.0000D+00 1.0000D+00 3.1623D-01 0.0000D+00 2.0000D+00 1.0000D+00 2.2361D-01 1.0000D+00 4 1 -(-4.0000D+00,-2.0000D+00) -(-5.0000D+00,-6.0000D+00) -(-2.0000D+00,-6.0000D+00) +(-4.0000D+00,-2.0000D+00) +(-5.0000D+00,-6.0000D+00) +(-2.0000D+00,-6.0000D+00) ( 0.0000D+00,-2.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -9.9883D-01 -1.0006D+00 1.3180D-04 2.4106D-04 -1.0012D+00 -9.9945D-01 1.3140D-04 2.4041D-04 -9.9947D-01 -6.8325D-04 1.3989D-04 8.7487D-05 -1.0005D+00 6.8556D-04 1.4010D-04 8.7750D-05 7 0 -( 2.0000D+00, 4.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 6.0000D+00, 2.0000D+00) -( 3.0000D+00, 3.0000D+00) -( 5.0000D+00, 5.0000D+00) -( 2.0000D+00, 6.0000D+00) +( 2.0000D+00, 4.0000D+00) ( 1.0000D+00, 1.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 1.0000D+00, 3.0000D+00) -( 3.0000D+00, 1.0000D+00) -( 5.0000D+00,-4.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 7.0000D+00, 2.0000D+00) +( 6.0000D+00, 2.0000D+00) +( 3.0000D+00, 3.0000D+00) +( 5.0000D+00, 5.0000D+00) +( 2.0000D+00, 6.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 1.0000D+00, 3.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 5.0000D+00,-4.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 7.0000D+00, 2.0000D+00) ( 2.0000D+00, 3.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 3.0000D+00,-2.0000D+00) -( 1.0000D+00, 1.0000D+00) -( 6.0000D+00, 3.0000D+00) -( 2.0000D+00, 1.0000D+00) -( 1.0000D+00, 4.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 3.0000D+00,-2.0000D+00) +( 1.0000D+00, 1.0000D+00) +( 6.0000D+00, 3.0000D+00) +( 2.0000D+00, 1.0000D+00) +( 1.0000D+00, 4.0000D+00) ( 2.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00, 3.0000D+00) -( 3.0000D+00, 1.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 2.0000D+00, 2.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00, 3.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 2.0000D+00, 2.0000D+00) +( 3.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00,-1.0000D+00) +( 2.0000D+00, 2.0000D+00) ( 3.0000D+00, 1.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00,-1.0000D+00) -( 2.0000D+00, 2.0000D+00) -( 3.0000D+00, 1.0000D+00) ( 1.0000D+00, 3.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 1.0000D+00,-1.0000D+00) -( 2.0000D+00, 1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 1.0000D+00,-1.0000D+00) +( 2.0000D+00, 1.0000D+00) ( 2.0000D+00, 2.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 2.0000D+00,-2.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 2.0000D+00,-2.0000D+00) ( 1.0000D+00, 1.0000D+00) -2.7081D+00 -2.8029D+00 6.9734D-01 3.9279D+00 -1.1478D+00 8.0176D-01 6.5772D-01 9.4243D-01 @@ -977,30 +977,30 @@ ZVX 21 Use all matrix types 5.3138D+00 1.2242D+00 3.0213D-01 7.1268D-01 8.2674D+00 3.7047D+00 2.8270D-01 3.2849D+00 5 1 -( 0.0000D+00, 5.0000D+00) -( 1.0000D+00, 2.0000D+00) -( 2.0000D+00, 3.0000D+00) -(-3.0000D+00, 6.0000D+00) +( 0.0000D+00, 5.0000D+00) +( 1.0000D+00, 2.0000D+00) +( 2.0000D+00, 3.0000D+00) +(-3.0000D+00, 6.0000D+00) ( 6.0000D+00, 0.0000D+00) -(-1.0000D+00, 2.0000D+00) -( 0.0000D+00, 6.0000D+00) -( 4.0000D+00, 5.0000D+00) -(-3.0000D+00,-2.0000D+00) +(-1.0000D+00, 2.0000D+00) +( 0.0000D+00, 6.0000D+00) +( 4.0000D+00, 5.0000D+00) +(-3.0000D+00,-2.0000D+00) ( 5.0000D+00, 0.0000D+00) -(-2.0000D+00, 3.0000D+00) -(-4.0000D+00, 5.0000D+00) -( 0.0000D+00, 7.0000D+00) -( 3.0000D+00, 0.0000D+00) +(-2.0000D+00, 3.0000D+00) +(-4.0000D+00, 5.0000D+00) +( 0.0000D+00, 7.0000D+00) +( 3.0000D+00, 0.0000D+00) ( 2.0000D+00, 0.0000D+00) -( 3.0000D+00, 6.0000D+00) -( 3.0000D+00,-2.0000D+00) -(-3.0000D+00, 0.0000D+00) -( 0.0000D+00,-5.0000D+00) +( 3.0000D+00, 6.0000D+00) +( 3.0000D+00,-2.0000D+00) +(-3.0000D+00, 0.0000D+00) +( 0.0000D+00,-5.0000D+00) ( 2.0000D+00, 1.0000D+00) -(-6.0000D+00, 0.0000D+00) -(-5.0000D+00, 0.0000D+00) -(-2.0000D+00, 0.0000D+00) -(-2.0000D+00, 1.0000D+00) +(-6.0000D+00, 0.0000D+00) +(-5.0000D+00, 0.0000D+00) +(-2.0000D+00, 0.0000D+00) +(-2.0000D+00, 1.0000D+00) ( 0.0000D+00, 2.0000D+00) -4.1735D-08 -1.0734D+01 1.0000D+00 7.7345D+00 -2.6397D-07 -2.9991D+00 1.0000D+00 4.5989D+00 @@ -1008,14 +1008,14 @@ ZVX 21 Use all matrix types -4.4369D-07 9.3159D+00 1.0000D+00 7.7161D+00 4.0937D-09 1.7817D+01 1.0000D+00 8.5013D+00 3 0 -( 2.0000D+00, 0.0000D+00) -( 0.0000D+00,-1.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00,-1.0000D+00) +( 0.0000D+00, 0.0000D+00) +( 0.0000D+00, 1.0000D+00) +( 2.0000D+00, 0.0000D+00) +( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 1.0000D+00) -( 2.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) -( 0.0000D+00, 0.0000D+00) ( 3.0000D+00, 0.0000D+00) 1.0000D+00 0.0000D+00 1.0000D+00 2.0000D+00 3.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 diff --git a/lapack-netlib/TESTING/zgbak.in b/lapack-netlib/TESTING/zgbak.in index e11d5026ea..6c890d06d6 100644 --- a/lapack-netlib/TESTING/zgbak.in +++ b/lapack-netlib/TESTING/zgbak.in @@ -443,4 +443,4 @@ ZGK: Tests ZGGBAK (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) -0 0 +0 0 diff --git a/lapack-netlib/TESTING/zgbal.in b/lapack-netlib/TESTING/zgbal.in index 51b1164c2b..fff9e051e6 100644 --- a/lapack-netlib/TESTING/zgbal.in +++ b/lapack-netlib/TESTING/zgbal.in @@ -657,4 +657,4 @@ ZGL: Tests ZGGBAL 0.2000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.5000D+01 0.5000D+01 -0 +0 diff --git a/lapack-netlib/TESTING/zgd.in b/lapack-netlib/TESTING/zgd.in index e92782a4ee..bf462b7686 100644 --- a/lapack-netlib/TESTING/zgd.in +++ b/lapack-netlib/TESTING/zgd.in @@ -1,6 +1,6 @@ ZGV Data for the Complex Nonsymmetric Eigenvalue Driver 6 Number of matrix dimensions -2 6 8 10 12 20 Matrix dimensions +2 6 8 10 12 20 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -8,7 +8,7 @@ ZGV Data for the Complex Nonsymmetric Eigenvalue Driver ZGV 26 Test all 26 matrix types ZGS Data for the Complex Nonsymmetric Schur Form Driver 5 Number of matrix dimensions -2 6 10 12 20 30 Matrix dimensions +2 6 10 12 20 30 Matrix dimensions 1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL 10 Threshold for test ratios .TRUE. Put T to test the error exits @@ -32,11 +32,11 @@ ZGX Data for the Complex Nonsymmetric Schur Form Expert Driver 10 Threshold for test ratios .TRUE. Put T to test the error exits 0 Code to interpret the seed - 4 + 4 2 ( 2.0000D+00, 6.0000D+00) ( 2.0000D+00, 5.0000D+00) -( 3.0000D+00,-1.0000D+01) +( 3.0000D+00,-1.0000D+01) ( 4.0000D+00, 7.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 9.0000D+00, 2.0000D+00) @@ -50,7 +50,7 @@ ZGX Data for the Complex Nonsymmetric Schur Form Expert Driver ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 1.0000D+01,-1.6000D+01) -(-9.0000D+00, 1.0000D+00) +(-9.0000D+00, 1.0000D+00) (-1.0000D+00,-8.0000D+00) (-1.0000D+00, 1.0000D+01) ( 2.0000D+00,-6.0000D+00) @@ -67,12 +67,12 @@ ZGX Data for the Complex Nonsymmetric Schur Form Expert Driver ( 0.0000D+00, 0.0000D+00) ( 8.0000D+00, 4.0000D+00) 7.6883D-02 2.1007D-01 Condition #'s for cluster selected from lower 2x2 - 4 + 4 2 ( 1.0000D+00, 8.0000D+00) ( 2.0000D+00, 4.0000D+00) ( 3.0000D+00,-1.3000D+01) -( 4.0000D+00, 4.0000D+00) +( 4.0000D+00, 4.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 5.0000D+00, 7.0000D+00) ( 6.0000D+00,-2.4000D+01) @@ -112,7 +112,7 @@ ZXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver 4 ( 2.0000D+00, 6.0000D+00) ( 2.0000D+00, 5.0000D+00) -( 3.0000D+00,-1.0000D+01) +( 3.0000D+00,-1.0000D+01) ( 4.0000D+00, 7.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 9.0000D+00, 2.0000D+00) @@ -126,7 +126,7 @@ ZXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 1.0000D+01,-1.6000D+01) -(-9.0000D+00, 1.0000D+00) +(-9.0000D+00, 1.0000D+00) (-1.0000D+00,-8.0000D+00) (-1.0000D+00, 1.0000D+01) ( 2.0000D+00,-6.0000D+00) @@ -144,11 +144,11 @@ ZXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver ( 8.0000D+00, 4.0000D+00) 5.2612D+00 8.0058D-01 1.4032D+00 4.0073D+00 condition #'s for eigenvalues 1.1787D+00 3.3139D+00 1.1835D+00 2.0777D+00 condition #'s for eigenvectors - 4 + 4 ( 1.0000D+00, 8.0000D+00) ( 2.0000D+00, 4.0000D+00) ( 3.0000D+00,-1.3000D+01) -( 4.0000D+00, 4.0000D+00) +( 4.0000D+00, 4.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 5.0000D+00, 7.0000D+00) ( 6.0000D+00,-2.4000D+01) diff --git a/lapack-netlib/TESTING/ztest.in b/lapack-netlib/TESTING/ztest.in index 1060351018..aba4a3d554 100644 --- a/lapack-netlib/TESTING/ztest.in +++ b/lapack-netlib/TESTING/ztest.in @@ -24,9 +24,12 @@ ZPB 8 List types on next line if 0 < NTYPES < 8 ZPT 12 List types on next line if 0 < NTYPES < 12 ZHE 10 List types on next line if 0 < NTYPES < 10 ZHR 10 List types on next line if 0 < NTYPES < 10 +ZHK 10 List types on next line if 0 < NTYPES < 10 +ZHA 10 List types on next line if 0 < NTYPES < 10 ZHP 10 List types on next line if 0 < NTYPES < 10 ZSY 11 List types on next line if 0 < NTYPES < 11 ZSR 11 List types on next line if 0 < NTYPES < 11 +ZSK 11 List types on next line if 0 < NTYPES < 11 ZSP 11 List types on next line if 0 < NTYPES < 11 ZTR 18 List types on next line if 0 < NTYPES < 18 ZTP 18 List types on next line if 0 < NTYPES < 18 @@ -41,3 +44,6 @@ ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ ZQT ZQX +ZXQ +ZTQ +ZTS diff --git a/lapack-netlib/lapack.pc.in b/lapack-netlib/lapack.pc.in index d34c8708be..878efc2ee6 100644 --- a/lapack-netlib/lapack.pc.in +++ b/lapack-netlib/lapack.pc.in @@ -1,7 +1,7 @@ prefix=@prefix@ libdir=@libdir@ -Name: lapack +Name: LAPACK Description: FORTRAN reference implementation of LAPACK Linear Algebra PACKage Version: @LAPACK_VERSION@ URL: http://www.netlib.org/lapack/ diff --git a/lapack-netlib/lapack_build.cmake b/lapack-netlib/lapack_build.cmake index df32dace2d..68744cc4c1 100644 --- a/lapack-netlib/lapack_build.cmake +++ b/lapack-netlib/lapack_build.cmake @@ -1,18 +1,24 @@ -cmake_minimum_required(VERSION 2.8.7) +## +## HINTS: ctest -Ddashboard_model=Continuous -S $(pwd)/lapack/lapack_build.cmake +## HINTS: ctest -Ddashboard_model=Experimental -S $(pwd)/lapack/lapack_build.cmake +## HINTS: ctest -Ddashboard_model=Nightly -S $(pwd)/lapack/lapack_build.cmake +## + +cmake_minimum_required(VERSION 2.8.10) ################################################################### # The values in this section must always be provided ################################################################### if(UNIX) if(NOT compiler) set(compiler gcc) - endif(NOT compiler) + endif() if(NOT c_compiler) set(c_compiler gcc) - endif(NOT c_compiler) + endif() if(NOT full_compiler) set(full_compiler g++) - endif(NOT full_compiler) -endif(UNIX) + endif() +endif() if(EXISTS "/proc/cpuinfo") set(parallel 1) @@ -21,11 +27,11 @@ if(EXISTS "/proc/cpuinfo") if("${line}" MATCHES processor) math(EXPR parallel "${parallel} + 1") endif() - endforeach(line) + endforeach() endif() if(WIN32) - set(VSLOCATIONS + set(VSLOCATIONS "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\6.0\\Setup;VsCommonDir]/MSDev98/Bin" "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.0\\Setup\\VS;EnvironmentDirectory]" "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.1\\Setup\\VS;EnvironmentDirectory]" @@ -57,7 +63,7 @@ if(WIN32) set(CTEST_CMAKE_GENERATOR "${GENERATOR}") message("${CTEST_CMAKE_GENERATOR} - found") set(compiler cl) -endif(WIN32) +endif() find_program(HOSTNAME NAMES hostname) find_program(UNAME NAMES uname) @@ -70,20 +76,17 @@ message("HOSTNAME: ${hostname}") # default to parallel 1 if(NOT DEFINED parallel) set(parallel 1) -endif(NOT DEFINED parallel) - -# find CVS -find_program(SVN svn PATHS $ENV{HOME}/bin /vol/local/bin) -if(NOT SVN) - message(FATAL_ERROR "SVN not found") endif() -set(CTEST_UPDATE_COMMAND ${SVN}) +find_package(Git REQUIRED) + +set(CTEST_GIT_COMMAND ${GIT_EXECUTABLE}) +set(CTEST_UPDATE_COMMAND ${GIT_EXECUTABLE}) macro(getuname name flag) exec_program("${UNAME}" ARGS "${flag}" OUTPUT_VARIABLE "${name}") string(REGEX REPLACE "[/\\\\+<> #]" "-" "${name}" "${${name}}") string(REGEX REPLACE "^(......|.....|....|...|..|.).*" "\\1" "${name}" "${${name}}") -endmacro(getuname) +endmacro() getuname(osname -s) getuname(osver -v) @@ -97,42 +100,54 @@ if("${osname}" MATCHES Darwin) set(osrel "") if("${cpu}" MATCHES "Power") set(cpu "ppc") - endif("${cpu}" MATCHES "Power") -endif("${osname}" MATCHES Darwin) + endif() +endif() if(NOT compiler) message(FATAL_ERROR "compiler must be set") -endif(NOT compiler) +endif() + - set(BUILDNAME "${osname}${osver}${osrel}${cpu}-${compiler}") message("BUILDNAME: ${BUILDNAME}") -# this is the cvs module name that should be checked out -set (CTEST_MODULE_NAME lapack) -set (CTEST_DIR_NAME "${CTEST_MODULE_NAME}SVN") +# this is the module name that should be checked out +set (CTEST_DIR_NAME "lapackGIT") # Settings: message("NOSPACES = ${NOSPACES}") if(NOSPACES) set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/MyTests-${BUILDNAME}") -else(NOSPACES) +else() set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/My Tests-${BUILDNAME}") -endif(NOSPACES) +endif() set(CTEST_SITE "${hostname}") set(CTEST_BUILD_NAME "${BUILDNAME}") set(CTEST_TEST_TIMEOUT "36000") -# CVS command and the checkout command +# GIT command and the checkout command +# Select Git source to use. +if(NOT DEFINED dashboard_git_url) + set(dashboard_git_url "https://github.com/Reference-LAPACK/lapack.git") +endif() +if(NOT DEFINED dashboard_git_branch) + set(dashboard_git_branch master) +endif() + if(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}") - set(CTEST_CHECKOUT_COMMAND - "\"${CTEST_UPDATE_COMMAND}\" co https://icl.cs.utk.edu/svn/lapack-dev/lapack/trunk ${CTEST_DIR_NAME}") -endif(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}") + set(CTEST_CHECKOUT_COMMAND + "\"${CTEST_UPDATE_COMMAND}\" clone ${dashboard_git_url} ${CTEST_DIR_NAME}") +endif() + +# Explicitly specify the remote as "origin". This ensure we are pulling from +# the correct remote and prevents command failures when the git tracking +# branch has not been configured. +set(CTEST_GIT_UPDATE_CUSTOM "${CTEST_GIT_COMMAND}" pull origin ${dashboard_git_branch}) # Set the generator and build configuration if(NOT DEFINED CTEST_CMAKE_GENERATOR) set(CTEST_CMAKE_GENERATOR "Unix Makefiles") -endif(NOT DEFINED CTEST_CMAKE_GENERATOR) +endif() set(CTEST_PROJECT_NAME "LAPACK") set(CTEST_BUILD_CONFIGURATION "Release") @@ -142,17 +157,17 @@ if(CTEST_CMAKE_GENERATOR MATCHES Makefiles) set(ENV{CC} "${c_compiler}") set(ENV{FC} "${f_compiler}") set(ENV{CXX} "${full_compiler}") -endif(CTEST_CMAKE_GENERATOR MATCHES Makefiles) +endif() #---------------------------------------------------------------------------------- # Should not need to edit under this line #---------------------------------------------------------------------------------- -# if you do not want to use the default location for a +# if you do not want to use the default location for a # dashboard then set this variable to the directory # the dashboard should be in make_directory("${CTEST_DASHBOARD_ROOT}") -# these are the the name of the source and binary directory on disk. +# these are the the name of the source and binary directory on disk. # They will be appended to DASHBOARD_ROOT set(CTEST_SOURCE_DIRECTORY "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}") set(CTEST_BINARY_DIRECTORY "${CTEST_SOURCE_DIRECTORY}-${CTEST_BUILD_NAME}") @@ -161,15 +176,15 @@ set(CTEST_NOTES_FILES "${CTEST_NOTES_FILES}" ) # check for parallel -if(parallel GREATER 10) +if(parallel GREATER 1 ) if(NOT CTEST_BUILD_COMMAND) set(CTEST_BUILD_COMMAND "make -j${parallel} -i") - endif(NOT CTEST_BUILD_COMMAND) + endif() message("Use parallel build") message("CTEST_BUILD_COMMAND: ${CTEST_BUILD_COMMAND}") message("CTEST_CONFIGURE_COMMAND: ${CTEST_CONFIGURE_COMMAND}") -endif(parallel GREATER 10) +endif() ################################################################### # Values for the cmake build @@ -179,13 +194,17 @@ set( CACHE_CONTENTS " SITE:STRING=${hostname} BUILDNAME:STRING=${BUILDNAME} DART_ROOT:PATH= -SVNCOMMAND:FILEPATH=${CTEST_UPDATE_COMMAND} +GITCOMMAND:FILEPATH=${CTEST_UPDATE_COMMAND} DROP_METHOD:STRING=https DART_TESTING_TIMEOUT:STRING=${CTEST_TEST_TIMEOUT} +#Set build type to use optimized build +CMAKE_BUILD_TYPE:STRING=Release # Enable LAPACKE LAPACKE:OPTION=ON +CBLAS:OPTION=ON # Use Reference BLAS by default USE_OPTIMIZED_BLAS:OPTION=OFF +USE_OPTIMIZED_LAPACK:OPTION=OFF " ) @@ -203,8 +222,16 @@ message("CTest command: ${CTEST_COMMAND}") # any quotes inside of this string if you use it file(WRITE "${CTEST_BINARY_DIRECTORY}/CMakeCache.txt" "${CACHE_CONTENTS}") +# Select the model (Nightly, Experimental, Continuous). +if(NOT DEFINED dashboard_model) + set(dashboard_model Nightly) +endif() +if(NOT "${dashboard_model}" MATCHES "^(Nightly|Experimental|Continuous)$") + message(FATAL_ERROR "dashboard_model must be Nightly, Experimental, or Continuous") +endif() + message("Start dashboard...") -ctest_start(Nightly) +ctest_start(${dashboard_model}) #ctest_start(Experimental) message(" Update") ctest_update(SOURCE "${CTEST_SOURCE_DIRECTORY}" RETURN_VALUE res) diff --git a/lapack-netlib/lapack_testing.py b/lapack-netlib/lapack_testing.py index 8ddc049b7e..70783fee9d 100755 --- a/lapack-netlib/lapack_testing.py +++ b/lapack-netlib/lapack_testing.py @@ -3,22 +3,22 @@ ############################################################################### -# lapack_testing.py +# lapack_testing.py ############################################################################### - -from subprocess import Popen, STDOUT, PIPE +from __future__ import print_function +from subprocess import Popen, STDOUT, PIPE import os, sys, math import getopt # Arguments try: - opts, args = getopt.getopt(sys.argv[1:], "hd:srep:t:n", - ["help", "dir", "short", "run", "error","prec=","test=","number"]) - -except getopt.error, msg: - print msg - print "for help use --help" - sys.exit(2) + opts, args = getopt.getopt(sys.argv[1:], "hd:srep:t:n", + ["help", "dir", "short", "run", "error","prec=","test=","number"]) + +except getopt.error as msg: + print(msg) + print("for help use --help") + sys.exit(2) short_summary=0 with_file=1 @@ -32,56 +32,56 @@ abs_bin_dir=os.path.normpath(os.path.join(os.getcwd(),bin_dir)) for o, a in opts: - if o in ("-h", "--help"): - print sys.argv[0]+" [-h|--help] [-d dir |--dir dir] [-s |--short] [-r |--run] [-e |--error] [-p p |--prec p] [-t test |--test test] [-n | --number]" - print " - h is to print this message" - print " - r is to use to run the LAPACK tests then analyse the output (.out files). By default, the script will not run all the LAPACK tests" - print " - d [dir] is to indicate where is the LAPACK testing directory (.out files). By default, the script will use ." - print " LEVEL OF OUTPUT" - print " - x is to print a detailed summary" - print " - e is to print only the error summary" - print " - s is to print a short summary" - print " - n is to print the numbers of failing tests (turn on summary mode)" - print " SECLECTION OF TESTS:" - print " - p [s/c/d/z/x] is to indicate the PRECISION to run:" - print " s=single" - print " d=double" - print " sd=single/double" - print " c=complex" - print " z=double complex" - print " cz=complex/double complex" - print " x=all [DEFAULT]" - print " - t [lin/eig/mixed/rfp/all] is to indicate which TEST FAMILY to run:" - print " lin=Linear Equation" - print " eig=Eigen Problems" - print " mixed=mixed-precision" - print " rfp=rfp format" - print " all=all tests [DEFAULT]" - print " EXAMPLES:" - print " ./lapack_testing.py -n" - print " Will return the numbers of failed tests by analyzing the LAPACK output" - print " ./lapack_testing.py -n -r -p s" - print " Will return the numbers of failed tests in REAL precision by running the LAPACK Tests then analyzing the output" - print " ./lapack_testing.py -n -p s -t eig " - print " Will return the numbers of failed tests in REAL precision by analyzing only the LAPACK output of EIGEN testings" - print "Written by Julie Langou (June 2011) " - sys.exit(0) - else: - if o in ("-s", "--short"): - short_summary = 1 - if o in ("-r", "--run"): - with_file = 0 - if o in ("-e", "--error"): - just_errors = 1 - if o in ( '-p', '--prec' ): - prec = a - if o in ( '-d', '--dir' ): - test_dir = a - if o in ( '-t', '--test' ): - test = a - if o in ( '-n', '--number' ): - only_numbers = 1 - short_summary = 1 + if o in ("-h", "--help"): + print(sys.argv[0]+" [-h|--help] [-d dir |--dir dir] [-s |--short] [-r |--run] [-e |--error] [-p p |--prec p] [-t test |--test test] [-n | --number]") + print(" - h is to print this message") + print(" - r is to use to run the LAPACK tests then analyse the output (.out files). By default, the script will not run all the LAPACK tests") + print(" - d [dir] is to indicate where is the LAPACK testing directory (.out files). By default, the script will use .") + print(" LEVEL OF OUTPUT") + print(" - x is to print a detailed summary") + print(" - e is to print only the error summary") + print(" - s is to print a short summary") + print(" - n is to print the numbers of failing tests (turn on summary mode)") + print(" SECLECTION OF TESTS:") + print(" - p [s/c/d/z/x] is to indicate the PRECISION to run:") + print(" s=single") + print(" d=double") + print(" sd=single/double") + print(" c=complex") + print(" z=double complex") + print(" cz=complex/double complex") + print(" x=all [DEFAULT]") + print(" - t [lin/eig/mixed/rfp/all] is to indicate which TEST FAMILY to run:") + print(" lin=Linear Equation") + print(" eig=Eigen Problems") + print(" mixed=mixed-precision") + print(" rfp=rfp format") + print(" all=all tests [DEFAULT]") + print(" EXAMPLES:") + print(" ./lapack_testing.py -n") + print(" Will return the numbers of failed tests by analyzing the LAPACK output") + print(" ./lapack_testing.py -n -r -p s") + print(" Will return the numbers of failed tests in REAL precision by running the LAPACK Tests then analyzing the output") + print(" ./lapack_testing.py -n -p s -t eig ") + print(" Will return the numbers of failed tests in REAL precision by analyzing only the LAPACK output of EIGEN testings") + print("Written by Julie Langou (June 2011) ") + sys.exit(0) + else: + if o in ("-s", "--short"): + short_summary = 1 + if o in ("-r", "--run"): + with_file = 0 + if o in ("-e", "--error"): + just_errors = 1 + if o in ( '-p', '--prec' ): + prec = a + if o in ( '-d', '--dir' ): + test_dir = a + if o in ( '-t', '--test' ): + test = a + if o in ( '-n', '--number' ): + only_numbers = 1 + short_summary = 1 # process options @@ -89,7 +89,7 @@ execution=1 summary="\n\t\t\t--> LAPACK TESTING SUMMARY <--\n"; -if with_file: summary+= "\t\tProcessing LAPACK Testing output found in the "+test_dir+" direcory\n"; +if with_file: summary+= "\t\tProcessing LAPACK Testing output found in the "+test_dir+" directory\n"; summary+="SUMMARY \tnb test run \tnumerical error \tother error \n"; summary+="================ \t===========\t=================\t================ \n"; nb_of_test=0 @@ -100,80 +100,80 @@ # Define a function to open the executable (different filenames on unix and Windows) def run_summary_test( f, cmdline, short_summary): - nb_test_run=0 - nb_test_fail=0 - nb_test_illegal=0 - nb_test_info=0 - - if (with_file): - if not os.path.exists(cmdline): - error_message=cmdline+" file not found" - r=1 - if short_summary: return [nb_test_run,nb_test_fail,nb_test_illegal,nb_test_info] - else: - pipe = open(cmdline,'r') - r=0 - else: - if os.name != 'nt': - cmdline='./' + cmdline - else : - cmdline=abs_bin_dir+os.path.sep+cmdline - - outfile=cmdline.split()[4] - #pipe = open(outfile,'w') - p = Popen(cmdline, shell=True)#, stdout=pipe) - p.wait() - #pipe.close() - r=p.returncode - pipe = open(outfile,'r') - error_message=cmdline+" did not work" - - if r != 0 and not with_file: - print "---- TESTING " + cmdline.split()[0] + "... FAILED(" + error_message +") !" - for line in pipe.readlines(): - f.write(str(line)) - elif r != 0 and with_file and not short_summary: - print "---- WARNING: please check that you have the LAPACK output : "+cmdline+"!" - print "---- WARNING: with the option -r, we can run the LAPACK testing for you" - # print "---- "+error_message - else: - for line in pipe.readlines(): - f.write(str(line)) - words_in_line=line.split() - if (line.find("run")!=-1): -# print line - whereisrun=words_in_line.index("run)") - nb_test_run+=int(words_in_line[whereisrun-2]) - if (line.find("out of")!=-1): - if (short_summary==0): print line, - whereisout= words_in_line.index("out") - nb_test_fail+=int(words_in_line[whereisout-1]) - if ((line.find("illegal")!=-1) or (line.find("Illegal")!=-1)): - if (short_summary==0):print line, - nb_test_illegal+=1 - if (line.find(" INFO")!=-1): - if (short_summary==0):print line, - nb_test_info+=1 - if (with_file==1): - pipe.close() - - f.flush(); - - return [nb_test_run,nb_test_fail,nb_test_illegal,nb_test_info] + nb_test_run=0 + nb_test_fail=0 + nb_test_illegal=0 + nb_test_info=0 + + if (with_file): + if not os.path.exists(cmdline): + error_message=cmdline+" file not found" + r=1 + if short_summary: return [nb_test_run,nb_test_fail,nb_test_illegal,nb_test_info] + else: + pipe = open(cmdline,'r') + r=0 + else: + if os.name != 'nt': + cmdline='./' + cmdline + else : + cmdline=abs_bin_dir+os.path.sep+cmdline + + outfile=cmdline.split()[4] + #pipe = open(outfile,'w') + p = Popen(cmdline, shell=True)#, stdout=pipe) + p.wait() + #pipe.close() + r=p.returncode + pipe = open(outfile,'r') + error_message=cmdline+" did not work" + + if r != 0 and not with_file: + print("---- TESTING " + cmdline.split()[0] + "... FAILED(" + error_message +") !") + for line in pipe.readlines(): + f.write(str(line)) + elif r != 0 and with_file and not short_summary: + print("---- WARNING: please check that you have the LAPACK output : "+cmdline+"!") + print("---- WARNING: with the option -r, we can run the LAPACK testing for you") + # print "---- "+error_message + else: + for line in pipe.readlines(): + f.write(str(line)) + words_in_line=line.split() + if (line.find("run")!=-1): +# print line + whereisrun=words_in_line.index("run)") + nb_test_run+=int(words_in_line[whereisrun-2]) + if (line.find("out of")!=-1): + if (short_summary==0): print(line, end=' ') + whereisout= words_in_line.index("out") + nb_test_fail+=int(words_in_line[whereisout-1]) + if ((line.find("illegal")!=-1) or (line.find("Illegal")!=-1)): + if (short_summary==0):print(line, end=' ') + nb_test_illegal+=1 + if (line.find(" INFO")!=-1): + if (short_summary==0):print(line, end=' ') + nb_test_info+=1 + if (with_file==1): + pipe.close() + + f.flush(); + + return [nb_test_run,nb_test_fail,nb_test_illegal,nb_test_info] # If filename cannot be opened, send output to sys.stderr filename = "testing_results.txt" try: - f = open(filename, 'w') + f = open(filename, 'w') except IOError: - f = sys.stdout + f = sys.stdout if (short_summary==0): - print " " - print "---------------- Testing LAPACK Routines ----------------" - print " " - print "-- Detailed results are stored in", filename + print(" ") + print("---------------- Testing LAPACK Routines ----------------") + print(" ") + print("-- Detailed results are stored in", filename) dtypes = ( ("s", "d", "c", "z"), @@ -181,32 +181,32 @@ def run_summary_test( f, cmdline, short_summary): ) if prec=='s': - range_prec=[0] + range_prec=[0] elif prec=='d': - range_prec=[1] + range_prec=[1] elif prec=='sd': - range_prec=[0,1] + range_prec=[0,1] elif prec=='c': - range_prec=[2] + range_prec=[2] elif prec=='z': - range_prec=[3] + range_prec=[3] elif prec=='cz': - range_prec=[2,3] -else: - prec='x'; - range_prec=range(4) + range_prec=[2,3] +else: + prec='x'; + range_prec=list(range(4)) if test=='lin': - range_test=[15] + range_test=[16] elif test=='mixed': - range_test=[16] - range_prec=[1,3] + range_test=[17] + range_prec=[1,3] elif test=='rfp': - range_test=[17] + range_test=[18] elif test=='eig': - range_test=range(15) -else: - range_test=range(18) + range_test=list(range(16)) +else: + range_test=list(range(19)) list_results = [ [0, 0, 0, 0, 0], @@ -216,111 +216,111 @@ def run_summary_test( f, cmdline, short_summary): ] for dtype in range_prec: - letter = dtypes[0][dtype] - name = dtypes[1][dtype] - - if (short_summary==0): - print " " - print "------------------------- %s ------------------------" % name - print " " - sys.stdout.flush() - - dtests = ( - ("nep", "sep", "svd", - letter+"ec",letter+"ed",letter+"gg", - letter+"gd",letter+"sb",letter+"sg", - letter+"bb","glm","gqr", - "gsv","csd","lse", - letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), - ("Nonsymmetric Eigenvalue Problem", "Symmetric Eigenvalue Problem", "Singular Value Decomposition", - "Eigen Condition","Nonsymmetric Eigenvalue","Nonsymmetric Generalized Eigenvalue Problem", - "Nonsymmetric Generalized Eigenvalue Problem driver", "Symmetric Eigenvalue Problem", "Symmetric Eigenvalue Generalized Problem", - "Banded Singular Value Decomposition routines", "Generalized Linear Regression Model routines", "Generalized QR and RQ factorization routines", - "Generalized Singular Value Decomposition routines", "CS Decomposition routines", "Constrained Linear Least Squares routines", - "Linear Equation routines", "Mixed Precision linear equation routines","RFP linear equation routines"), - (letter+"nep", letter+"sep", letter+"svd", - letter+"ec",letter+"ed",letter+"gg", - letter+"gd",letter+"sb",letter+"sg", - letter+"bb",letter+"glm",letter+"gqr", - letter+"gsv",letter+"csd",letter+"lse", - letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), - ) - - - for dtest in range_test: - nb_of_test=0 - # NEED TO SKIP SOME PRECISION (namely s and c) FOR PROTO MIXED PRECISION TESTING - if dtest==16 and (letter=="s" or letter=="c"): - continue - if (with_file==1): - cmdbase=dtests[2][dtest]+".out" - else: - if dtest==15: - # LIN TESTS - cmdbase="xlintst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - elif dtest==16: - # PROTO LIN TESTS - cmdbase="xlintst"+letter+dtypes[0][dtype-1]+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - elif dtest==17: - # PROTO LIN TESTS - cmdbase="xlintstrf"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + letter = dtypes[0][dtype] + name = dtypes[1][dtype] + + if (short_summary==0): + print(" ") + print("------------------------- %s ------------------------" % name) + print(" ") + sys.stdout.flush() + + dtests = ( + ("nep", "sep", "se2", "svd", + letter+"ec",letter+"ed",letter+"gg", + letter+"gd",letter+"sb",letter+"sg", + letter+"bb","glm","gqr", + "gsv","csd","lse", + letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), + ("Nonsymmetric Eigenvalue Problem", "Symmetric Eigenvalue Problem", "Symmetric Eigenvalue Problem 2 stage", "Singular Value Decomposition", + "Eigen Condition","Nonsymmetric Eigenvalue","Nonsymmetric Generalized Eigenvalue Problem", + "Nonsymmetric Generalized Eigenvalue Problem driver", "Symmetric Eigenvalue Problem", "Symmetric Eigenvalue Generalized Problem", + "Banded Singular Value Decomposition routines", "Generalized Linear Regression Model routines", "Generalized QR and RQ factorization routines", + "Generalized Singular Value Decomposition routines", "CS Decomposition routines", "Constrained Linear Least Squares routines", + "Linear Equation routines", "Mixed Precision linear equation routines","RFP linear equation routines"), + (letter+"nep", letter+"sep", letter+"se2", letter+"svd", + letter+"ec",letter+"ed",letter+"gg", + letter+"gd",letter+"sb",letter+"sg", + letter+"bb",letter+"glm",letter+"gqr", + letter+"gsv",letter+"csd",letter+"lse", + letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp"), + ) + + + for dtest in range_test: + nb_of_test=0 + # NEED TO SKIP SOME PRECISION (namely s and c) FOR PROTO MIXED PRECISION TESTING + if dtest==17 and (letter=="s" or letter=="c"): + continue + if (with_file==1): + cmdbase=dtests[2][dtest]+".out" else: - # EIG TESTS - cmdbase="xeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - if (not just_errors and not short_summary): - print "--> Testing "+name+" "+dtests[1][dtest]+" [ "+cmdbase+" ]" - # Run the process: either to read the file or run the LAPACK testing - nb_test = run_summary_test(f, cmdbase, short_summary) - list_results[0][dtype]+=nb_test[0] - list_results[1][dtype]+=nb_test[1] - list_results[2][dtype]+=nb_test[2] - list_results[3][dtype]+=nb_test[3] - got_error=nb_test[1]+nb_test[2]+nb_test[3] - - if (not short_summary): - if (nb_test[0]>0 and just_errors==0): - print "--> Tests passed: "+str(nb_test[0]) - if (nb_test[1]>0): - print "--> Tests failing to pass the threshold: "+str(nb_test[1]) - if (nb_test[2]>0): - print "--> Illegal Error: "+str(nb_test[2]) - if (nb_test[3]>0): - print "--> Info Error: "+str(nb_test[3]) - if (got_error>0 and just_errors==1): - print "ERROR IS LOCATED IN "+name+" "+dtests[1][dtest]+" [ "+cmdbase+" ]" - print "" - if (just_errors==0): - print "" + if dtest==16: + # LIN TESTS + cmdbase="xlintst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + elif dtest==17: + # PROTO LIN TESTS + cmdbase="xlintst"+letter+dtypes[0][dtype-1]+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + elif dtest==18: + # PROTO LIN TESTS + cmdbase="xlintstrf"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + else: + # EIG TESTS + cmdbase="xeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" + if (not just_errors and not short_summary): + print("--> Testing "+name+" "+dtests[1][dtest]+" [ "+cmdbase+" ]") + # Run the process: either to read the file or run the LAPACK testing + nb_test = run_summary_test(f, cmdbase, short_summary) + list_results[0][dtype]+=nb_test[0] + list_results[1][dtype]+=nb_test[1] + list_results[2][dtype]+=nb_test[2] + list_results[3][dtype]+=nb_test[3] + got_error=nb_test[1]+nb_test[2]+nb_test[3] + + if (not short_summary): + if (nb_test[0]>0 and just_errors==0): + print("--> Tests passed: "+str(nb_test[0])) + if (nb_test[1]>0): + print("--> Tests failing to pass the threshold: "+str(nb_test[1])) + if (nb_test[2]>0): + print("--> Illegal Error: "+str(nb_test[2])) + if (nb_test[3]>0): + print("--> Info Error: "+str(nb_test[3])) + if (got_error>0 and just_errors==1): + print("ERROR IS LOCATED IN "+name+" "+dtests[1][dtest]+" [ "+cmdbase+" ]") + print("") + if (just_errors==0): + print("") # elif (got_error>0): # print dtests[2][dtest]+".out \t"+str(nb_test[1])+"\t"+str(nb_test[2])+"\t"+str(nb_test[3]) - - sys.stdout.flush() - if (list_results[0][dtype] > 0 ): - percent_num_error=float(list_results[1][dtype])/float(list_results[0][dtype])*100 - percent_error=float(list_results[2][dtype]+list_results[3][dtype])/float(list_results[0][dtype])*100 - else: - percent_num_error=0 - percent_error=0 - summary+=name+"\t"+str(list_results[0][dtype])+"\t\t"+str(list_results[1][dtype])+"\t("+"%.3f" % percent_num_error+"%)\t"+str(list_results[2][dtype]+list_results[3][dtype])+"\t("+"%.3f" % percent_error+"%)\t""\n" - list_results[0][4]+=list_results[0][dtype] - list_results[1][4]+=list_results[1][dtype] - list_results[2][4]+=list_results[2][dtype] - list_results[3][4]+=list_results[3][dtype] - + + sys.stdout.flush() + if (list_results[0][dtype] > 0 ): + percent_num_error=float(list_results[1][dtype])/float(list_results[0][dtype])*100 + percent_error=float(list_results[2][dtype]+list_results[3][dtype])/float(list_results[0][dtype])*100 + else: + percent_num_error=0 + percent_error=0 + summary+=name+"\t"+str(list_results[0][dtype])+"\t\t"+str(list_results[1][dtype])+"\t("+"%.3f" % percent_num_error+"%)\t"+str(list_results[2][dtype]+list_results[3][dtype])+"\t("+"%.3f" % percent_error+"%)\t""\n" + list_results[0][4]+=list_results[0][dtype] + list_results[1][4]+=list_results[1][dtype] + list_results[2][4]+=list_results[2][dtype] + list_results[3][4]+=list_results[3][dtype] + if only_numbers==1: - print str(list_results[1][4])+"\n"+str(list_results[2][4]+list_results[3][4]) + print(str(list_results[1][4])+"\n"+str(list_results[2][4]+list_results[3][4])) else: - print summary - if (list_results[0][4] > 0 ): - percent_num_error=float(list_results[1][4])/float(list_results[0][4])*100 - percent_error=float(list_results[2][4]+list_results[3][4])/float(list_results[0][4])*100 - else: - percent_num_error=0 - percent_error=0 - if (prec=='x'): - print "--> ALL PRECISIONS\t"+str(list_results[0][4])+"\t\t"+str(list_results[1][4])+"\t("+"%.3f" % percent_num_error+"%)\t"+str(list_results[2][4]+list_results[3][4])+"\t("+"%.3f" % percent_error+"%)\t""\n" - if list_results[0][4] == 0: - print "NO TESTS WERE ANALYZED, please use the -r option to run the LAPACK TESTING" + print(summary) + if (list_results[0][4] > 0 ): + percent_num_error=float(list_results[1][4])/float(list_results[0][4])*100 + percent_error=float(list_results[2][4]+list_results[3][4])/float(list_results[0][4])*100 + else: + percent_num_error=0 + percent_error=0 + if (prec=='x'): + print("--> ALL PRECISIONS\t"+str(list_results[0][4])+"\t\t"+str(list_results[1][4])+"\t("+"%.3f" % percent_num_error+"%)\t"+str(list_results[2][4]+list_results[3][4])+"\t("+"%.3f" % percent_error+"%)\t""\n") + if list_results[0][4] == 0: + print("NO TESTS WERE ANALYZED, please use the -r option to run the LAPACK TESTING") # This may close the sys.stdout stream, so make it the last statement f.close() diff --git a/lapack-netlib/make.inc.example b/lapack-netlib/make.inc.example index 504a164217..7f66018e83 100644 --- a/lapack-netlib/make.inc.example +++ b/lapack-netlib/make.inc.example @@ -1,22 +1,22 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.6.0 # -# November 2015 # +# LAPACK, Version 3.7.0 # +# December 2016 # #################################################################### # SHELL = /bin/sh -# +# # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and +# selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # # Note: During a regular execution, LAPACK might create NaN and Inf -# and handle these quantities appropriately. As a consequence, one +# and handle these quantities appropriately. As a consequence, one # should not compile LAPACK with flags such as -ffpe-trap=overflow. # -FORTRAN = gfortran +FORTRAN = gfortran OPTS = -O2 -frecursive DRVOPTS = $(OPTS) NOOPT = -O0 -frecursive @@ -26,7 +26,7 @@ LOADOPTS = # Comment out the following line to include deprecated routines to the # LAPACK library. # -#MAKEDEPRECATED = Yes +#BUILD_DEPRECATED = Yes # # Timer for the SECOND and DSECND routines # @@ -70,7 +70,7 @@ RANLIB = ranlib XBLASLIB = # XBLASLIB = -lxblas # -# The location of the libraries to which you will link. (The +# The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # diff --git a/lapack/getrf/getrf_parallel.c b/lapack/getrf/getrf_parallel.c index 8fdf76987e..db8c836e0a 100644 --- a/lapack/getrf/getrf_parallel.c +++ b/lapack/getrf/getrf_parallel.c @@ -239,7 +239,7 @@ static int inner_advanced_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG * for (i = 1; i < DIVIDE_RATE; i++) { - buffer[i] = buffer[i - 1] + GEMM_Q * ((div_n + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1)) * COMPSIZE; + buffer[i] = buffer[i - 1] + GEMM_Q * (((div_n + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N) * COMPSIZE; } for (xxx = n_from, bufferside = 0; xxx < n_to; xxx += div_n, bufferside ++) { @@ -284,6 +284,7 @@ static int inner_advanced_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG * } } + MB; for (i = 0; i < args -> nthreads; i++) job[mypos].working[i][CACHE_LINE_SIZE * bufferside] = (BLASLONG)buffer[bufferside]; @@ -303,7 +304,7 @@ static int inner_advanced_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG * min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = ((min_i + 1) / 2 + GEMM_UNROLL_M - 1) & ~(GEMM_UNROLL_M - 1); + min_i = (((min_i + 1) / 2 + GEMM_UNROLL_M - 1)/GEMM_UNROLL_M) * GEMM_UNROLL_M; } ICOPY_OPERATION(k, min_i, a, lda, 0, is, sa); @@ -324,6 +325,7 @@ static int inner_advanced_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG * sa, (FLOAT *)job[current].working[mypos][CACHE_LINE_SIZE * bufferside], c, lda, is, xxx); + MB; if (is + min_i >= m) { job[current].working[mypos][CACHE_LINE_SIZE * bufferside] = 0; } @@ -420,7 +422,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, mn = MIN(m, n); - init_bk = (mn / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + init_bk = ((mn / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (init_bk > GEMM_Q) init_bk = GEMM_Q; if (init_bk <= GEMM_UNROLL_N) { @@ -459,11 +461,11 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, while (is < mn) { - width = (FORMULA1(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + width = ((FORMULA1(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (width > mn - is - bk) width = mn - is - bk; if (width < bk) { - next_bk = (FORMULA2(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N) & ~(GEMM_UNROLL_N - 1); + next_bk = ((FORMULA2(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (next_bk > bk) next_bk = bk; @@ -594,11 +596,11 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, bk = mn - is; if (bk > next_bk) bk = next_bk; - width = (FORMULA1(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + width = ((FORMULA1(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (width > mn - is - bk) width = mn - is - bk; if (width < bk) { - next_bk = (FORMULA2(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N) & ~(GEMM_UNROLL_N - 1); + next_bk = ((FORMULA2(m, n, is, bk, args -> nthreads) + GEMM_UNROLL_N)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (next_bk > bk) next_bk = bk; } @@ -676,7 +678,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, mn = MIN(m, n); - init_bk = (mn / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + init_bk = ((mn / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (init_bk > GEMM_Q) init_bk = GEMM_Q; if (init_bk <= GEMM_UNROLL_N) { @@ -685,14 +687,14 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, } width = FORMULA1(m, n, 0, init_bk, args -> nthreads); - width = (width + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + width = ((width + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (width > n - init_bk) width = n - init_bk; if (width < init_bk) { BLASLONG temp; temp = FORMULA2(m, n, 0, init_bk, args -> nthreads); - temp = (temp + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + temp = ((temp + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (temp < GEMM_UNROLL_N) temp = GEMM_UNROLL_N; if (temp < init_bk) init_bk = temp; @@ -717,12 +719,12 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, while (is < mn) { width = FORMULA1(m, n, is, bk, args -> nthreads); - width = (width + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + width = ((width + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (width < bk) { next_bk = FORMULA2(m, n, is, bk, args -> nthreads); - next_bk = (next_bk + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + next_bk = ((next_bk + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (next_bk > bk) next_bk = bk; #if 0 @@ -852,11 +854,11 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, if (bk > next_bk) bk = next_bk; width = FORMULA1(m, n, is, bk, args -> nthreads); - width = (width + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + width = ((width + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (width < bk) { next_bk = FORMULA2(m, n, is, bk, args -> nthreads); - next_bk = (next_bk + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + next_bk = ((next_bk + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (next_bk > bk) next_bk = bk; #if 0 diff --git a/lapack/getrf/getrf_parallel_omp.c b/lapack/getrf/getrf_parallel_omp.c index 6b8cbda2f5..79d6f51982 100644 --- a/lapack/getrf/getrf_parallel_omp.c +++ b/lapack/getrf/getrf_parallel_omp.c @@ -170,7 +170,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, mn = MIN(m, n); - blocking = (mn / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((mn / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; #ifdef POWER8 diff --git a/lapack/getrf/getrf_single.c b/lapack/getrf/getrf_single.c index 9f0f36b78b..581feeb2ea 100644 --- a/lapack/getrf/getrf_single.c +++ b/lapack/getrf/getrf_single.c @@ -74,7 +74,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, mn = MIN(m, n); - blocking = (mn / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((mn / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; #ifdef POWER8 diff --git a/lapack/laswp/zarch/Makefile b/lapack/laswp/zarch/Makefile new file mode 100644 index 0000000000..af1f0199c0 --- /dev/null +++ b/lapack/laswp/zarch/Makefile @@ -0,0 +1,8 @@ +TOPDIR = ../../.. +include ../../../Makefile.system + +LASWP = ../generic/laswp_k_1.c +ZLASWP = ../generic/zlaswp_k_1.c + +include ../generic/Makefile + diff --git a/lapack/lauum/lauum_L_parallel.c b/lapack/lauum/lauum_L_parallel.c index c93c4a8610..0ebe3f0693 100644 --- a/lapack/lauum/lauum_L_parallel.c +++ b/lapack/lauum/lauum_L_parallel.c @@ -88,7 +88,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, newarg.beta = NULL; newarg.nthreads = args -> nthreads; - blocking = (n / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((n / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; for (i = 0; i < n; i += blocking) { diff --git a/lapack/lauum/lauum_U_parallel.c b/lapack/lauum/lauum_U_parallel.c index e4a2792b22..7214c97313 100644 --- a/lapack/lauum/lauum_U_parallel.c +++ b/lapack/lauum/lauum_U_parallel.c @@ -88,7 +88,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, newarg.beta = NULL; newarg.nthreads = args -> nthreads; - blocking = (n / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((n / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; for (i = 0; i < n; i += blocking) { diff --git a/lapack/potrf/potrf_L_parallel.c b/lapack/potrf/potrf_L_parallel.c index 52a383a15c..68ec8e22a2 100644 --- a/lapack/potrf/potrf_L_parallel.c +++ b/lapack/potrf/potrf_L_parallel.c @@ -89,7 +89,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, newarg.beta = NULL; newarg.nthreads = args -> nthreads; - blocking = (n / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((n / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; for (i = 0; i < n; i += blocking) { diff --git a/lapack/potrf/potrf_U_parallel.c b/lapack/potrf/potrf_U_parallel.c index d9b7a88182..3b5d395118 100644 --- a/lapack/potrf/potrf_U_parallel.c +++ b/lapack/potrf/potrf_U_parallel.c @@ -89,7 +89,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, newarg.beta = NULL; newarg.nthreads = args -> nthreads; - blocking = (n / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((n / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; for (i = 0; i < n; i += blocking) { diff --git a/lapack/potrf/potrf_U_single.c b/lapack/potrf/potrf_U_single.c index 7bdeb494d4..932e481147 100644 --- a/lapack/potrf/potrf_U_single.c +++ b/lapack/potrf/potrf_U_single.c @@ -163,7 +163,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = (min_i / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = ((min_i / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } #ifdef SHARED_ARRAY diff --git a/lapack/potrf/potrf_parallel.c b/lapack/potrf/potrf_parallel.c index c3a7ced2cf..e61e8decbf 100644 --- a/lapack/potrf/potrf_parallel.c +++ b/lapack/potrf/potrf_parallel.c @@ -183,7 +183,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, fprintf(stderr, "Thread[%ld] m_from : %ld m_to : %ld\n", mypos, m_from, m_to); #endif - div_n = ((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((m_to - m_from + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; buffer[0] = (FLOAT *)((((BLASULONG)(sb + k * k * COMPSIZE) + GEMM_ALIGN) & ~GEMM_ALIGN) + GEMM_OFFSET_B); for (i = 1; i < DIVIDE_RATE; i++) { @@ -248,7 +248,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = ((min_i + 1) / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = (((min_i + 1) / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } #ifndef LOWER @@ -265,7 +265,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, while (current >= 0) #endif { - div_n = ((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; for (xxx = range_n[current], bufferside = 0; xxx < range_n[current + 1]; xxx += div_n, bufferside ++) { @@ -296,7 +296,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, min_i = GEMM_P; } else if (min_i > GEMM_P) { - min_i = ((min_i + 1) / 2 + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + min_i = (((min_i + 1) / 2 + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; } #ifndef LOWER @@ -313,7 +313,7 @@ static int inner_thread(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, while (current >= 0) #endif { - div_n = ((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1) & ~(GEMM_UNROLL_MN - 1); + div_n = (((range_n[current + 1] - range_n[current] + DIVIDE_RATE - 1) / DIVIDE_RATE + GEMM_UNROLL_MN - 1)/GEMM_UNROLL_MN) * GEMM_UNROLL_MN; for (xxx = range_n[current], bufferside = 0; xxx < range_n[current + 1]; xxx += div_n, bufferside ++) { @@ -429,9 +429,9 @@ static int thread_driver(blas_arg_t *args, FLOAT *sa, FLOAT *sb){ double di = (double)i; - width = (((BLASLONG)(sqrt(di * di + dnum) - di) + mask) & ~mask); + width = ((((BLASLONG)(sqrt(di * di + dnum) - di) + mask)/(mask+1)) * (mask+1)); - if (num_cpu == 0) width = n - ((n - width) & ~mask); + if (num_cpu == 0) width = n - (((n - width)/(mask+1)) * (mask+1)); if ((width > n - i) || (width < mask)) width = n - i; @@ -471,7 +471,7 @@ static int thread_driver(blas_arg_t *args, FLOAT *sa, FLOAT *sb){ double di = (double)i; - width = (((BLASLONG)(sqrt(di * di + dnum) - di) + mask) & ~mask); + width = ((((BLASLONG)(sqrt(di * di + dnum) - di) + mask)/(mask+1)) * (mask+1)); if ((width > n - i) || (width < mask)) width = n - i; @@ -582,7 +582,7 @@ blasint CNAME(blas_arg_t *args, BLASLONG *range_m, BLASLONG *range_n, FLOAT *sa, newarg.beta = NULL; newarg.nthreads = args -> nthreads; - blocking = (n / 2 + GEMM_UNROLL_N - 1) & ~(GEMM_UNROLL_N - 1); + blocking = ((n / 2 + GEMM_UNROLL_N - 1)/GEMM_UNROLL_N) * GEMM_UNROLL_N; if (blocking > GEMM_Q) blocking = GEMM_Q; for (i = 0; i < n; i += blocking) { diff --git a/openblas.pc.in b/openblas.pc.in new file mode 100644 index 0000000000..ff849807c5 --- /dev/null +++ b/openblas.pc.in @@ -0,0 +1,7 @@ +Name: openblas +Description: OpenBLAS is an optimized BLAS library based on GotoBLAS2 1.13 BSD version +Version: ${version} +URL: https://github.com/xianyi/OpenBLAS +Libs: -L${libdir} -lopenblas +Libs.private: ${extralib} +Cflags: -I${includedir} diff --git a/param.h b/param.h index 480518cd4b..2d5bccee78 100644 --- a/param.h +++ b/param.h @@ -595,6 +595,123 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #endif +#ifdef ZEN +#define SNUMOPT 16 +#define DNUMOPT 8 + +#define GEMM_DEFAULT_OFFSET_A 0 +#define GEMM_DEFAULT_OFFSET_B 0 +#define GEMM_DEFAULT_ALIGN 0x03fffUL + +#define SYMV_P 8 + +#define SWITCH_RATIO 4 + +#ifdef ARCH_X86 + +#define SGEMM_DEFAULT_UNROLL_M 4 +#define DGEMM_DEFAULT_UNROLL_M 2 +#define QGEMM_DEFAULT_UNROLL_M 2 +#define CGEMM_DEFAULT_UNROLL_M 2 +#define ZGEMM_DEFAULT_UNROLL_M 1 +#define XGEMM_DEFAULT_UNROLL_M 1 + +#define SGEMM_DEFAULT_UNROLL_N 4 +#define DGEMM_DEFAULT_UNROLL_N 4 +#define QGEMM_DEFAULT_UNROLL_N 2 +#define CGEMM_DEFAULT_UNROLL_N 2 +#define ZGEMM_DEFAULT_UNROLL_N 2 +#define XGEMM_DEFAULT_UNROLL_N 1 + +#else + +#define SGEMM_DEFAULT_UNROLL_M 16 +#define DGEMM_DEFAULT_UNROLL_M 4 +#define QGEMM_DEFAULT_UNROLL_M 2 +#define CGEMM_DEFAULT_UNROLL_M 8 +#define ZGEMM_DEFAULT_UNROLL_M 4 +#define XGEMM_DEFAULT_UNROLL_M 1 + +#define SGEMM_DEFAULT_UNROLL_N 4 +#define DGEMM_DEFAULT_UNROLL_N 8 +#define QGEMM_DEFAULT_UNROLL_N 2 +#define CGEMM_DEFAULT_UNROLL_N 2 +#define ZGEMM_DEFAULT_UNROLL_N 2 +#define XGEMM_DEFAULT_UNROLL_N 1 + +#define SGEMM_DEFAULT_UNROLL_MN 32 +#define DGEMM_DEFAULT_UNROLL_MN 32 +#endif + +#ifdef ARCH_X86 + +#define SGEMM_DEFAULT_P 512 +#define SGEMM_DEFAULT_R sgemm_r +#define DGEMM_DEFAULT_P 512 +#define DGEMM_DEFAULT_R dgemm_r +#define QGEMM_DEFAULT_P 504 +#define QGEMM_DEFAULT_R qgemm_r +#define CGEMM_DEFAULT_P 128 +#define CGEMM_DEFAULT_R 1024 +#define ZGEMM_DEFAULT_P 512 +#define ZGEMM_DEFAULT_R zgemm_r +#define XGEMM_DEFAULT_P 252 +#define XGEMM_DEFAULT_R xgemm_r +#define SGEMM_DEFAULT_Q 256 +#define DGEMM_DEFAULT_Q 256 +#define QGEMM_DEFAULT_Q 128 +#define CGEMM_DEFAULT_Q 256 +#define ZGEMM_DEFAULT_Q 192 +#define XGEMM_DEFAULT_Q 128 + +#else + +#define SGEMM_DEFAULT_P 768 +#define DGEMM_DEFAULT_P 512 +#define CGEMM_DEFAULT_P 384 +#define ZGEMM_DEFAULT_P 256 + +#ifdef WINDOWS_ABI +#define SGEMM_DEFAULT_Q 320 +#define DGEMM_DEFAULT_Q 128 +#else +#define SGEMM_DEFAULT_Q 384 +#define DGEMM_DEFAULT_Q 256 +#endif +#define CGEMM_DEFAULT_Q 192 +#define ZGEMM_DEFAULT_Q 128 + +#define SGEMM_DEFAULT_R sgemm_r +#define DGEMM_DEFAULT_R 13824 +#define CGEMM_DEFAULT_R cgemm_r +#define ZGEMM_DEFAULT_R zgemm_r + +#define QGEMM_DEFAULT_Q 128 +#define QGEMM_DEFAULT_P 504 +#define QGEMM_DEFAULT_R qgemm_r +#define XGEMM_DEFAULT_P 252 +#define XGEMM_DEFAULT_R xgemm_r +#define XGEMM_DEFAULT_Q 128 + +#define CGEMM3M_DEFAULT_UNROLL_N 8 +#define CGEMM3M_DEFAULT_UNROLL_M 4 +#define ZGEMM3M_DEFAULT_UNROLL_N 8 +#define ZGEMM3M_DEFAULT_UNROLL_M 2 + +#define CGEMM3M_DEFAULT_P 448 +#define ZGEMM3M_DEFAULT_P 224 +#define XGEMM3M_DEFAULT_P 112 +#define CGEMM3M_DEFAULT_Q 224 +#define ZGEMM3M_DEFAULT_Q 224 +#define XGEMM3M_DEFAULT_Q 224 +#define CGEMM3M_DEFAULT_R 12288 +#define ZGEMM3M_DEFAULT_R 12288 +#define XGEMM3M_DEFAULT_R 12288 + +#endif + +#endif + #ifdef ATHLON #define SNUMOPT 4 @@ -2385,6 +2502,82 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define SYMV_P 16 #endif +#if defined(THUNDERX) +#define SNUMOPT 2 +#define DNUMOPT 2 + +#define GEMM_DEFAULT_OFFSET_A 0 +#define GEMM_DEFAULT_OFFSET_B 0 +#define GEMM_DEFAULT_ALIGN 0x03fffUL + +#define SGEMM_DEFAULT_UNROLL_M 4 +#define SGEMM_DEFAULT_UNROLL_N 4 + +#define DGEMM_DEFAULT_UNROLL_M 2 +#define DGEMM_DEFAULT_UNROLL_N 2 + +#define CGEMM_DEFAULT_UNROLL_M 2 +#define CGEMM_DEFAULT_UNROLL_N 2 + +#define ZGEMM_DEFAULT_UNROLL_M 2 +#define ZGEMM_DEFAULT_UNROLL_N 2 + +#define SGEMM_DEFAULT_P 128 +#define DGEMM_DEFAULT_P 128 +#define CGEMM_DEFAULT_P 96 +#define ZGEMM_DEFAULT_P 64 + +#define SGEMM_DEFAULT_Q 240 +#define DGEMM_DEFAULT_Q 120 +#define CGEMM_DEFAULT_Q 120 +#define ZGEMM_DEFAULT_Q 120 + +#define SGEMM_DEFAULT_R 12288 +#define DGEMM_DEFAULT_R 8192 +#define CGEMM_DEFAULT_R 4096 +#define ZGEMM_DEFAULT_R 4096 + + +#define SYMV_P 16 +#endif + +#if defined(THUNDERX2T99) || defined(VULCAN) +#define SNUMOPT 2 +#define DNUMOPT 2 + +#define GEMM_DEFAULT_OFFSET_A 0 +#define GEMM_DEFAULT_OFFSET_B 0 +#define GEMM_DEFAULT_ALIGN 0x03fffUL + +#define SGEMM_DEFAULT_UNROLL_M 16 +#define SGEMM_DEFAULT_UNROLL_N 4 + +#define DGEMM_DEFAULT_UNROLL_M 8 +#define DGEMM_DEFAULT_UNROLL_N 4 + +#define CGEMM_DEFAULT_UNROLL_M 8 +#define CGEMM_DEFAULT_UNROLL_N 4 + +#define ZGEMM_DEFAULT_UNROLL_M 4 +#define ZGEMM_DEFAULT_UNROLL_N 4 + +#define SGEMM_DEFAULT_P sgemm_p +#define DGEMM_DEFAULT_P dgemm_p +#define CGEMM_DEFAULT_P cgemm_p +#define ZGEMM_DEFAULT_P zgemm_p + +#define SGEMM_DEFAULT_Q sgemm_q +#define DGEMM_DEFAULT_Q dgemm_q +#define CGEMM_DEFAULT_Q cgemm_q +#define ZGEMM_DEFAULT_Q zgemm_q + +#define SGEMM_DEFAULT_R sgemm_r +#define DGEMM_DEFAULT_R dgemm_r +#define CGEMM_DEFAULT_R cgemm_r +#define ZGEMM_DEFAULT_R zgemm_r + +#define SYMV_P 16 +#endif #if defined(ARMV5) #define SNUMOPT 2 @@ -2505,6 +2698,85 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +#define SYMV_P 16 +#endif + + +#if defined(ZARCH_GENERIC) +#define SNUMOPT 2 +#define DNUMOPT 2 + +#define GEMM_DEFAULT_OFFSET_A 0 +#define GEMM_DEFAULT_OFFSET_B 0 +#define GEMM_DEFAULT_ALIGN 0x03fffUL + +#define SGEMM_DEFAULT_UNROLL_M 2 +#define SGEMM_DEFAULT_UNROLL_N 2 + +#define DGEMM_DEFAULT_UNROLL_M 2 +#define DGEMM_DEFAULT_UNROLL_N 2 + +#define CGEMM_DEFAULT_UNROLL_M 2 +#define CGEMM_DEFAULT_UNROLL_N 2 + +#define ZGEMM_DEFAULT_UNROLL_M 2 +#define ZGEMM_DEFAULT_UNROLL_N 2 + +#define SGEMM_DEFAULT_P 128 +#define DGEMM_DEFAULT_P 128 +#define CGEMM_DEFAULT_P 96 +#define ZGEMM_DEFAULT_P 64 + +#define SGEMM_DEFAULT_Q 240 +#define DGEMM_DEFAULT_Q 120 +#define CGEMM_DEFAULT_Q 120 +#define ZGEMM_DEFAULT_Q 120 + +#define SGEMM_DEFAULT_R 12288 +#define DGEMM_DEFAULT_R 8192 +#define CGEMM_DEFAULT_R 4096 +#define ZGEMM_DEFAULT_R 4096 + + +#define SYMV_P 16 +#endif + +#if defined(Z13) +#define SNUMOPT 2 +#define DNUMOPT 2 + +#define GEMM_DEFAULT_OFFSET_A 0 +#define GEMM_DEFAULT_OFFSET_B 0 +#define GEMM_DEFAULT_ALIGN 0x03fffUL + +#define SGEMM_DEFAULT_UNROLL_M 8 +#define SGEMM_DEFAULT_UNROLL_N 4 + +#define DGEMM_DEFAULT_UNROLL_M 8 +#define DGEMM_DEFAULT_UNROLL_N 4 + +#define CGEMM_DEFAULT_UNROLL_M 4 +#define CGEMM_DEFAULT_UNROLL_N 4 + +#define ZGEMM_DEFAULT_UNROLL_M 4 +#define ZGEMM_DEFAULT_UNROLL_N 4 + +#define SGEMM_DEFAULT_P 456 +#define DGEMM_DEFAULT_P 320 +#define CGEMM_DEFAULT_P 480 +#define ZGEMM_DEFAULT_P 224 + +#define SGEMM_DEFAULT_Q 488 +#define DGEMM_DEFAULT_Q 384 +#define CGEMM_DEFAULT_Q 128 +#define ZGEMM_DEFAULT_Q 352 + +#define SGEMM_DEFAULT_R 8192 +#define DGEMM_DEFAULT_R 4096 +#define CGEMM_DEFAULT_R 4096 +#define ZGEMM_DEFAULT_R 2048 + + #define SYMV_P 16 #endif diff --git a/relapack/LICENSE b/relapack/LICENSE new file mode 100644 index 0000000000..edeb4046e1 --- /dev/null +++ b/relapack/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2016 Elmar Peise + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/relapack/Makefile b/relapack/Makefile new file mode 100644 index 0000000000..ddf101bd15 --- /dev/null +++ b/relapack/Makefile @@ -0,0 +1,98 @@ +TOPDIR = .. +include $(TOPDIR)/Makefile.system + + + +SRC = $(wildcard src/*.c) + +SRC1 = \ + src/slauum.c src/clauum.c src/dlauum.c src/zlauum.c \ + src/strtri.c src/dtrtri.c src/ctrtri.c src/ztrtri.c \ + src/spotrf.c src/dpotrf.c src/cpotrf.c src/zpotrf.c \ + src/sgetrf.c src/dgetrf.c src/cgetrf.c src/zgetrf.c + +SRC2 = \ + src/cgbtrf.c src/cpbtrf.c src/dsytrf_rec2.c src/sgbtrf.c src/ssytrf_rook.c src/zhegst.c src/zsytrf_rec2.c \ + src/cgemmt.c src/dgbtrf.c src/dsytrf_rook.c src/sgemmt.c src/ssytrf_rook_rec2.c src/zhetrf.c src/zsytrf_rook.c \ + src/csytrf.c src/dgemmt.c src/dsytrf_rook_rec2.c src/stgsyl.c src/zhetrf_rec2.c src/zsytrf_rook_rec2.c \ + src/chegst.c src/csytrf_rec2.c src/dtgsyl.c src/strsyl.c src/zhetrf_rook.c src/ztgsyl.c \ + src/chetrf.c src/csytrf_rook.c src/dtrsyl.c src/spbtrf.c src/strsyl_rec2.c src/zhetrf_rook_rec2.c src/ztrsyl.c \ + src/chetrf_rec2.c src/csytrf_rook_rec2.c src/dpbtrf.c src/dtrsyl_rec2.c src/ztrsyl_rec2.c \ + src/chetrf_rook.c src/ctgsyl.c src/ssygst.c src/zgbtrf.c src/zpbtrf.c \ + src/chetrf_rook_rec2.c src/ctrsyl.c src/dsygst.c src/f2c.c src/ssytrf.c src/zgemmt.c \ + src/ctrsyl_rec2.c src/dsytrf.c src/lapack_wrappers.c src/ssytrf_rec2.c src/zsytrf.c + +SRCX = \ + src/cgbtrf.c src/cpbtrf.c src/ctrtri.c src/dsytrf_rec2.c src/sgbtrf.c src/ssytrf_rook.c src/zhegst.c src/zsytrf_rec2.c \ + src/cgemmt.c src/cpotrf.c src/dgbtrf.c src/dsytrf_rook.c src/sgemmt.c src/ssytrf_rook_rec2.c src/zhetrf.c src/zsytrf_rook.c \ + src/cgetrf.c src/csytrf.c src/dgemmt.c src/dsytrf_rook_rec2.c src/sgetrf.c src/stgsyl.c src/zhetrf_rec2.c src/zsytrf_rook_rec2.c \ + src/chegst.c src/csytrf_rec2.c src/dgetrf.c src/dtgsyl.c src/slauum.c src/strsyl.c src/zhetrf_rook.c src/ztgsyl.c \ + src/chetrf.c src/csytrf_rook.c src/dlauum.c src/dtrsyl.c src/spbtrf.c src/strsyl_rec2.c src/zhetrf_rook_rec2.c src/ztrsyl.c \ + src/chetrf_rec2.c src/csytrf_rook_rec2.c src/dpbtrf.c src/dtrsyl_rec2.c src/spotrf.c src/strtri.c src/zlauum.c src/ztrsyl_rec2.c \ + src/chetrf_rook.c src/ctgsyl.c src/dpotrf.c src/dtrtri.c src/ssygst.c src/zgbtrf.c src/zpbtrf.c src/ztrtri.c \ + src/chetrf_rook_rec2.c src/ctrsyl.c src/dsygst.c src/f2c.c src/ssytrf.c src/zgemmt.c src/zpotrf.c \ + src/clauum.c src/ctrsyl_rec2.c src/dsytrf.c src/lapack_wrappers.c src/ssytrf_rec2.c src/zgetrf.c src/zsytrf.c + +OBJS1 = $(SRC1:%.c=%.$(SUFFIX)) +OBJS2 = $(SRC2:%.c=%.o) +OBJS = $(OBJS1) $(OBJS2) + +TEST_SUITS = \ + slauum dlauum clauum zlauum \ + spotrf dpotrf cpotrf zpotrf \ + spbtrf dpbtrf cpbtrf zpbtrf \ + ssygst dsygst chegst zhegst \ + ssytrf dsytrf csytrf chetrf zsytrf zhetrf \ + sgetrf dgetrf cgetrf zgetrf \ + sgbtrf dgbtrf cgbtrf zgbtrf \ + strsyl dtrsyl ctrsyl ztrsyl \ + stgsyl dtgsyl ctgsyl ztgsyl \ + sgemmt dgemmt cgemmt zgemmt +TESTS = $(TEST_SUITS:%=test/%.pass) # dummies +TEST_EXES = $(TEST_SUITS:%=test/%.x) + +LINK_TEST = -L$(TOPDIR) -lopenblas -lgfortran -lm + +.SECONDARY: $(TEST_EXES) +.PHONY: test + +# ReLAPACK compilation + +libs: $(OBJS) + @echo "Building ReLAPACK library $(LIBNAME)" + $(AR) -r $(TOPDIR)/$(LIBNAME) $(OBJS) + $(RANLIB) $(TOPDIR)/$(LIBNAME) + +%.$(SUFFIX): %.c config.h + $(CC) $(CFLAGS) -c $< -o $@ + +%.o: %.c config.h + $(CC) $(CFLAGS) -c $< -o $@ + + +# ReLAPACK testing + +test: $(TEST_EXES) $(TESTS) + @echo "passed all tests" + +test/%.pass: test/%.x + @echo -n $*: + @./$< > /dev/null && echo " pass" || (echo " FAIL" && ./$<) + +test/s%.x: test/x%.c test/util.$(SUFFIX) $(TOPDIR)/$(LIBNAME) test/config.h test/test.h + $(CC) $(CFLAGS) -DDT_PREFIX=s $< test/util.$(SUFFIX) -o $@ $(LINK_TEST) $(TOPDIR)/$(LIBNAME) $(LINK_TEST) + +test/d%.x: test/x%.c test/util.$(SUFFIX) $(TOPDIR)/$(LIBNAME) test/config.h test/test.h + $(CC) $(CFLAGS) -DDT_PREFIX=d $< test/util.$(SUFFIX) -o $@ $(LINK_TEST) $(TOPDIR)/$(LIBNAME) $(LINK_TEST) + +test/c%.x: test/x%.c test/util.$(SUFFIX) $(TOPDIR)/$(LIBNAME) test/config.h test/test.h + $(CC) $(CFLAGS) -DDT_PREFIX=c $< test/util.$(SUFFIX) -o $@ $(LINK_TEST) $(TOPDIR)/$(LIBNAME) $(LINK_TEST) + +test/z%.x: test/x%.c test/util.$(SUFFIX) $(TOPDIR)/$(LIBNAME) test/config.h test/test.h + $(CC) $(CFLAGS) -DDT_PREFIX=z $< test/util.$(SUFFIX) -o $@ $(LINK_TEST) $(TOPDIR)/$(LIBNAME) $(LINK_TEST) + + +# cleaning up + +clean: + rm -f $(OBJS) test/util.$(SUFFIX) test/*.x diff --git a/relapack/README.md b/relapack/README.md new file mode 100644 index 0000000000..1947c17486 --- /dev/null +++ b/relapack/README.md @@ -0,0 +1,68 @@ +ReLAPACK +======== + +[![Build Status](https://travis-ci.org/HPAC/ReLAPACK.svg?branch=master)](https://travis-ci.org/HPAC/ReLAPACK) + +[Recursive LAPACK Collection](https://github.com/HPAC/ReLAPACK) + +ReLAPACK offers a collection of recursive algorithms for many of LAPACK's +compute kernels. Since it preserves LAPACK's established interfaces, ReLAPACK +integrates effortlessly into existing application codes. ReLAPACK's routines +not only outperform the reference LAPACK but also improve upon the performance +of tuned implementations, such as OpenBLAS and MKL. + + +Coverage +-------- +For a detailed list of covered operations and an overview of operations to which +recursion is not efficiently applicable, see [coverage.md](coverage.md). + + +Installation +------------ +To compile with the default configuration, simply run `make` to create the +library `librelapack.a`. + +### Linking with MKL +Note that to link with MKL, you currently need to set the flag +`COMPLEX_FUNCTIONS_AS_ROUTINES` to `1` to avoid problems in `ctrsyl` and +`ztrsyl`. For further configuration options see [config.md](config.md). + + +### Dependencies +ReLAPACK builds on top of [BLAS](http://www.netlib.org/blas/) and unblocked +kernels from [LAPACK](http://www.netlib.org/lapack/). There are many optimized +and machine specific implementations of these libraries, which are commonly +provided by hardware vendors or available as open source (e.g., +[OpenBLAS](http://www.openblas.net/)). + + +Testing +------- +ReLAPACK's test suite compares its routines numerically with LAPACK's +counterparts. To set up the tests (located int `test/`) you need to specify +link flags for BLAS and LAPACK (version 3.5.0 or newer) in `make.inc`; then +`make test` runs the tests. For details on the performed tests, see +[test/README.md](test/README.md). + + +Examples +-------- +Since ReLAPACK replaces parts of LAPACK, any LAPACK example involving the +covered routines applies directly to ReLAPACK. A few separate examples are +given in `examples/`. For details, see [examples/README.md](examples/README.md). + + +Citing +------ +When referencing ReLAPACK, please cite the preprint of the paper +[Recursive Algorithms for Dense Linear Algebra: The ReLAPACK Collection](http://arxiv.org/abs/1602.06763): + + @article{relapack, + author = {Elmar Peise and Paolo Bientinesi}, + title = {Recursive Algorithms for Dense Linear Algebra: The ReLAPACK Collection}, + journal = {CoRR}, + volume = {abs/1602.06763}, + year = {2016}, + url = {http://arxiv.org/abs/1602.06763}, + } diff --git a/relapack/config.h b/relapack/config.h new file mode 100644 index 0000000000..9113a712da --- /dev/null +++ b/relapack/config.h @@ -0,0 +1,208 @@ +#ifndef RELAPACK_CONFIG_H +#define RELAPACK_CONFIG_H + +// ReLAPACK configuration file. +// See also config.md + + +/////////////////////////////// +// BLAS/LAPACK obect symbols // +/////////////////////////////// + +// BLAS routines linked against have a trailing underscore +#define BLAS_UNDERSCORE 1 +// LAPACK routines linked against have a trailing underscore +#define LAPACK_UNDERSCORE BLAS_UNDERSCORE + +// Complex BLAS/LAPACK routines return their result in the first argument +// This option must be enabled when linking to MKL for ctrsyl and ztrsyl to +// work. +#define COMPLEX_FUNCTIONS_AS_ROUTINES 0 +#ifdef F_INTERFACE_INTEL +#define COMPLEX_FUNCTIONS_AS_ROUTINES 1 +#endif +#define BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES COMPLEX_FUNCTIONS_AS_ROUTINES +#define LAPACK_BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES COMPLEX_FUNCTIONS_AS_ROUTINES + +// The BLAS-like extension xgemmt is provided by an external library. +#define HAVE_XGEMMT 0 + + +//////////////////////////// +// Use malloc in ReLAPACK // +//////////////////////////// + +#define ALLOW_MALLOC 1 +// allow malloc in xsygst for improved performance +#define XSYGST_ALLOW_MALLOC ALLOW_MALLOC +// allow malloc in xsytrf if the passed work buffer is too small +#define XSYTRF_ALLOW_MALLOC ALLOW_MALLOC + + +//////////////////////////////// +// LAPACK routine replacement // +//////////////////////////////// +// The following macros specify which routines are included in the library under +// LAPACK's symbol names: 1 included, 0 not included + +#define INCLUDE_ALL 1 + +#define INCLUDE_XLAUUM INCLUDE_ALL +#define INCLUDE_SLAUUM INCLUDE_XLAUUM +#define INCLUDE_DLAUUM INCLUDE_XLAUUM +#define INCLUDE_CLAUUM INCLUDE_XLAUUM +#define INCLUDE_ZLAUUM INCLUDE_XLAUUM + +#define INCLUDE_XSYGST INCLUDE_ALL +#define INCLUDE_SSYGST INCLUDE_XSYGST +#define INCLUDE_DSYGST INCLUDE_XSYGST +#define INCLUDE_CHEGST INCLUDE_XSYGST +#define INCLUDE_ZHEGST INCLUDE_XSYGST + +#define INCLUDE_XTRTRI INCLUDE_ALL +#define INCLUDE_STRTRI INCLUDE_XTRTRI +#define INCLUDE_DTRTRI INCLUDE_XTRTRI +#define INCLUDE_CTRTRI INCLUDE_XTRTRI +#define INCLUDE_ZTRTRI INCLUDE_XTRTRI + +#define INCLUDE_XPOTRF INCLUDE_ALL +#define INCLUDE_SPOTRF INCLUDE_XPOTRF +#define INCLUDE_DPOTRF INCLUDE_XPOTRF +#define INCLUDE_CPOTRF INCLUDE_XPOTRF +#define INCLUDE_ZPOTRF INCLUDE_XPOTRF + +#define INCLUDE_XPBTRF INCLUDE_ALL +#define INCLUDE_SPBTRF INCLUDE_XPBTRF +#define INCLUDE_DPBTRF INCLUDE_XPBTRF +#define INCLUDE_CPBTRF INCLUDE_XPBTRF +#define INCLUDE_ZPBTRF INCLUDE_XPBTRF + +#define INCLUDE_XSYTRF INCLUDE_ALL +#define INCLUDE_SSYTRF INCLUDE_XSYTRF +#define INCLUDE_DSYTRF INCLUDE_XSYTRF +#define INCLUDE_CSYTRF INCLUDE_XSYTRF +#define INCLUDE_CHETRF INCLUDE_XSYTRF +#define INCLUDE_ZSYTRF INCLUDE_XSYTRF +#define INCLUDE_ZHETRF INCLUDE_XSYTRF +#define INCLUDE_SSYTRF_ROOK INCLUDE_SSYTRF +#define INCLUDE_DSYTRF_ROOK INCLUDE_DSYTRF +#define INCLUDE_CSYTRF_ROOK INCLUDE_CSYTRF +#define INCLUDE_CHETRF_ROOK INCLUDE_CHETRF +#define INCLUDE_ZSYTRF_ROOK INCLUDE_ZSYTRF +#define INCLUDE_ZHETRF_ROOK INCLUDE_ZHETRF + +#define INCLUDE_XGETRF INCLUDE_ALL +#define INCLUDE_SGETRF INCLUDE_XGETRF +#define INCLUDE_DGETRF INCLUDE_XGETRF +#define INCLUDE_CGETRF INCLUDE_XGETRF +#define INCLUDE_ZGETRF INCLUDE_XGETRF + +#define INCLUDE_XGBTRF INCLUDE_ALL +#define INCLUDE_SGBTRF INCLUDE_XGBTRF +#define INCLUDE_DGBTRF INCLUDE_XGBTRF +#define INCLUDE_CGBTRF INCLUDE_XGBTRF +#define INCLUDE_ZGBTRF INCLUDE_XGBTRF + +#define INCLUDE_XTRSYL INCLUDE_ALL +#define INCLUDE_STRSYL INCLUDE_XTRSYL +#define INCLUDE_DTRSYL INCLUDE_XTRSYL +#define INCLUDE_CTRSYL INCLUDE_XTRSYL +#define INCLUDE_ZTRSYL INCLUDE_XTRSYL + +#define INCLUDE_XTGSYL INCLUDE_ALL +#define INCLUDE_STGSYL INCLUDE_XTGSYL +#define INCLUDE_DTGSYL INCLUDE_XTGSYL +#define INCLUDE_CTGSYL INCLUDE_XTGSYL +#define INCLUDE_ZTGSYL INCLUDE_XTGSYL + +#define INCLUDE_XGEMMT 0 +#define INCLUDE_SGEMMT INCLUDE_XGEMMT +#define INCLUDE_DGEMMT INCLUDE_XGEMMT +#define INCLUDE_CGEMMT INCLUDE_XGEMMT +#define INCLUDE_ZGEMMT INCLUDE_XGEMMT + + +///////////////////// +// crossover sizes // +///////////////////// + +// default crossover size +#define CROSSOVER 24 + +// individual crossover sizes +#define CROSSOVER_XLAUUM CROSSOVER +#define CROSSOVER_SLAUUM CROSSOVER_XLAUUM +#define CROSSOVER_DLAUUM CROSSOVER_XLAUUM +#define CROSSOVER_CLAUUM CROSSOVER_XLAUUM +#define CROSSOVER_ZLAUUM CROSSOVER_XLAUUM + +#define CROSSOVER_XSYGST CROSSOVER +#define CROSSOVER_SSYGST CROSSOVER_XSYGST +#define CROSSOVER_DSYGST CROSSOVER_XSYGST +#define CROSSOVER_CHEGST CROSSOVER_XSYGST +#define CROSSOVER_ZHEGST CROSSOVER_XSYGST + +#define CROSSOVER_XTRTRI CROSSOVER +#define CROSSOVER_STRTRI CROSSOVER_XTRTRI +#define CROSSOVER_DTRTRI CROSSOVER_XTRTRI +#define CROSSOVER_CTRTRI CROSSOVER_XTRTRI +#define CROSSOVER_ZTRTRI CROSSOVER_XTRTRI + +#define CROSSOVER_XPOTRF CROSSOVER +#define CROSSOVER_SPOTRF CROSSOVER_XPOTRF +#define CROSSOVER_DPOTRF CROSSOVER_XPOTRF +#define CROSSOVER_CPOTRF CROSSOVER_XPOTRF +#define CROSSOVER_ZPOTRF CROSSOVER_XPOTRF + +#define CROSSOVER_XPBTRF CROSSOVER +#define CROSSOVER_SPBTRF CROSSOVER_XPBTRF +#define CROSSOVER_DPBTRF CROSSOVER_XPBTRF +#define CROSSOVER_CPBTRF CROSSOVER_XPBTRF +#define CROSSOVER_ZPBTRF CROSSOVER_XPBTRF + +#define CROSSOVER_XSYTRF CROSSOVER +#define CROSSOVER_SSYTRF CROSSOVER_XSYTRF +#define CROSSOVER_DSYTRF CROSSOVER_XSYTRF +#define CROSSOVER_CSYTRF CROSSOVER_XSYTRF +#define CROSSOVER_CHETRF CROSSOVER_XSYTRF +#define CROSSOVER_ZSYTRF CROSSOVER_XSYTRF +#define CROSSOVER_ZHETRF CROSSOVER_XSYTRF +#define CROSSOVER_SSYTRF_ROOK CROSSOVER_SSYTRF +#define CROSSOVER_DSYTRF_ROOK CROSSOVER_DSYTRF +#define CROSSOVER_CSYTRF_ROOK CROSSOVER_CSYTRF +#define CROSSOVER_CHETRF_ROOK CROSSOVER_CHETRF +#define CROSSOVER_ZSYTRF_ROOK CROSSOVER_ZSYTRF +#define CROSSOVER_ZHETRF_ROOK CROSSOVER_ZHETRF + +#define CROSSOVER_XGETRF CROSSOVER +#define CROSSOVER_SGETRF CROSSOVER_XGETRF +#define CROSSOVER_DGETRF CROSSOVER_XGETRF +#define CROSSOVER_CGETRF CROSSOVER_XGETRF +#define CROSSOVER_ZGETRF CROSSOVER_XGETRF + +#define CROSSOVER_XGBTRF CROSSOVER +#define CROSSOVER_SGBTRF CROSSOVER_XGBTRF +#define CROSSOVER_DGBTRF CROSSOVER_XGBTRF +#define CROSSOVER_CGBTRF CROSSOVER_XGBTRF +#define CROSSOVER_ZGBTRF CROSSOVER_XGBTRF + +#define CROSSOVER_XTRSYL CROSSOVER +#define CROSSOVER_STRSYL CROSSOVER_XTRSYL +#define CROSSOVER_DTRSYL CROSSOVER_XTRSYL +#define CROSSOVER_CTRSYL CROSSOVER_XTRSYL +#define CROSSOVER_ZTRSYL CROSSOVER_XTRSYL + +#define CROSSOVER_XTGSYL CROSSOVER +#define CROSSOVER_STGSYL CROSSOVER_XTGSYL +#define CROSSOVER_DTGSYL CROSSOVER_XTGSYL +#define CROSSOVER_CTGSYL CROSSOVER_XTGSYL +#define CROSSOVER_ZTGSYL CROSSOVER_XTGSYL + +// sytrf helper routine +#define CROSSOVER_XGEMMT CROSSOVER_XSYTRF +#define CROSSOVER_SGEMMT CROSSOVER_XGEMMT +#define CROSSOVER_DGEMMT CROSSOVER_XGEMMT +#define CROSSOVER_CGEMMT CROSSOVER_XGEMMT +#define CROSSOVER_ZGEMMT CROSSOVER_XGEMMT + +#endif /* RELAPACK_CONFIG_H */ diff --git a/relapack/config.md b/relapack/config.md new file mode 100644 index 0000000000..ea14be16a9 --- /dev/null +++ b/relapack/config.md @@ -0,0 +1,87 @@ +RELAPACK Configuration +====================== + +ReLAPACK has two configuration files: `make.inc`, which is included by the +Makefile, and `config.h` which is included in the source files. + + +Build and Testing Environment +----------------------------- +The build environment (compiler and flags) and the test configuration (linker +flags for BLAS and LAPACK) are specified in `make.inc`. The test matrix size +and error bounds are defined in `test/config.h`. + +The library `librelapack.a` is compiled by invoking `make`. The tests are +performed by either `make test` or calling `make` in the test folder. + + +BLAS/LAPACK complex function interfaces +--------------------------------------- +For BLAS and LAPACK functions that return a complex number, there exist two +conflicting (FORTRAN compiler dependent) calling conventions: either the result +is returned as a `struct` of two floating point numbers or an additional first +argument with a pointer to such a `struct` is used. By default ReLAPACK uses +the former (which is what gfortran uses), but it can switch to the latter by +setting `COMPLEX_FUNCTIONS_AS_ROUTINES` (or explicitly the BLAS and LAPACK +specific counterparts) to `1` in `config.h`. + +**For MKL, `COMPLEX_FUNCTIONS_AS_ROUTINES` must be set to `1`.** + +(Using the wrong convention will break `ctrsyl` and `ztrsyl` and the test cases +will segfault or return errors on the order of 1 or larger.) + + +BLAS extension `xgemmt` +----------------------- +The LDL decompositions require a general matrix-matrix product that updates only +a triangular matrix called `xgemmt`. If the BLAS implementation linked against +provides such a routine, set the flag `HAVE_XGEMMT` to `1` in `config.h`; +otherwise, ReLAPACK uses its own recursive implementation of these kernels. + +`xgemmt` is provided by MKL. + + +Routine Selection +----------------- +ReLAPACK's routines are named `RELAPACK_X` (e.g., `RELAPACK_dgetrf`). If the +corresponding `INCLUDE_X` flag in `config.h` (e.g., `INCLUDE_DGETRF`) is set to +`1`, ReLAPACK additionally provides a wrapper under the LAPACK name (e.g., +`dgetrf_`). By default, wrappers for all routines are enabled. + + +Crossover Size +-------------- +The crossover size determines below which matrix sizes ReLAPACK's recursive +algorithms switch to LAPACK's unblocked routines to avoid tiny BLAS Level 3 +routines. The crossover size is set in `config.h` and can be chosen either +globally for the entire library, by operation, or individually by routine. + + +Allowing Temporary Buffers +-------------------------- +Two of ReLAPACK's routines make use of temporary buffers, which are allocated +and freed within ReLAPACK. Setting `ALLOW_MALLOC` (or one of the routine +specific counterparts) to 0 in `config.h` will disable these buffers. The +affected routines are: + + * `xsytrf`: The LDL decomposition requires a buffer of size n^2 / 2. As in + LAPACK, this size can be queried by setting `lWork = -1` and the passed + buffer will be used if it is large enough; only if it is not, a local buffer + will be allocated. + + The advantage of this mechanism is that ReLAPACK will seamlessly work even + with codes that statically provide too little memory instead of breaking + them. + + * `xsygst`: The reduction of a real symmetric-definite generalized eigenproblem + to standard form can use an auxiliary buffer of size n^2 / 2 to avoid + redundant computations. It thereby performs about 30% less FLOPs than + LAPACK. + + +FORTRAN symbol names +-------------------- +ReLAPACK is commonly linked to BLAS and LAPACK with standard FORTRAN interfaces. +Since these libraries usually have an underscore to their symbol names, ReLAPACK +has configuration switches in `config.h` to adjust the corresponding routine +names. diff --git a/relapack/coverage.md b/relapack/coverage.md new file mode 100644 index 0000000000..8406b20788 --- /dev/null +++ b/relapack/coverage.md @@ -0,0 +1,212 @@ +Coverage of ReLAPACK +==================== + +This file lists all LAPACK compute routines that are covered by recursive +algorithms in ReLAPACK, it also lists all of LAPACK's blocked algorithms which +are not (yet) part of ReLAPACK. + + + +**Table of Contents** *generated with [DocToc](https://github.com/thlorenz/doctoc)* + +- [List of covered LAPACK routines](#list-of-covered-lapack-routines) + - [`xlauum`](#xlauum) + - [`xsygst`](#xsygst) + - [`xtrtri`](#xtrtri) + - [`xpotrf`](#xpotrf) + - [`xpbtrf`](#xpbtrf) + - [`xsytrf`](#xsytrf) + - [`xgetrf`](#xgetrf) + - [`xgbtrf`](#xgbtrf) + - [`xtrsyl`](#xtrsyl) + - [`xtgsyl`](#xtgsyl) +- [Covered BLAS extension](#covered-blas-extension) + - [`xgemmt`](#xgemmt) +- [Not covered yet](#not-covered-yet) + - [`xpstrf`](#xpstrf) +- [Not covered: extra FLOPs](#not-covered-extra-flops) + - [QR decomposition (and related)](#qr-decomposition-and-related) + - [Symmetric reduction to tridiagonal](#symmetric-reduction-to-tridiagonal) + - [Symmetric reduction to bidiagonal](#symmetric-reduction-to-bidiagonal) + - [Reduction to upper Hessenberg](#reduction-to-upper-hessenberg) + + + + +List of covered LAPACK routines +------------------------------- + +### `xlauum` +Multiplication of a triangular matrix with its (complex conjugate) transpose, +resulting in a symmetric (Hermitian) matrix. + +Routines: `slauum`, `dlauum`, `clauum`, `zlauum` + +Operations: +* A = L^T L +* A = U U^T + +### `xsygst` +Simultaneous two-sided multiplication of a symmetric matrix with a triangular +matrix and its transpose + +Routines: `ssygst`, `dsygst`, `chegst`, `zhegst` + +Operations: +* A = inv(L) A inv(L^T) +* A = inv(U^T) A inv(U) +* A = L^T A L +* A = U A U^T + +### `xtrtri` +Inversion of a triangular matrix + +Routines: `strtri`, `dtrtri`, `ctrtri`, `ztrtri` + +Operations: +* L = inv(L) +* U = inv(U) + +### `xpotrf` +Cholesky decomposition of a symmetric (Hermitian) positive definite matrix + +Routines: `spotrf`, `dpotrf`, `cpotrf`, `zpotrf` + +Operations: +* L L^T = A +* U^T U = A + +### `xpbtrf` +Cholesky decomposition of a banded symmetric (Hermitian) positive definite matrix + +Routines: `spbtrf`, `dpbtrf`, `cpbtrf`, `zpbtrf` + +Operations: +* L L^T = A +* U^T U = A + +### `xsytrf` +LDL decomposition of a symmetric (or Hermitian) matrix + +Routines: +* `ssytrf`, `dsytrf`, `csytrf`, `chetrf`, `zsytrf`, `zhetrf`, +* `ssytrf_rook`, `dsytrf_rook`, `csytrf_rook`, `chetrf_rook`, `zsytrf_rook`, + `zhetrf_rook` + +Operations: +* L D L^T = A +* U^T D U = A + +### `xgetrf` +LU decomposition of a general matrix with pivoting + +Routines: `sgetrf`, `dgetrf`, `cgetrf`, `zgetrf` + +Operation: P L U = A + +### `xgbtrf` +LU decomposition of a general banded matrix with pivoting + +Routines: `sgbtrf`, `dgbtrf`, `cgbtrf`, `zgbtrf` + +Operation: L U = A + +### `xtrsyl` +Solution of the quasi-triangular Sylvester equation + +Routines: `strsyl`, `dtrsyl`, `ctrsyl`, `ztrsyl` + +Operations: +* A X + B Y = C -> X +* A^T X + B Y = C -> X +* A X + B^T Y = C -> X +* A^T X + B^T Y = C -> X +* A X - B Y = C -> X +* A^T X - B Y = C -> X +* A X - B^T Y = C -> X +* A^T X - B^T Y = C -> X + +### `xtgsyl` +Solution of the generalized Sylvester equations + +Routines: `stgsyl`, `dtgsyl`, `ctgsyl`, `ztgsyl` + +Operations: +* A R - L B = C, D R - L E = F -> L, R +* A^T R + D^T L = C, R B^T - L E^T = -F -> L, R + + +Covered BLAS extension +---------------------- + +### `xgemmt` +Matrix-matrix product updating only a triangular part of the result + +Routines: `sgemmt`, `dgemmt`, `cgemmt`, `zgemmt` + +Operations: +* C = alpha A B + beta C +* C = alpha A B^T + beta C +* C = alpha A^T B + beta C +* C = alpha A^T B^T + beta C + + +Not covered yet +--------------- +The following operation is implemented as a blocked algorithm in LAPACK but +currently not yet covered in ReLAPACK as a recursive algorithm + +### `xpstrf` +Cholesky decomposition of a positive semi-definite matrix with complete pivoting. + +Routines: `spstrf`, `dpstrf`, `cpstrf`, `zpstrf` + +Operations: +* P L L^T P^T = A +* P U^T U P^T = A + + +Not covered: extra FLOPs +------------------------ +The following routines are not covered because recursive variants would require +considerably more FLOPs or operate on banded matrices. + +### QR decomposition (and related) +Routines: +* `sgeqrf`, `dgeqrf`, `cgeqrf`, `zgeqrf` +* `sgerqf`, `dgerqf`, `cgerqf`, `zgerqf` +* `sgeqlf`, `dgeqlf`, `cgeqlf`, `zgeqlf` +* `sgelqf`, `dgelqf`, `cgelqf`, `zgelqf` +* `stzrzf`, `dtzrzf`, `ctzrzf`, `ztzrzf` + +Operations: Q R = A, R Q = A, Q L = A, L Q = A, R Z = A + +Routines for multiplication with Q: +* `sormqr`, `dormqr`, `cunmqr`, `zunmqr` +* `sormrq`, `dormrq`, `cunmrq`, `zunmrq` +* `sormql`, `dormql`, `cunmql`, `zunmql` +* `sormlq`, `dormlq`, `cunmlq`, `zunmlq` +* `sormrz`, `dormrz`, `cunmrz`, `zunmrz` + +Operations: C = Q C, C = C Q, C = Q^T C, C = C Q^T + +Routines for construction of Q: +* `sorgqr`, `dorgqr`, `cungqr`, `zungqr` +* `sorgrq`, `dorgrq`, `cungrq`, `zungrq` +* `sorgql`, `dorgql`, `cungql`, `zungql` +* `sorglq`, `dorglq`, `cunglq`, `zunglq` + +### Symmetric reduction to tridiagonal +Routines: `ssytrd`, `dsytrd`, `csytrd`, `zsytrd` + +Operation: Q T Q^T = A + +### Symmetric reduction to bidiagonal +Routines: `ssybrd`, `dsybrd`, `csybrd`, `zsybrd` + +Operation: Q T P^T = A + +### Reduction to upper Hessenberg +Routines: `sgehrd`, `dgehrd`, `cgehrd`, `zgehrd` + +Operation: Q H Q^T = A diff --git a/relapack/inc/relapack.h b/relapack/inc/relapack.h new file mode 100644 index 0000000000..e421f352b1 --- /dev/null +++ b/relapack/inc/relapack.h @@ -0,0 +1,67 @@ +#ifndef RELAPACK_H +#define RELAPACK_H + +void RELAPACK_slauum(const char *, const int *, float *, const int *, int *); +void RELAPACK_dlauum(const char *, const int *, double *, const int *, int *); +void RELAPACK_clauum(const char *, const int *, float *, const int *, int *); +void RELAPACK_zlauum(const char *, const int *, double *, const int *, int *); + +void RELAPACK_strtri(const char *, const char *, const int *, float *, const int *, int *); +void RELAPACK_dtrtri(const char *, const char *, const int *, double *, const int *, int *); +void RELAPACK_ctrtri(const char *, const char *, const int *, float *, const int *, int *); +void RELAPACK_ztrtri(const char *, const char *, const int *, double *, const int *, int *); + +void RELAPACK_spotrf(const char *, const int *, float *, const int *, int *); +void RELAPACK_dpotrf(const char *, const int *, double *, const int *, int *); +void RELAPACK_cpotrf(const char *, const int *, float *, const int *, int *); +void RELAPACK_zpotrf(const char *, const int *, double *, const int *, int *); + +void RELAPACK_spbtrf(const char *, const int *, const int *, float *, const int *, int *); +void RELAPACK_dpbtrf(const char *, const int *, const int *, double *, const int *, int *); +void RELAPACK_cpbtrf(const char *, const int *, const int *, float *, const int *, int *); +void RELAPACK_zpbtrf(const char *, const int *, const int *, double *, const int *, int *); + +void RELAPACK_ssytrf(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_dsytrf(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_csytrf(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_chetrf(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_zsytrf(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_zhetrf(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_ssytrf_rook(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_dsytrf_rook(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_csytrf_rook(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_chetrf_rook(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_zsytrf_rook(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_zhetrf_rook(const char *, const int *, double *, const int *, int *, double *, const int *, int *); + +void RELAPACK_sgetrf(const int *, const int *, float *, const int *, int *, int *); +void RELAPACK_dgetrf(const int *, const int *, double *, const int *, int *, int *); +void RELAPACK_cgetrf(const int *, const int *, float *, const int *, int *, int *); +void RELAPACK_zgetrf(const int *, const int *, double *, const int *, int *, int *); + +void RELAPACK_sgbtrf(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +void RELAPACK_dgbtrf(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); +void RELAPACK_cgbtrf(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +void RELAPACK_zgbtrf(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); + +void RELAPACK_ssygst(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +void RELAPACK_dsygst(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); +void RELAPACK_chegst(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +void RELAPACK_zhegst(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); + +void RELAPACK_strsyl(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void RELAPACK_dtrsyl(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); +void RELAPACK_ctrsyl(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void RELAPACK_ztrsyl(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); + +void RELAPACK_stgsyl(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, const int *, int *, int *); +void RELAPACK_dtgsyl(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, const int *, int *, int *); +void RELAPACK_ctgsyl(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, const int *, int *, int *); +void RELAPACK_ztgsyl(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, const int *, int *, int *); + +void RELAPACK_sgemmt(const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +void RELAPACK_dgemmt(const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); +void RELAPACK_cgemmt(const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +void RELAPACK_zgemmt(const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); + +#endif /* RELAPACK_H */ diff --git a/relapack/src/blas.h b/relapack/src/blas.h new file mode 100644 index 0000000000..7441c1033d --- /dev/null +++ b/relapack/src/blas.h @@ -0,0 +1,61 @@ +#ifndef BLAS_H +#define BLAS_H + +extern void BLAS(sswap)(const int *, float *, const int *, float *, const int *); +extern void BLAS(dswap)(const int *, double *, const int *, double *, const int *); +extern void BLAS(cswap)(const int *, float *, const int *, float *, const int *); +extern void BLAS(zswap)(const int *, double *, const int *, double *, const int *); + +extern void BLAS(sscal)(const int *, const float *, float *, const int *); +extern void BLAS(dscal)(const int *, const double *, double *, const int *); +extern void BLAS(cscal)(const int *, const float *, float *, const int *); +extern void BLAS(zscal)(const int *, const double *, double *, const int *); + +extern void BLAS(saxpy)(const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(daxpy)(const int *, const double *, const double *, const int *, double *, const int *); +extern void BLAS(caxpy)(const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(zaxpy)(const int *, const double *, const double *, const int *, double *, const int *); + +extern void BLAS(sgemv)(const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(dgemv)(const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); +extern void BLAS(cgemv)(const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(zgemv)(const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); + +extern void BLAS(sgemm)(const char *, const char *, const int *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(dgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); +extern void BLAS(cgemm)(const char *, const char *, const int *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(zgemm)(const char *, const char *, const int *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); + +extern void BLAS(strsm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(dtrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, double *, const int *); +extern void BLAS(ctrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(ztrsm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, double *, const int *); + +extern void BLAS(strmm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(dtrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, double *, const int *); +extern void BLAS(ctrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, float *, const int *); +extern void BLAS(ztrmm)(const char *, const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, double *, const int *); + +extern void BLAS(ssyrk)(const char *, const char *, const int *, const int *, const float *, float *, const int *, const float *, float *, const int *); +extern void BLAS(dsyrk)(const char *, const char *, const int *, const int *, const double *, double *, const int *, const double *, double *, const int *); +extern void BLAS(cherk)(const char *, const char *, const int *, const int *, const float *, float *, const int *, const float *, float *, const int *); +extern void BLAS(zherk)(const char *, const char *, const int *, const int *, const double *, double *, const int *, const double *, double *, const int *); + +extern void BLAS(ssymm)(const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +extern void BLAS(dsymm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); +extern void BLAS(chemm)(const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +extern void BLAS(zhemm)(const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); + +extern void BLAS(ssyr2k)(const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +extern void BLAS(dsyr2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); +extern void BLAS(cher2k)(const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, float *, const int *); +extern void BLAS(zher2k)(const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, double *, const int *); + +#if HAVE_XGEMMT +extern void BLAS(sgemmt)(const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(dgemmt)(const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); +extern void BLAS(cgemmt)(const char *, const char *, const char *, const int *, const int *, const float *, const float *, const int *, const float *, const int *, const float *, const float *, const int*); +extern void BLAS(zgemmt)(const char *, const char *, const char *, const int *, const int *, const double *, const double *, const int *, const double *, const int *, const double *, const double *, const int*); +#endif + +#endif /* BLAS_H */ diff --git a/relapack/src/cgbtrf.c b/relapack/src/cgbtrf.c new file mode 100644 index 0000000000..90b2c87895 --- /dev/null +++ b/relapack/src/cgbtrf.c @@ -0,0 +1,230 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_cgbtrf_rec(const int *, const int *, const int *, + const int *, float *, const int *, int *, float *, const int *, float *, + const int *, int *); + + +/** CGBTRF computes an LU factorization of a complex m-by-n band matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's cgbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d0/d3a/cgbtrf_8f.html + * */ +void RELAPACK_cgbtrf( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kl < 0) + *info = -3; + else if (*ku < 0) + *info = -4; + else if (*ldAb < 2 * *kl + *ku + 1) + *info = -6; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CGBTRF", &minfo); + return; + } + + // Constant + const float ZERO[] = { 0., 0. }; + + // Result upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + 2 * kv; + + // Zero upper diagonal fill-in elements + int i, j; + for (j = 0; j < *n; j++) { + float *const A_j = A + 2 * *ldA * j; + for (i = MAX(0, j - kv); i < j - *ku; i++) + A_j[2 * i] = A_j[2 * i + 1] = 0.; + } + + // Allocate work space + const int n1 = CREC_SPLIT(*n); + const int mWorkl = (kv > n1) ? MAX(1, *m - *kl) : kv; + const int nWorkl = (kv > n1) ? n1 : kv; + const int mWorku = (*kl > n1) ? n1 : *kl; + const int nWorku = (*kl > n1) ? MAX(0, *n - *kl) : *kl; + float *Workl = malloc(mWorkl * nWorkl * 2 * sizeof(float)); + float *Worku = malloc(mWorku * nWorku * 2 * sizeof(float)); + LAPACK(claset)("L", &mWorkl, &nWorkl, ZERO, ZERO, Workl, &mWorkl); + LAPACK(claset)("U", &mWorku, &nWorku, ZERO, ZERO, Worku, &mWorku); + + // Recursive kernel + RELAPACK_cgbtrf_rec(m, n, kl, ku, Ab, ldAb, ipiv, Workl, &mWorkl, Worku, &mWorku, info); + + // Free work space + free(Workl); + free(Worku); +} + + +/** cgbtrf's recursive compute kernel */ +static void RELAPACK_cgbtrf_rec( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + float *Workl, const int *ldWorkl, float *Worku, const int *ldWorku, + int *info +) { + + if (*n <= MAX(CROSSOVER_CGBTRF, 1)) { + // Unblocked + LAPACK(cgbtf2)(m, n, kl, ku, Ab, ldAb, ipiv, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Loop iterators + int i, j; + + // Output upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + 2 * kv; + + // Splitting + const int n1 = MIN(CREC_SPLIT(*n), *kl); + const int n2 = *n - n1; + const int m1 = MIN(n1, *m); + const int m2 = *m - m1; + const int mn1 = MIN(m1, n1); + const int mn2 = MIN(m2, n2); + + // Ab_L * + // Ab_BR + float *const Ab_L = Ab; + float *const Ab_BR = Ab + 2 * *ldAb * n1; + + // A_L A_R + float *const A_L = A; + float *const A_R = A + 2 * *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * m1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * m1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // Banded splitting + const int n21 = MIN(n2, kv - n1); + const int n22 = MIN(n2 - n21, n1); + const int m21 = MIN(m2, *kl - m1); + const int m22 = MIN(m2 - m21, m1); + + // n1 n21 n22 + // m * A_Rl ARr + float *const A_Rl = A_R; + float *const A_Rr = A_R + 2 * *ldA * n21; + + // n1 n21 n22 + // m1 * A_TRl A_TRr + // m21 A_BLt A_BRtl A_BRtr + // m22 A_BLb A_BRbl A_BRbr + float *const A_TRl = A_TR; + float *const A_TRr = A_TR + 2 * *ldA * n21; + float *const A_BLt = A_BL; + float *const A_BLb = A_BL + 2 * m21; + float *const A_BRtl = A_BR; + float *const A_BRtr = A_BR + 2 * *ldA * n21; + float *const A_BRbl = A_BR + 2 * m21; + float *const A_BRbr = A_BR + 2 * *ldA * n21 + 2 * m21; + + // recursion(Ab_L, ipiv_T) + RELAPACK_cgbtrf_rec(m, &n1, kl, ku, Ab_L, ldAb, ipiv_T, Workl, ldWorkl, Worku, ldWorku, info); + + // Workl = A_BLb + LAPACK(clacpy)("U", &m22, &n1, A_BLb, ldA, Workl, ldWorkl); + + // partially redo swaps in A_L + for (i = 0; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(cswap)(&i, A_L + 2 * i, ldA, A_L + 2 * ip, ldA); + else + BLAS(cswap)(&i, A_L + 2 * i, ldA, Workl + 2 * (ip - *kl), ldWorkl); + } + } + + // apply pivots to A_Rl + LAPACK(claswp)(&n21, A_Rl, ldA, iONE, &mn1, ipiv_T, iONE); + + // apply pivots to A_Rr columnwise + for (j = 0; j < n22; j++) { + float *const A_Rrj = A_Rr + 2 * *ldA * j; + for (i = j; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + const float tmpr = A_Rrj[2 * i]; + const float tmpc = A_Rrj[2 * i + 1]; + A_Rrj[2 * i] = A_Rrj[2 * ip]; + A_Rrj[2 * i + 1] = A_Rr[2 * ip + 1]; + A_Rrj[2 * ip] = tmpr; + A_Rrj[2 * ip + 1] = tmpc; + } + } + } + + // A_TRl = A_TL \ A_TRl + BLAS(ctrsm)("L", "L", "N", "U", &m1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // Worku = A_TRr + LAPACK(clacpy)("L", &m1, &n22, A_TRr, ldA, Worku, ldWorku); + // Worku = A_TL \ Worku + BLAS(ctrsm)("L", "L", "N", "U", &m1, &n22, ONE, A_TL, ldA, Worku, ldWorku); + // A_TRr = Worku + LAPACK(clacpy)("L", &m1, &n22, Worku, ldWorku, A_TRr, ldA); + // A_BRtl = A_BRtl - A_BLt * A_TRl + BLAS(cgemm)("N", "N", &m21, &n21, &n1, MONE, A_BLt, ldA, A_TRl, ldA, ONE, A_BRtl, ldA); + // A_BRbl = A_BRbl - Workl * A_TRl + BLAS(cgemm)("N", "N", &m22, &n21, &n1, MONE, Workl, ldWorkl, A_TRl, ldA, ONE, A_BRbl, ldA); + // A_BRtr = A_BRtr - A_BLt * Worku + BLAS(cgemm)("N", "N", &m21, &n22, &n1, MONE, A_BLt, ldA, Worku, ldWorku, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Workl * Worku + BLAS(cgemm)("N", "N", &m22, &n22, &n1, MONE, Workl, ldWorkl, Worku, ldWorku, ONE, A_BRbr, ldA); + + // partially undo swaps in A_L + for (i = mn1 - 1; i >= 0; i--) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(cswap)(&i, A_L + 2 * i, ldA, A_L + 2 * ip, ldA); + else + BLAS(cswap)(&i, A_L + 2 * i, ldA, Workl + 2 * (ip - *kl), ldWorkl); + } + } + + // recursion(Ab_BR, ipiv_B) + RELAPACK_cgbtrf_rec(&m2, &n2, kl, ku, Ab_BR, ldAb, ipiv_B, Workl, ldWorkl, Worku, ldWorku, info); + if (*info) + *info += n1; + // shift pivots + for (i = 0; i < mn2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/cgemmt.c b/relapack/src/cgemmt.c new file mode 100644 index 0000000000..28e2b00b01 --- /dev/null +++ b/relapack/src/cgemmt.c @@ -0,0 +1,167 @@ +#include "relapack.h" + +static void RELAPACK_cgemmt_rec(const char *, const char *, const char *, + const int *, const int *, const float *, const float *, const int *, + const float *, const int *, const float *, float *, const int *); + +static void RELAPACK_cgemmt_rec2(const char *, const char *, const char *, + const int *, const int *, const float *, const float *, const int *, + const float *, const int *, const float *, float *, const int *); + + +/** CGEMMT computes a matrix-matrix product with general matrices but updates + * only the upper or lower triangular part of the result matrix. + * + * This routine performs the same operation as the BLAS routine + * cgemm(transA, transB, n, n, k, alpha, A, ldA, B, ldB, beta, C, ldC) + * but only updates the triangular part of C specified by uplo: + * If (*uplo == 'L'), only the lower triangular part of C is updated, + * otherwise the upper triangular part is updated. + * */ +void RELAPACK_cgemmt( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + +#if HAVE_XGEMMT + BLAS(cgemmt)(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; +#else + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int notransA = LAPACK(lsame)(transA, "N"); + const int tranA = LAPACK(lsame)(transA, "T"); + const int ctransA = LAPACK(lsame)(transA, "C"); + const int notransB = LAPACK(lsame)(transB, "N"); + const int tranB = LAPACK(lsame)(transB, "T"); + const int ctransB = LAPACK(lsame)(transB, "C"); + int info = 0; + if (!lower && !upper) + info = 1; + else if (!tranA && !ctransA && !notransA) + info = 2; + else if (!tranB && !ctransB && !notransB) + info = 3; + else if (*n < 0) + info = 4; + else if (*k < 0) + info = 5; + else if (*ldA < MAX(1, notransA ? *n : *k)) + info = 8; + else if (*ldB < MAX(1, notransB ? *k : *n)) + info = 10; + else if (*ldC < MAX(1, *n)) + info = 13; + if (info) { + LAPACK(xerbla)("CGEMMT", &info); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleantransA = notransA ? 'N' : (tranA ? 'T' : 'C'); + const char cleantransB = notransB ? 'N' : (tranB ? 'T' : 'C'); + + // Recursive kernel + RELAPACK_cgemmt_rec(&cleanuplo, &cleantransA, &cleantransB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); +#endif +} + + +/** cgemmt's recursive compute kernel */ +static void RELAPACK_cgemmt_rec( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + + if (*n <= MAX(CROSSOVER_CGEMMT, 1)) { + // Unblocked + RELAPACK_cgemmt_rec2(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; + } + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_T + // A_B + const float *const A_T = A; + const float *const A_B = A + 2 * ((*transA == 'N') ? n1 : *ldA * n1); + + // B_L B_R + const float *const B_L = B; + const float *const B_R = B + 2 * ((*transB == 'N') ? *ldB * n1 : n1); + + // C_TL C_TR + // C_BL C_BR + float *const C_TL = C; + float *const C_TR = C + 2 * *ldC * n1; + float *const C_BL = C + 2 * n1; + float *const C_BR = C + 2 * *ldC * n1 + 2 * n1; + + // recursion(C_TL) + RELAPACK_cgemmt_rec(uplo, transA, transB, &n1, k, alpha, A_T, ldA, B_L, ldB, beta, C_TL, ldC); + + if (*uplo == 'L') + // C_BL = alpha A_B B_L + beta C_BL + BLAS(cgemm)(transA, transB, &n2, &n1, k, alpha, A_B, ldA, B_L, ldB, beta, C_BL, ldC); + else + // C_TR = alpha A_T B_R + beta C_TR + BLAS(cgemm)(transA, transB, &n1, &n2, k, alpha, A_T, ldA, B_R, ldB, beta, C_TR, ldC); + + // recursion(C_BR) + RELAPACK_cgemmt_rec(uplo, transA, transB, &n2, k, alpha, A_B, ldA, B_R, ldB, beta, C_BR, ldC); +} + + +/** cgemmt's unblocked compute kernel */ +static void RELAPACK_cgemmt_rec2( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + + const int incB = (*transB == 'N') ? 1 : *ldB; + const int incC = 1; + + int i; + for (i = 0; i < *n; i++) { + // A_0 + // A_i + const float *const A_0 = A; + const float *const A_i = A + 2 * ((*transA == 'N') ? i : *ldA * i); + + // * B_i * + const float *const B_i = B + 2 * ((*transB == 'N') ? *ldB * i : i); + + // * C_0i * + // * C_ii * + float *const C_0i = C + 2 * *ldC * i; + float *const C_ii = C + 2 * *ldC * i + 2 * i; + + if (*uplo == 'L') { + const int nmi = *n - i; + if (*transA == 'N') + BLAS(cgemv)(transA, &nmi, k, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + else + BLAS(cgemv)(transA, k, &nmi, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + } else { + const int ip1 = i + 1; + if (*transA == 'N') + BLAS(cgemv)(transA, &ip1, k, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + else + BLAS(cgemv)(transA, k, &ip1, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + } + } +} diff --git a/relapack/src/cgetrf.c b/relapack/src/cgetrf.c new file mode 100644 index 0000000000..b31a711d0f --- /dev/null +++ b/relapack/src/cgetrf.c @@ -0,0 +1,117 @@ +#include "relapack.h" + +static void RELAPACK_cgetrf_rec(const int *, const int *, float *, + const int *, int *, int *); + + +/** CGETRF computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's cgetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d9/dfb/cgetrf_8f.html + */ +void RELAPACK_cgetrf( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CGETRF", &minfo); + return; + } + + const int sn = MIN(*m, *n); + + RELAPACK_cgetrf_rec(m, &sn, A, ldA, ipiv, info); + + // Right remainder + if (*m < *n) { + // Constants + const float ONE[] = { 1., 0. }; + const int iONE[] = { 1 }; + + // Splitting + const int rn = *n - *m; + + // A_L A_R + const float *const A_L = A; + float *const A_R = A + 2 * *ldA * *m; + + // A_R = apply(ipiv, A_R) + LAPACK(claswp)(&rn, A_R, ldA, iONE, m, ipiv, iONE); + // A_R = A_L \ A_R + BLAS(ctrsm)("L", "L", "N", "U", m, &rn, ONE, A_L, ldA, A_R, ldA); + } +} + + +/** cgetrf's recursive compute kernel */ +static void RELAPACK_cgetrf_rec( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + + if (*n <= MAX(CROSSOVER_CGETRF, 1)) { + // Unblocked + LAPACK(cgetf2)(m, n, A, ldA, ipiv, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + const int m2 = *m - n1; + + // A_L A_R + float *const A_L = A; + float *const A_R = A + 2 * *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // recursion(A_L, ipiv_T) + RELAPACK_cgetrf_rec(m, &n1, A_L, ldA, ipiv_T, info); + // apply pivots to A_R + LAPACK(claswp)(&n2, A_R, ldA, iONE, &n1, ipiv_T, iONE); + + // A_TR = A_TL \ A_TR + BLAS(ctrsm)("L", "L", "N", "U", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_BL * A_TR + BLAS(cgemm)("N", "N", &m2, &n2, &n1, MONE, A_BL, ldA, A_TR, ldA, ONE, A_BR, ldA); + + // recursion(A_BR, ipiv_B) + RELAPACK_cgetrf_rec(&m2, &n2, A_BR, ldA, ipiv_B, info); + if (*info) + *info += n1; + // apply pivots to A_BL + LAPACK(claswp)(&n1, A_BL, ldA, iONE, &n2, ipiv_B, iONE); + // shift pivots + int i; + for (i = 0; i < n2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/chegst.c b/relapack/src/chegst.c new file mode 100644 index 0000000000..dff875017d --- /dev/null +++ b/relapack/src/chegst.c @@ -0,0 +1,212 @@ +#include "relapack.h" +#if XSYGST_ALLOW_MALLOC +#include "stdlib.h" +#endif + +static void RELAPACK_chegst_rec(const int *, const char *, const int *, + float *, const int *, const float *, const int *, + float *, const int *, int *); + + +/** CHEGST reduces a complex Hermitian-definite generalized eigenproblem to standard form. + * + * This routine is functionally equivalent to LAPACK's chegst. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d7/d2a/chegst_8f.html + * */ +void RELAPACK_chegst( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (*itype < 1 || *itype > 3) + *info = -1; + else if (!lower && !upper) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + else if (*ldB < MAX(1, *n)) + *info = -7; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CHEGST", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Allocate work space + float *Work = NULL; + int lWork = 0; +#if XSYGST_ALLOW_MALLOC + const int n1 = CREC_SPLIT(*n); + lWork = n1 * (*n - n1); + Work = malloc(lWork * 2 * sizeof(float)); + if (!Work) + lWork = 0; +#endif + + // recursive kernel + RELAPACK_chegst_rec(itype, &cleanuplo, n, A, ldA, B, ldB, Work, &lWork, info); + + // Free work space +#if XSYGST_ALLOW_MALLOC + if (Work) + free(Work); +#endif +} + + +/** chegst's recursive compute kernel */ +static void RELAPACK_chegst_rec( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + float *Work, const int *lWork, int *info +) { + + if (*n <= MAX(CROSSOVER_CHEGST, 1)) { + // Unblocked + LAPACK(chegs2)(itype, uplo, n, A, ldA, B, ldB, info); + return; + } + + // Constants + const float ZERO[] = { 0., 0. }; + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const float HALF[] = { .5, 0. }; + const float MHALF[] = { -.5, 0. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // B_TL B_TR + // B_BL B_BR + const float *const B_TL = B; + const float *const B_TR = B + 2 * *ldB * n1; + const float *const B_BL = B + 2 * n1; + const float *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // recursion(A_TL, B_TL) + RELAPACK_chegst_rec(itype, uplo, &n1, A_TL, ldA, B_TL, ldB, Work, lWork, info); + + if (*itype == 1) + if (*uplo == 'L') { + // A_BL = A_BL / B_TL' + BLAS(ctrsm)("R", "L", "C", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * B_BL * A_TL + BLAS(chemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(caxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + } else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(chemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BR = A_BR - A_BL * B_BL' - B_BL * A_BL' + BLAS(cher2k)("L", "N", &n2, &n1, MONE, A_BL, ldA, B_BL, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(caxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(chemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR \ A_BL + BLAS(ctrsm)("L", "L", "N", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL' \ A_TR + BLAS(ctrsm)("L", "U", "C", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * A_TL * B_TR + BLAS(chemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(caxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + } else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(chemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_BR = A_BR - A_TR' * B_TR - B_TR' * A_TR + BLAS(cher2k)("U", "C", &n2, &n1, MONE, A_TR, ldA, B_TR, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(caxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(chemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR / B_BR + BLAS(ctrsm)("R", "U", "N", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + else + if (*uplo == 'L') { + // A_BL = A_BL * B_TL + BLAS(ctrmm)("R", "L", "N", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * A_BR * B_BL + BLAS(chemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(caxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + } else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(chemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_TL = A_TL + A_BL' * B_BL + B_BL' * A_BL + BLAS(cher2k)("L", "C", &n1, &n2, ONE, A_BL, ldA, B_BL, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(caxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(chemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR * A_BL + BLAS(ctrmm)("L", "L", "C", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL * A_TR + BLAS(ctrmm)("L", "U", "N", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * B_TR * A_BR + BLAS(chemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(caxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + } else + // A_TR = A_TR + 1/2 B_TR A_BR + BLAS(chemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TL = A_TL + A_TR * B_TR' + B_TR * A_TR' + BLAS(cher2k)("U", "N", &n1, &n2, ONE, A_TR, ldA, B_TR, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(caxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + else + // A_TR = A_TR + 1/2 B_TR * A_BR + BLAS(chemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR * B_BR + BLAS(ctrmm)("R", "U", "C", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + + // recursion(A_BR, B_BR) + RELAPACK_chegst_rec(itype, uplo, &n2, A_BR, ldA, B_BR, ldB, Work, lWork, info); +} diff --git a/relapack/src/chetrf.c b/relapack/src/chetrf.c new file mode 100644 index 0000000000..2928235e47 --- /dev/null +++ b/relapack/src/chetrf.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_chetrf_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** CHETRF computes the factorization of a complex Hermitian matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's chetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/da/dc1/chetrf_8f.html + * */ +void RELAPACK_chetrf( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CHETRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_chetrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** chetrf's recursive compute kernel */ +static void RELAPACK_chetrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_CHETRF, 3)) { + // Unblocked + if (top) { + LAPACK(chetf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_chetrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = CREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_chetrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + float *const A_BL_B = A + 2 * *n; + float *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + 2 * n1; + float *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_cgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_chetrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(cgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = CREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_chetrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + 2 * *ldA * n_rest; + float *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + float *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + float *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_cgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_chetrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(cgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/chetrf_rec2.c b/relapack/src/chetrf_rec2.c new file mode 100644 index 0000000000..b5c8341b6b --- /dev/null +++ b/relapack/src/chetrf_rec2.c @@ -0,0 +1,520 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static int c__1 = 1; + +/** CHETRF_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kau fman diagonal pivoting method + * + * This routine is a minor modification of LAPACK's clahef. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_chetrf_rec2(char *uplo, int *n, int * + nb, int *kb, complex *a, int *lda, int *ipiv, complex *w, + int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + float r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + double sqrt(double), r_imag(complex *); + void r_cnjg(complex *, complex *), c_div(complex *, complex *, complex *); + + /* Local variables */ + static int j, k; + static float t, r1; + static complex d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static float alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int cgemv_(char *, int *, int *, complex * + , complex *, int *, complex *, int *, complex *, complex * + , int *, ftnlen), ccopy_(int *, complex *, int *, + complex *, int *), cswap_(int *, complex *, int *, + complex *, int *); + static int kstep; + static float absakk; + extern /* Subroutine */ int clacgv_(int *, complex *, int *); + extern int icamax_(int *, complex *, int *); + extern /* Subroutine */ int csscal_(int *, float *, complex *, int + *); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + i__1 = k - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)); + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - 1; + ccopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + jmax + (kw - 1) * w_dim1]), dabs(r__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + ( + r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), dabs( + r__2)); + rowmax = dmax(r__3,r__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((r__1 = w[i__1].r, dabs(r__1)) >= alpha * rowmax) { + kp = imax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = kk - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + clacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + r1 = 1.f / a[i__1].r; + i__1 = k - 1; + csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + r_cnjg(&q__2, &d21); + c_div(&q__1, &w[k + kw * w_dim1], &q__2); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1.f / (q__1.r - 1.f); + q__2.r = t, q__2.i = 0.f; + c_div(&q__1, &q__2, &d21); + d21.r = q__1.r, d21.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + r_cnjg(&q__2, &d21); + i__3 = j + kw * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = + q__2.r * q__3.i + q__2.i * q__3.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1; + clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + clacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j <= *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (ftnlen)12); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + clacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (imax < *n) { + i__1 = *n - imax; + ccopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + jmax + (k + 1) * w_dim1]), dabs(r__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + ( + r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), dabs( + r__2)); + rowmax = dmax(r__3,r__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((r__1 = w[i__1].r, dabs(r__1)) >= alpha * rowmax) { + kp = imax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k + kstep - 1; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = kp - kk - 1; + ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + clacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + r1 = 1.f / a[i__1].r; + i__1 = *n - k; + csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + i__1 = *n - k; + clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + r_cnjg(&q__2, &d21); + c_div(&q__1, &w[k + k * w_dim1], &q__2); + d22.r = q__1.r, d22.i = q__1.i; + q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1.f / (q__1.r - 1.f); + q__2.r = t, q__2.i = 0.f; + c_div(&q__1, &q__2, &d21); + d21.r = q__1.r, d21.i = q__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + r_cnjg(&q__2, &d21); + i__3 = j + k * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = + q__2.r * q__3.i + q__2.i * q__3.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = *n - k; + clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + clacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/chetrf_rook.c b/relapack/src/chetrf_rook.c new file mode 100644 index 0000000000..086393d576 --- /dev/null +++ b/relapack/src/chetrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_chetrf_rook_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's chetrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d0/d5e/chetrf__rook_8f.html + * */ +void RELAPACK_chetrf_rook( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CHETRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_chetrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** chetrf_rook's recursive compute kernel */ +static void RELAPACK_chetrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_CHETRF, 3)) { + // Unblocked + if (top) { + LAPACK(chetf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_chetrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = CREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_chetrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + float *const A_BL_B = A + 2 * *n; + float *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + 2 * n1; + float *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_cgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_chetrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(cgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = CREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_chetrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + 2 * *ldA * n_rest; + float *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + float *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + float *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_cgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_chetrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(cgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/chetrf_rook_rec2.c b/relapack/src/chetrf_rook_rec2.c new file mode 100644 index 0000000000..a42cbfd44d --- /dev/null +++ b/relapack/src/chetrf_rook_rec2.c @@ -0,0 +1,661 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static int c__1 = 1; + +/** CHETRF_ROOK_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the boun ded Bunch-Kaufman ("rook") diagonal pivoting method + * + * This routine is a minor modification of LAPACK's clahef_rook. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_chetrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, complex *a, int *lda, int *ipiv, + complex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + float r__1, r__2; + complex q__1, q__2, q__3, q__4, q__5; + + /* Builtin functions */ + double sqrt(double), r_imag(complex *); + void r_cnjg(complex *, complex *), c_div(complex *, complex *, complex *); + + /* Local variables */ + static int j, k, p; + static float t, r1; + static complex d11, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static float alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int cgemv_(char *, int *, int *, complex * + , complex *, int *, complex *, int *, complex *, complex * + , int *, ftnlen); + static float sfmin; + extern /* Subroutine */ int ccopy_(int *, complex *, int *, + complex *, int *); + static int itemp; + extern /* Subroutine */ int cswap_(int *, complex *, int *, + complex *, int *); + static int kstep; + static float stemp, absakk; + extern /* Subroutine */ int clacgv_(int *, complex *, int *); + extern int icamax_(int *, complex *, int *); + extern double slamch_(char *, ftnlen); + extern /* Subroutine */ int csscal_(int *, float *, complex *, int + *); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + sfmin = slamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], & + c__1); + } + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)); + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + r__1 = w[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + if (k > 1) { + i__1 = k - 1; + ccopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], + &c__1); + } + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + if (imax > 1) { + i__1 = imax - 1; + ccopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + } + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[jmax + (kw - 1) * w_dim1]), dabs(r__2)); + } else { + rowmax = 0.f; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[itemp + (kw - 1) * w_dim1]), dabs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + i__1 = imax + (kw - 1) * w_dim1; + if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) { + kp = imax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = k - 1 - p; + ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + i__1 = k - 1 - p; + clacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda); + if (p > 1) { + i__1 = p - 1; + ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = kk - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + clacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (dabs(t) >= sfmin) { + r1 = 1.f / t; + i__1 = k - 1; + csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L14: */ + } + } + i__1 = k - 1; + clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + r_cnjg(&q__2, &d21); + c_div(&q__1, &w[k + kw * w_dim1], &q__2); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1.f / (q__1.r - 1.f); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + r_cnjg(&q__5, &d21); + c_div(&q__2, &q__3, &q__5); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1; + clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + clacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + ++jj; + if (kstep == 2 && jp1 != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + r__1 = w[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + if (k < *n) { + i__1 = *n - k; + ccopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k * + a_dim1], &c__1); + } + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + clacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + r__1 = a[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + if (imax < *n) { + i__1 = *n - imax; + ccopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + r__1 = w[i__2].r; + w[i__1].r = r__1, w[i__1].i = 0.f; + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[jmax + (k + 1) * w_dim1]), dabs(r__2)); + } else { + rowmax = 0.f; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[itemp + (k + 1) * w_dim1]), dabs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + i__1 = imax + (k + 1) * w_dim1; + if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) { + kp = imax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = p - k - 1; + ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * + a_dim1], lda); + i__1 = p - k - 1; + clacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda); + if (p < *n) { + i__1 = *n - p; + ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = kp - kk - 1; + ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + clacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (dabs(t) >= sfmin) { + r1 = 1.f / t; + i__1 = *n - k; + csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L74: */ + } + } + i__1 = *n - k; + clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + r_cnjg(&q__2, &d21); + c_div(&q__1, &w[k + k * w_dim1], &q__2); + d22.r = q__1.r, d22.i = q__1.i; + q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1.f / (q__1.r - 1.f); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + r_cnjg(&q__5, &d21); + c_div(&q__2, &q__3, &q__5); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = *n - k; + clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + clacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + cswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + --jj; + if (kstep == 2 && jp1 != jj && j >= 1) { + cswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/clauum.c b/relapack/src/clauum.c new file mode 100644 index 0000000000..36d6297cfc --- /dev/null +++ b/relapack/src/clauum.c @@ -0,0 +1,87 @@ +#include "relapack.h" + +static void RELAPACK_clauum_rec(const char *, const int *, float *, + const int *, int *); + + +/** CLAUUM computes the product U * U**H or L**H * L, where the triangular factor U or L is stored in the upper or lower triangular part of the array A. + * + * This routine is functionally equivalent to LAPACK's clauum. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d2/d36/clauum_8f.html + * */ +void RELAPACK_clauum( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CLAUUM", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_clauum_rec(&cleanuplo, n, A, ldA, info); +} + + +/** clauum's recursive compute kernel */ +static void RELAPACK_clauum_rec( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_CLAUUM, 1)) { + // Unblocked + LAPACK(clauu2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_clauum_rec(uplo, &n1, A_TL, ldA, info); + + if (*uplo == 'L') { + // A_TL = A_TL + A_BL' * A_BL + BLAS(cherk)("L", "C", &n1, &n2, ONE, A_BL, ldA, ONE, A_TL, ldA); + // A_BL = A_BR' * A_BL + BLAS(ctrmm)("L", "L", "C", "N", &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TL = A_TL + A_TR * A_TR' + BLAS(cherk)("U", "N", &n1, &n2, ONE, A_TR, ldA, ONE, A_TL, ldA); + // A_TR = A_TR * A_BR' + BLAS(ctrmm)("R", "U", "C", "N", &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_clauum_rec(uplo, &n2, A_BR, ldA, info); +} diff --git a/relapack/src/cpbtrf.c b/relapack/src/cpbtrf.c new file mode 100644 index 0000000000..e0ea7b944a --- /dev/null +++ b/relapack/src/cpbtrf.c @@ -0,0 +1,157 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_cpbtrf_rec(const char *, const int *, const int *, + float *, const int *, float *, const int *, int *); + + +/** CPBTRF computes the Cholesky factorization of a complex Hermitian positive definite band matrix A. + * + * This routine is functionally equivalent to LAPACK's cpbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/de/d2d/cpbtrf_8f.html + * */ +void RELAPACK_cpbtrf( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kd < 0) + *info = -3; + else if (*ldAb < *kd + 1) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CPBTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Constant + const float ZERO[] = { 0., 0. }; + + // Allocate work space + const int n1 = CREC_SPLIT(*n); + const int mWork = (*kd > n1) ? (lower ? *n - *kd : n1) : *kd; + const int nWork = (*kd > n1) ? (lower ? n1 : *n - *kd) : *kd; + float *Work = malloc(mWork * nWork * 2 * sizeof(float)); + LAPACK(claset)(uplo, &mWork, &nWork, ZERO, ZERO, Work, &mWork); + + // Recursive kernel + RELAPACK_cpbtrf_rec(&cleanuplo, n, kd, Ab, ldAb, Work, &mWork, info); + + // Free work space + free(Work); +} + + +/** cpbtrf's recursive compute kernel */ +static void RELAPACK_cpbtrf_rec( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + float *Work, const int *ldWork, + int *info +){ + + if (*n <= MAX(CROSSOVER_CPBTRF, 1)) { + // Unblocked + LAPACK(cpbtf2)(uplo, n, kd, Ab, ldAb, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + 2 * ((*uplo == 'L') ? 0 : *kd); + + // Splitting + const int n1 = MIN(CREC_SPLIT(*n), *kd); + const int n2 = *n - n1; + + // * * + // * Ab_BR + float *const Ab_BR = Ab + 2 * *ldAb * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_cpotrf(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + // Banded splitting + const int n21 = MIN(n2, *kd - n1); + const int n22 = MIN(n2 - n21, *kd); + + // n1 n21 n22 + // n1 * A_TRl A_TRr + // n21 A_BLt A_BRtl A_BRtr + // n22 A_BLb A_BRbl A_BRbr + float *const A_TRl = A_TR; + float *const A_TRr = A_TR + 2 * *ldA * n21; + float *const A_BLt = A_BL; + float *const A_BLb = A_BL + 2 * n21; + float *const A_BRtl = A_BR; + float *const A_BRtr = A_BR + 2 * *ldA * n21; + float *const A_BRbl = A_BR + 2 * n21; + float *const A_BRbr = A_BR + 2 * *ldA * n21 + 2 * n21; + + if (*uplo == 'L') { + // A_BLt = ABLt / A_TL' + BLAS(ctrsm)("R", "L", "C", "N", &n21, &n1, ONE, A_TL, ldA, A_BLt, ldA); + // A_BRtl = A_BRtl - A_BLt * A_BLt' + BLAS(cherk)("L", "N", &n21, &n1, MONE, A_BLt, ldA, ONE, A_BRtl, ldA); + // Work = A_BLb + LAPACK(clacpy)("U", &n22, &n1, A_BLb, ldA, Work, ldWork); + // Work = Work / A_TL' + BLAS(ctrsm)("R", "L", "C", "N", &n22, &n1, ONE, A_TL, ldA, Work, ldWork); + // A_BRbl = A_BRbl - Work * A_BLt' + BLAS(cgemm)("N", "C", &n22, &n21, &n1, MONE, Work, ldWork, A_BLt, ldA, ONE, A_BRbl, ldA); + // A_BRbr = A_BRbr - Work * Work' + BLAS(cherk)("L", "N", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_BLb = Work + LAPACK(clacpy)("U", &n22, &n1, Work, ldWork, A_BLb, ldA); + } else { + // A_TRl = A_TL' \ A_TRl + BLAS(ctrsm)("L", "U", "C", "N", &n1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // A_BRtl = A_BRtl - A_TRl' * A_TRl + BLAS(cherk)("U", "C", &n21, &n1, MONE, A_TRl, ldA, ONE, A_BRtl, ldA); + // Work = A_TRr + LAPACK(clacpy)("L", &n1, &n22, A_TRr, ldA, Work, ldWork); + // Work = A_TL' \ Work + BLAS(ctrsm)("L", "U", "C", "N", &n1, &n22, ONE, A_TL, ldA, Work, ldWork); + // A_BRtr = A_BRtr - A_TRl' * Work + BLAS(cgemm)("C", "N", &n21, &n22, &n1, MONE, A_TRl, ldA, Work, ldWork, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Work' * Work + BLAS(cherk)("U", "C", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_TRr = Work + LAPACK(clacpy)("L", &n1, &n22, Work, ldWork, A_TRr, ldA); + } + + // recursion(A_BR) + if (*kd > n1) + RELAPACK_cpotrf(uplo, &n2, A_BR, ldA, info); + else + RELAPACK_cpbtrf_rec(uplo, &n2, kd, Ab_BR, ldAb, Work, ldWork, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/cpotrf.c b/relapack/src/cpotrf.c new file mode 100644 index 0000000000..e35caa7fa8 --- /dev/null +++ b/relapack/src/cpotrf.c @@ -0,0 +1,92 @@ +#include "relapack.h" + +static void RELAPACK_cpotrf_rec(const char *, const int *, float *, + const int *, int *); + + +/** CPOTRF computes the Cholesky factorization of a complex Hermitian positive definite matrix A. + * + * This routine is functionally equivalent to LAPACK's cpotrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dd/dce/cpotrf_8f.html + * */ +void RELAPACK_cpotrf( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CPOTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_cpotrf_rec(&cleanuplo, n, A, ldA, info); +} + + +/** cpotrf's recursive compute kernel */ +static void RELAPACK_cpotrf_rec( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_CPOTRF, 1)) { + // Unblocked + LAPACK(cpotf2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_cpotrf_rec(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = A_BL / A_TL' + BLAS(ctrsm)("R", "L", "C", "N", &n2, &n1, ONE, A_TL, ldA, A_BL, ldA); + // A_BR = A_BR - A_BL * A_BL' + BLAS(cherk)("L", "N", &n2, &n1, MONE, A_BL, ldA, ONE, A_BR, ldA); + } else { + // A_TR = A_TL' \ A_TR + BLAS(ctrsm)("L", "U", "C", "N", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_TR' * A_TR + BLAS(cherk)("U", "C", &n2, &n1, MONE, A_TR, ldA, ONE, A_BR, ldA); + } + + // recursion(A_BR) + RELAPACK_cpotrf_rec(uplo, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/csytrf.c b/relapack/src/csytrf.c new file mode 100644 index 0000000000..01c161d1ae --- /dev/null +++ b/relapack/src/csytrf.c @@ -0,0 +1,238 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_csytrf_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** CSYTRF computes the factorization of a complex symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's csytrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d5/d21/csytrf_8f.html + * */ +void RELAPACK_csytrf( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy arguments + int nout; + + // Recursive kernel + RELAPACK_csytrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** csytrf's recursive compute kernel */ +static void RELAPACK_csytrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_CSYTRF, 3)) { + // Unblocked + if (top) { + LAPACK(csytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_csytrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = CREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_csytrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + float *const A_BL_B = A + 2 * *n; + float *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + 2 * n1; + float *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_cgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_csytrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(cgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = CREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_csytrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + 2 * *ldA * n_rest; + float *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + float *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + float *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_cgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_csytrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(cgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/csytrf_rec2.c b/relapack/src/csytrf_rec2.c new file mode 100644 index 0000000000..9d6bd849d0 --- /dev/null +++ b/relapack/src/csytrf_rec2.c @@ -0,0 +1,451 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static int c__1 = 1; + +/** CSYTRF_REC2 computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagon al pivoting method. + * + * This routine is a minor modification of LAPACK's clasyf. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_csytrf_rec2(char *uplo, int *n, int * + nb, int *kb, complex *a, int *lda, int *ipiv, complex *w, + int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + float r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3; + + /* Builtin functions */ + double sqrt(double), r_imag(complex *); + void c_div(complex *, complex *, complex *); + + /* Local variables */ + static int j, k; + static complex t, r1, d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static float alpha; + extern /* Subroutine */ int cscal_(int *, complex *, complex *, + int *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int cgemv_(char *, int *, int *, complex * + , complex *, int *, complex *, int *, complex *, complex * + , int *, ftnlen), ccopy_(int *, complex *, int *, + complex *, int *), cswap_(int *, complex *, int *, + complex *, int *); + static int kstep; + static float absakk; + extern int icamax_(int *, complex *, int *); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + kstep = 1; + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + kw * + w_dim1]), dabs(r__2)); + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + jmax + (kw - 1) * w_dim1]), dabs(r__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + ( + r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), dabs( + r__2)); + rowmax = dmax(r__3,r__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + imax + (kw - 1) * w_dim1]), dabs(r__2)) >= alpha * + rowmax) { + kp = imax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kk - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + kw * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + c_div(&q__1, &t, &d21); + d21.r = q__1.r, d21.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + i__1 = *n - k + 1; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (ftnlen)12); + kstep = 1; + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + k * + w_dim1]), dabs(r__2)); + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + jmax + (k + 1) * w_dim1]), dabs(r__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + ( + r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), dabs( + r__2)); + rowmax = dmax(r__3,r__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + imax + (k + 1) * w_dim1]), dabs(r__2)) >= alpha * + rowmax) { + kp = imax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k + kstep - 1; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - kk - 1; + ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k + k * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + c_div(&q__1, &t, &d21); + d21.r = q__1.r, d21.i = q__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + .i; + q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = + d21.r * q__2.i + d21.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/csytrf_rook.c b/relapack/src/csytrf_rook.c new file mode 100644 index 0000000000..aa7dd0e57a --- /dev/null +++ b/relapack/src/csytrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_csytrf_rook_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** CSYTRF_ROOK computes the factorization of a complex symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's csytrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d8/dc8/csytrf__rook_8f.html + * */ +void RELAPACK_csytrf_rook( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_csytrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** csytrf_rook's recursive compute kernel */ +static void RELAPACK_csytrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_CSYTRF_ROOK, 3)) { + // Unblocked + if (top) { + LAPACK(csytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_csytrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = CREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_csytrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + float *const A_BL_B = A + 2 * *n; + float *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + 2 * n1; + float *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_cgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_csytrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(cgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = CREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_csytrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + 2 * *ldA * n_rest; + float *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + float *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + float *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_cgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(cgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_csytrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(cgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/csytrf_rook_rec2.c b/relapack/src/csytrf_rook_rec2.c new file mode 100644 index 0000000000..6638338a60 --- /dev/null +++ b/relapack/src/csytrf_rook_rec2.c @@ -0,0 +1,565 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static int c__1 = 1; + +/** CSYTRF_ROOK_REC2 computes a partial factorization of a complex symmetric matrix using the bounded Bunch-K aufman ("rook") diagonal pivoting method. + * + * This routine is a minor modification of LAPACK's clasyf_rook. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_csytrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, complex *a, int *lda, int *ipiv, + complex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + float r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + double sqrt(double), r_imag(complex *); + void c_div(complex *, complex *, complex *); + + /* Local variables */ + static int j, k, p; + static complex t, r1, d11, d12, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static float alpha; + extern /* Subroutine */ int cscal_(int *, complex *, complex *, + int *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int cgemv_(char *, int *, int *, complex * + , complex *, int *, complex *, int *, complex *, complex * + , int *, ftnlen); + static float sfmin; + extern /* Subroutine */ int ccopy_(int *, complex *, int *, + complex *, int *); + static int itemp; + extern /* Subroutine */ int cswap_(int *, complex *, int *, + complex *, int *); + static int kstep; + static float stemp, absakk; + extern int icamax_(int *, complex *, int *); + extern double slamch_(char *, ftnlen); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + sfmin = slamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + i__1 = k + kw * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + kw * + w_dim1]), dabs(r__2)); + if (k > 1) { + i__1 = k - 1; + imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + kw * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[jmax + (kw - 1) * w_dim1]), dabs(r__2)); + } else { + rowmax = 0.f; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[itemp + (kw - 1) * w_dim1]), dabs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + i__1 = imax + (kw - 1) * w_dim1; + if (! ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + imax + (kw - 1) * w_dim1]), dabs(r__2)) < alpha * + rowmax)) { + kp = imax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = k - p; + ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + ccopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + i__1 = *n - k + 1; + cswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + ccopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = *n - kk + 1; + cswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), dabs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = k - 1; + cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L14: */ + } + } + } + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + c_div(&q__1, &w[k + kw * w_dim1], &d12); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + cswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = *n - k + 1; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + } + i__1 = k + k * w_dim1; + absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + k * + w_dim1]), dabs(r__2)); + if (k < *n) { + i__1 = *n - k; + imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax + + k * w_dim1]), dabs(r__2)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[jmax + (k + 1) * w_dim1]), dabs(r__2)); + } else { + rowmax = 0.f; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(& + w[itemp + (k + 1) * w_dim1]), dabs(r__2)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + i__1 = imax + (k + 1) * w_dim1; + if (! ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[ + imax + (k + 1) * w_dim1]), dabs(r__2)) < alpha * + rowmax)) { + kp = imax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p - k; + ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + ccopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + cswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + ccopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + ccopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + cswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[k + + k * a_dim1]), dabs(r__2)) >= sfmin) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + r1.r = q__1.r, r1.i = q__1.i; + i__1 = *n - k; + cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + c_div(&q__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L74: */ + } + } + } + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = q__1.r, d11.i = q__1.i; + c_div(&q__1, &w[k + k * w_dim1], &d21); + d22.r = q__1.r, d22.i = q__1.i; + q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * + d22.i + d11.i * d22.r; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; + c_div(&q__1, &c_b1, &q__2); + t.r = q__1.r, t.i = q__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] + .i; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + cswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + cswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/ctgsyl.c b/relapack/src/ctgsyl.c new file mode 100644 index 0000000000..15c738baf2 --- /dev/null +++ b/relapack/src/ctgsyl.c @@ -0,0 +1,268 @@ +#include "relapack.h" +#include + +static void RELAPACK_ctgsyl_rec(const char *, const int *, const int *, + const int *, const float *, const int *, const float *, const int *, + float *, const int *, const float *, const int *, const float *, + const int *, float *, const int *, float *, float *, float *, int *); + + +/** CTGSYL solves the generalized Sylvester equation. + * + * This routine is functionally equivalent to LAPACK's ctgsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d7/de7/ctgsyl_8f.html + * */ +void RELAPACK_ctgsyl( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + + // Parse arguments + const int notran = LAPACK(lsame)(trans, "N"); + const int tran = LAPACK(lsame)(trans, "C"); + + // Compute work buffer size + int lwmin = 1; + if (notran && (*ijob == 1 || *ijob == 2)) + lwmin = MAX(1, 2 * *m * *n); + *info = 0; + + // Check arguments + if (!tran && !notran) + *info = -1; + else if (notran && (*ijob < 0 || *ijob > 4)) + *info = -2; + else if (*m <= 0) + *info = -3; + else if (*n <= 0) + *info = -4; + else if (*ldA < MAX(1, *m)) + *info = -6; + else if (*ldB < MAX(1, *n)) + *info = -8; + else if (*ldC < MAX(1, *m)) + *info = -10; + else if (*ldD < MAX(1, *m)) + *info = -12; + else if (*ldE < MAX(1, *n)) + *info = -14; + else if (*ldF < MAX(1, *m)) + *info = -16; + else if (*lWork < lwmin && *lWork != -1) + *info = -20; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CTGSYL", &minfo); + return; + } + + if (*lWork == -1) { + // Work size query + *Work = lwmin; + return; + } + + // Clean char * arguments + const char cleantrans = notran ? 'N' : 'C'; + + // Constant + const float ZERO[] = { 0., 0. }; + + int isolve = 1; + int ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + LAPACK(claset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(claset)("F", m, n, ZERO, ZERO, F, ldF); + } else if (*ijob >= 1) + isolve = 2; + } + + float scale2; + int iround; + for (iround = 1; iround <= isolve; iround++) { + *scale = 1; + float dscale = 0; + float dsum = 1; + RELAPACK_ctgsyl_rec(&cleantrans, &ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, &dsum, &dscale, info); + if (dscale != 0) { + if (*ijob == 1 || *ijob == 3) + *dif = sqrt(2 * *m * *n) / (dscale * sqrt(dsum)); + else + *dif = sqrt(*m * *n) / (dscale * sqrt(dsum)); + } + if (isolve == 2) { + if (iround == 1) { + if (notran) + ifunc = *ijob; + scale2 = *scale; + LAPACK(clacpy)("F", m, n, C, ldC, Work, m); + LAPACK(clacpy)("F", m, n, F, ldF, Work + 2 * *m * *n, m); + LAPACK(claset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(claset)("F", m, n, ZERO, ZERO, F, ldF); + } else { + LAPACK(clacpy)("F", m, n, Work, m, C, ldC); + LAPACK(clacpy)("F", m, n, Work + 2 * *m * *n, m, F, ldF); + *scale = scale2; + } + } + } +} + + +/** ctgsyl's recursive vompute kernel */ +static void RELAPACK_ctgsyl_rec( + const char *trans, const int *ifunc, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dsum, float *dscale, + int *info +) { + + if (*m <= MAX(CROSSOVER_CTGSYL, 1) && *n <= MAX(CROSSOVER_CTGSYL, 1)) { + // Unblocked + LAPACK(ctgsy2)(trans, ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dsum, dscale, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Outputs + float scale1[] = { 1., 0. }; + float scale2[] = { 1., 0. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + const int m1 = CREC_SPLIT(*m); + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const float *const A_TL = A; + const float *const A_TR = A + 2 * *ldA * m1; + const float *const A_BR = A + 2 * *ldA * m1 + 2 * m1; + + // C_T + // C_B + float *const C_T = C; + float *const C_B = C + 2 * m1; + + // D_TL D_TR + // 0 D_BR + const float *const D_TL = D; + const float *const D_TR = D + 2 * *ldD * m1; + const float *const D_BR = D + 2 * *ldD * m1 + 2 * m1; + + // F_T + // F_B + float *const F_T = F; + float *const F_B = F + 2 * m1; + + if (*trans == 'N') { + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_ctgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale1, dsum, dscale, info1); + // C_T = C_T - A_TR * C_B + BLAS(cgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // F_T = F_T - D_TR * C_B + BLAS(cgemm)("N", "N", &m1, n, &m2, MONE, D_TR, ldD, C_B, ldC, scale1, F_T, ldF); + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_ctgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m2, n, F_B, ldF, info); + } + } else { + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_ctgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale1, dsum, dscale, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale1, &m2, n, F_B, ldF, info); + // C_B = C_B - A_TR^H * C_T + BLAS(cgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // C_B = C_B - D_TR^H * F_T + BLAS(cgemm)("C", "N", &m2, n, &m1, MONE, D_TR, ldD, F_T, ldC, ONE, C_B, ldC); + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_ctgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_T, ldC, info); + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m1, n, F_T, ldF, info); + } + } + } else { + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const float *const B_TL = B; + const float *const B_TR = B + 2 * *ldB * n1; + const float *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // C_L C_R + float *const C_L = C; + float *const C_R = C + 2 * *ldC * n1; + + // E_TL E_TR + // 0 E_BR + const float *const E_TL = E; + const float *const E_TR = E + 2 * *ldE * n1; + const float *const E_BR = E + 2 * *ldE * n1 + 2 * n1; + + // F_L F_R + float *const F_L = F; + float *const F_R = F + 2 * *ldF * n1; + + if (*trans == 'N') { + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_ctgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale1, dsum, dscale, info1); + // C_R = C_R + F_L * B_TR + BLAS(cgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, B_TR, ldB, scale1, C_R, ldC); + // F_R = F_R + F_L * E_TR + BLAS(cgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, E_TR, ldE, scale1, F_R, ldF); + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_ctgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n1, F_L, ldF, info); + } + } else { + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_ctgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale1, dsum, dscale, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale1, m, &n1, C_L, ldC, info); + // F_L = F_L + C_R * B_TR + BLAS(cgemm)("N", "C", m, &n1, &n2, ONE, C_R, ldC, B_TR, ldB, scale1, F_L, ldF); + // F_L = F_L + F_R * E_TR + BLAS(cgemm)("N", "C", m, &n1, &n2, ONE, F_R, ldF, E_TR, ldB, ONE, F_L, ldF); + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_ctgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n2, F_R, ldF, info); + } + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/ctrsyl.c b/relapack/src/ctrsyl.c new file mode 100644 index 0000000000..b548d5354d --- /dev/null +++ b/relapack/src/ctrsyl.c @@ -0,0 +1,163 @@ +#include "relapack.h" + +static void RELAPACK_ctrsyl_rec(const char *, const char *, const int *, + const int *, const int *, const float *, const int *, const float *, + const int *, float *, const int *, float *, int *); + + +/** CTRSYL solves the complex Sylvester matrix equation. + * + * This routine is functionally equivalent to LAPACK's ctrsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d8/df4/ctrsyl_8f.html + * */ +void RELAPACK_ctrsyl( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + + // Check arguments + const int notransA = LAPACK(lsame)(tranA, "N"); + const int ctransA = LAPACK(lsame)(tranA, "C"); + const int notransB = LAPACK(lsame)(tranB, "N"); + const int ctransB = LAPACK(lsame)(tranB, "C"); + *info = 0; + if (!ctransA && !notransA) + *info = -1; + else if (!ctransB && !notransB) + *info = -2; + else if (*isgn != 1 && *isgn != -1) + *info = -3; + else if (*m < 0) + *info = -4; + else if (*n < 0) + *info = -5; + else if (*ldA < MAX(1, *m)) + *info = -7; + else if (*ldB < MAX(1, *n)) + *info = -9; + else if (*ldC < MAX(1, *m)) + *info = -11; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CTRSYL", &minfo); + return; + } + + // Clean char * arguments + const char cleantranA = notransA ? 'N' : 'C'; + const char cleantranB = notransB ? 'N' : 'C'; + + // Recursive kernel + RELAPACK_ctrsyl_rec(&cleantranA, &cleantranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} + + +/** ctrsyl's recursive compute kernel */ +static void RELAPACK_ctrsyl_rec( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + + if (*m <= MAX(CROSSOVER_CTRSYL, 1) && *n <= MAX(CROSSOVER_CTRSYL, 1)) { + // Unblocked + RELAPACK_ctrsyl_rec2(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + const float MSGN[] = { -*isgn, 0. }; + const int iONE[] = { 1 }; + + // Outputs + float scale1[] = { 1., 0. }; + float scale2[] = { 1., 0. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + const int m1 = CREC_SPLIT(*m); + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const float *const A_TL = A; + const float *const A_TR = A + 2 * *ldA * m1; + const float *const A_BR = A + 2 * *ldA * m1 + 2 * m1; + + // C_T + // C_B + float *const C_T = C; + float *const C_B = C + 2 * m1; + + if (*tranA == 'N') { + // recusion(A_BR, B, C_B) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale1, info1); + // C_T = C_T - A_TR * C_B + BLAS(cgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // recusion(A_TL, B, C_T) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + } else { + // recusion(A_TL, B, C_T) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale1, info1); + // C_B = C_B - A_TR' * C_T + BLAS(cgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // recusion(A_BR, B, C_B) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_B, ldC, info); + } + } else { + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const float *const B_TL = B; + const float *const B_TR = B + 2 * *ldB * n1; + const float *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // C_L C_R + float *const C_L = C; + float *const C_R = C + 2 * *ldC * n1; + + if (*tranB == 'N') { + // recusion(A, B_TL, C_L) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale1, info1); + // C_R = C_R -/+ C_L * B_TR + BLAS(cgemm)("N", "N", m, &n2, &n1, MSGN, C_L, ldC, B_TR, ldB, scale1, C_R, ldC); + // recusion(A, B_BR, C_R) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + } else { + // recusion(A, B_BR, C_R) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale1, info1); + // C_L = C_L -/+ C_R * B_TR' + BLAS(cgemm)("N", "C", m, &n1, &n2, MSGN, C_R, ldC, B_TR, ldB, scale1, C_L, ldC); + // recusion(A, B_TL, C_L) + RELAPACK_ctrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(clascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/ctrsyl_rec2.c b/relapack/src/ctrsyl_rec2.c new file mode 100644 index 0000000000..518574868a --- /dev/null +++ b/relapack/src/ctrsyl_rec2.c @@ -0,0 +1,392 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "../config.h" +#include "f2c.h" + +#if BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES +complex cdotu_fun(int *n, complex *x, int *incx, complex *y, int *incy) { + extern void cdotu_(complex *, int *, complex *, int *, complex *, int *); + complex result; + cdotu_(&result, n, x, incx, y, incy); + return result; +} +#define cdotu_ cdotu_fun + +complex cdotc_fun(int *n, complex *x, int *incx, complex *y, int *incy) { + extern void cdotc_(complex *, int *, complex *, int *, complex *, int *); + complex result; + cdotc_(&result, n, x, incx, y, incy); + return result; +} +#define cdotc_ cdotc_fun +#endif + +#if LAPACK_BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES +complex cladiv_fun(complex *a, complex *b) { + extern void cladiv_(complex *, complex *, complex *); + complex result; + cladiv_(&result, a, b); + return result; +} +#define cladiv_ cladiv_fun +#endif + +/* Table of constant values */ + +static int c__1 = 1; + +/** RELAPACK_CTRSYL_REC2 solves the complex Sylvester matrix equation (unblocked algorithm) + * + * This routine is an exact copy of LAPACK's ctrsyl. + * It serves as an unblocked kernel in the recursive algorithms. + * */ +/* Subroutine */ void RELAPACK_ctrsyl_rec2(char *trana, char *tranb, int + *isgn, int *m, int *n, complex *a, int *lda, complex *b, + int *ldb, complex *c__, int *ldc, float *scale, int *info, + ftnlen trana_len, ftnlen tranb_len) +{ + /* System generated locals */ + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + float r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + float r_imag(complex *); + void r_cnjg(complex *, complex *); + + /* Local variables */ + static int j, k, l; + static complex a11; + static float db; + static complex x11; + static float da11; + static complex vec; + static float dum[1], eps, sgn, smin; + static complex suml, sumr; + /* Complex */ complex cdotc_(int *, complex *, int + *, complex *, int *); + extern int lsame_(char *, char *, ftnlen, ftnlen); + /* Complex */ complex cdotu_(int *, complex *, int + *, complex *, int *); + extern /* Subroutine */ int slabad_(float *, float *); + extern float clange_(char *, int *, int *, complex *, + int *, float *, ftnlen); + /* Complex */ complex cladiv_(complex *, complex *); + static float scaloc; + extern float slamch_(char *, ftnlen); + extern /* Subroutine */ int csscal_(int *, float *, complex *, int + *), xerbla_(char *, int *, ftnlen); + static float bignum; + static int notrna, notrnb; + static float smlnum; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N", (ftnlen)1, (ftnlen)1); + notrnb = lsame_(tranb, "N", (ftnlen)1, (ftnlen)1); + *info = 0; + if (! notrna && ! lsame_(trana, "C", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1,*m)) { + *info = -7; + } else if (*ldb < max(1,*n)) { + *info = -9; + } else if (*ldc < max(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CTRSY2", &i__1, (ftnlen)6); + return; + } + *scale = 1.f; + if (*m == 0 || *n == 0) { + return; + } + eps = slamch_("P", (ftnlen)1); + smlnum = slamch_("S", (ftnlen)1); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum = smlnum * (float) (*m * *n) / eps; + bignum = 1.f / smlnum; +/* Computing MAX */ + r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum, ( + ftnlen)1), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n, + &b[b_offset], ldb, dum, (ftnlen)1); + smin = dmax(r__1,r__2); + sgn = (float) (*isgn); + if (notrna && notrnb) { + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + for (k = *m; k >= 1; --k) { + i__2 = *m - k; +/* Computing MIN */ + i__3 = k + 1; +/* Computing MIN */ + i__4 = k + 1; + q__1 = cdotu_(&i__2, &a[k + min(i__3,*m) * a_dim1], lda, &c__[ + min(i__4,*m) + l * c_dim1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__2 = l - 1; + q__1 = cdotu_(&i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = q__1.r, sumr.i = q__1.i; + i__2 = k + l * c_dim1; + q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + scaloc = 1.f; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i; + q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), + dabs(r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + q__1 = cladiv_(&q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; +/* L20: */ + } +/* L30: */ + } + } else if (! notrna && notrnb) { + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k - 1; + q__1 = cdotc_(&i__3, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__3 = l - 1; + q__1 = cdotu_(&i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = q__1.r, sumr.i = q__1.i; + i__3 = k + l * c_dim1; + q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + scaloc = 1.f; + r_cnjg(&q__2, &a[k + k * a_dim1]); + i__3 = l + l * b_dim1; + q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), + dabs(r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + q__1 = cladiv_(&q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + i__3 = k + l * c_dim1; + c__[i__3].r = x11.r, c__[i__3].i = x11.i; +/* L50: */ + } +/* L60: */ + } + } else if (! notrna && ! notrnb) { + for (l = *n; l >= 1; --l) { + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + q__1 = cdotc_(&i__2, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__2 = *n - l; +/* Computing MIN */ + i__3 = l + 1; +/* Computing MIN */ + i__4 = l + 1; + q__1 = cdotc_(&i__2, &c__[k + min(i__3,*n) * c_dim1], ldc, &b[ + l + min(i__4,*n) * b_dim1], ldb); + sumr.r = q__1.r, sumr.i = q__1.i; + i__2 = k + l * c_dim1; + r_cnjg(&q__4, &sumr); + q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + scaloc = 1.f; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; + q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i; + r_cnjg(&q__1, &q__2); + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), + dabs(r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + q__1 = cladiv_(&q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; +/* L80: */ + } +/* L90: */ + } + } else if (notrna && ! notrnb) { + for (l = *n; l >= 1; --l) { + for (k = *m; k >= 1; --k) { + i__1 = *m - k; +/* Computing MIN */ + i__2 = k + 1; +/* Computing MIN */ + i__3 = k + 1; + q__1 = cdotu_(&i__1, &a[k + min(i__2,*m) * a_dim1], lda, &c__[ + min(i__3,*m) + l * c_dim1], &c__1); + suml.r = q__1.r, suml.i = q__1.i; + i__1 = *n - l; +/* Computing MIN */ + i__2 = l + 1; +/* Computing MIN */ + i__3 = l + 1; + q__1 = cdotc_(&i__1, &c__[k + min(i__2,*n) * c_dim1], ldc, &b[ + l + min(i__3,*n) * b_dim1], ldb); + sumr.r = q__1.r, sumr.i = q__1.i; + i__1 = k + l * c_dim1; + r_cnjg(&q__4, &sumr); + q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; + q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; + q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i; + vec.r = q__1.r, vec.i = q__1.i; + scaloc = 1.f; + i__1 = k + k * a_dim1; + r_cnjg(&q__3, &b[l + l * b_dim1]); + q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i; + q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i; + a11.r = q__1.r, a11.i = q__1.i; + da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), + dabs(r__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.f; + da11 = smin; + *info = 1; + } + db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( + r__2)); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + q__3.r = scaloc, q__3.i = 0.f; + q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * + q__3.i + vec.i * q__3.r; + q__1 = cladiv_(&q__2, &a11); + x11.r = q__1.r, x11.i = q__1.i; + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + i__1 = k + l * c_dim1; + c__[i__1].r = x11.r, c__[i__1].i = x11.i; +/* L110: */ + } +/* L120: */ + } + } + return; +} diff --git a/relapack/src/ctrtri.c b/relapack/src/ctrtri.c new file mode 100644 index 0000000000..0262cb59d9 --- /dev/null +++ b/relapack/src/ctrtri.c @@ -0,0 +1,107 @@ +#include "relapack.h" + +static void RELAPACK_ctrtri_rec(const char *, const char *, const int *, + float *, const int *, int *); + + +/** CTRTRI computes the inverse of a complex upper or lower triangular matrix A. + * + * This routine is functionally equivalent to LAPACK's ctrtri. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/df/df8/ctrtri_8f.html + * */ +void RELAPACK_ctrtri( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int nounit = LAPACK(lsame)(diag, "N"); + const int unit = LAPACK(lsame)(diag, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (!nounit && !unit) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("CTRTRI", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleandiag = nounit ? 'N' : 'U'; + + // check for singularity + if (nounit) { + int i; + for (i = 0; i < *n; i++) + if (A[2 * (i + *ldA * i)] == 0 && A[2 * (i + *ldA * i) + 1] == 0) { + *info = i; + return; + } + } + + // Recursive kernel + RELAPACK_ctrtri_rec(&cleanuplo, &cleandiag, n, A, ldA, info); +} + + +/** ctrtri's recursive compute kernel */ +static void RELAPACK_ctrtri_rec( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_CTRTRI, 1)) { + // Unblocked + LAPACK(ctrti2)(uplo, diag, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1., 0. }; + const float MONE[] = { -1., 0. }; + + // Splitting + const int n1 = CREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + 2 * *ldA * n1; + float *const A_BL = A + 2 * n1; + float *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_ctrtri_rec(uplo, diag, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = - A_BL * A_TL + BLAS(ctrmm)("R", "L", "N", diag, &n2, &n1, MONE, A_TL, ldA, A_BL, ldA); + // A_BL = A_BR \ A_BL + BLAS(ctrsm)("L", "L", "N", diag, &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TR = - A_TL * A_TR + BLAS(ctrmm)("L", "U", "N", diag, &n1, &n2, MONE, A_TL, ldA, A_TR, ldA); + // A_TR = A_TR / A_BR + BLAS(ctrsm)("R", "U", "N", diag, &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_ctrtri_rec(uplo, diag, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/dgbtrf.c b/relapack/src/dgbtrf.c new file mode 100644 index 0000000000..1a1757d311 --- /dev/null +++ b/relapack/src/dgbtrf.c @@ -0,0 +1,227 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_dgbtrf_rec(const int *, const int *, const int *, + const int *, double *, const int *, int *, double *, const int *, double *, + const int *, int *); + + +/** DGBTRF computes an LU factorization of a real m-by-n band matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's dgbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/da/d87/dgbtrf_8f.html + * */ +void RELAPACK_dgbtrf( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kl < 0) + *info = -3; + else if (*ku < 0) + *info = -4; + else if (*ldAb < 2 * *kl + *ku + 1) + *info = -6; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DGBTRF", &minfo); + return; + } + + // Constant + const double ZERO[] = { 0. }; + + // Result upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + kv; + + // Zero upper diagonal fill-in elements + int i, j; + for (j = 0; j < *n; j++) { + double *const A_j = A + *ldA * j; + for (i = MAX(0, j - kv); i < j - *ku; i++) + A_j[i] = 0.; + } + + // Allocate work space + const int n1 = DREC_SPLIT(*n); + const int mWorkl = (kv > n1) ? MAX(1, *m - *kl) : kv; + const int nWorkl = (kv > n1) ? n1 : kv; + const int mWorku = (*kl > n1) ? n1 : *kl; + const int nWorku = (*kl > n1) ? MAX(0, *n - *kl) : *kl; + double *Workl = malloc(mWorkl * nWorkl * sizeof(double)); + double *Worku = malloc(mWorku * nWorku * sizeof(double)); + LAPACK(dlaset)("L", &mWorkl, &nWorkl, ZERO, ZERO, Workl, &mWorkl); + LAPACK(dlaset)("U", &mWorku, &nWorku, ZERO, ZERO, Worku, &mWorku); + + // Recursive kernel + RELAPACK_dgbtrf_rec(m, n, kl, ku, Ab, ldAb, ipiv, Workl, &mWorkl, Worku, &mWorku, info); + + // Free work space + free(Workl); + free(Worku); +} + + +/** dgbtrf's recursive compute kernel */ +static void RELAPACK_dgbtrf_rec( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + double *Workl, const int *ldWorkl, double *Worku, const int *ldWorku, + int *info +) { + + if (*n <= MAX(CROSSOVER_DGBTRF, 1)) { + // Unblocked + LAPACK(dgbtf2)(m, n, kl, ku, Ab, ldAb, ipiv, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Loop iterators + int i, j; + + // Output upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + kv; + + // Splitting + const int n1 = MIN(DREC_SPLIT(*n), *kl); + const int n2 = *n - n1; + const int m1 = MIN(n1, *m); + const int m2 = *m - m1; + const int mn1 = MIN(m1, n1); + const int mn2 = MIN(m2, n2); + + // Ab_L * + // Ab_BR + double *const Ab_L = Ab; + double *const Ab_BR = Ab + *ldAb * n1; + + // A_L A_R + double *const A_L = A; + double *const A_R = A + *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + m1; + double *const A_BR = A + *ldA * n1 + m1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // Banded splitting + const int n21 = MIN(n2, kv - n1); + const int n22 = MIN(n2 - n21, n1); + const int m21 = MIN(m2, *kl - m1); + const int m22 = MIN(m2 - m21, m1); + + // n1 n21 n22 + // m * A_Rl ARr + double *const A_Rl = A_R; + double *const A_Rr = A_R + *ldA * n21; + + // n1 n21 n22 + // m1 * A_TRl A_TRr + // m21 A_BLt A_BRtl A_BRtr + // m22 A_BLb A_BRbl A_BRbr + double *const A_TRl = A_TR; + double *const A_TRr = A_TR + *ldA * n21; + double *const A_BLt = A_BL; + double *const A_BLb = A_BL + m21; + double *const A_BRtl = A_BR; + double *const A_BRtr = A_BR + *ldA * n21; + double *const A_BRbl = A_BR + m21; + double *const A_BRbr = A_BR + *ldA * n21 + m21; + + // recursion(Ab_L, ipiv_T) + RELAPACK_dgbtrf_rec(m, &n1, kl, ku, Ab_L, ldAb, ipiv_T, Workl, ldWorkl, Worku, ldWorku, info); + + // Workl = A_BLb + LAPACK(dlacpy)("U", &m22, &n1, A_BLb, ldA, Workl, ldWorkl); + + // partially redo swaps in A_L + for (i = 0; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(dswap)(&i, A_L + i, ldA, A_L + ip, ldA); + else + BLAS(dswap)(&i, A_L + i, ldA, Workl + ip - *kl, ldWorkl); + } + } + + // apply pivots to A_Rl + LAPACK(dlaswp)(&n21, A_Rl, ldA, iONE, &mn1, ipiv_T, iONE); + + // apply pivots to A_Rr columnwise + for (j = 0; j < n22; j++) { + double *const A_Rrj = A_Rr + *ldA * j; + for (i = j; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + const double tmp = A_Rrj[i]; + A_Rrj[i] = A_Rr[ip]; + A_Rrj[ip] = tmp; + } + } + } + + // A_TRl = A_TL \ A_TRl + BLAS(dtrsm)("L", "L", "N", "U", &m1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // Worku = A_TRr + LAPACK(dlacpy)("L", &m1, &n22, A_TRr, ldA, Worku, ldWorku); + // Worku = A_TL \ Worku + BLAS(dtrsm)("L", "L", "N", "U", &m1, &n22, ONE, A_TL, ldA, Worku, ldWorku); + // A_TRr = Worku + LAPACK(dlacpy)("L", &m1, &n22, Worku, ldWorku, A_TRr, ldA); + // A_BRtl = A_BRtl - A_BLt * A_TRl + BLAS(dgemm)("N", "N", &m21, &n21, &n1, MONE, A_BLt, ldA, A_TRl, ldA, ONE, A_BRtl, ldA); + // A_BRbl = A_BRbl - Workl * A_TRl + BLAS(dgemm)("N", "N", &m22, &n21, &n1, MONE, Workl, ldWorkl, A_TRl, ldA, ONE, A_BRbl, ldA); + // A_BRtr = A_BRtr - A_BLt * Worku + BLAS(dgemm)("N", "N", &m21, &n22, &n1, MONE, A_BLt, ldA, Worku, ldWorku, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Workl * Worku + BLAS(dgemm)("N", "N", &m22, &n22, &n1, MONE, Workl, ldWorkl, Worku, ldWorku, ONE, A_BRbr, ldA); + + // partially undo swaps in A_L + for (i = mn1 - 1; i >= 0; i--) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(dswap)(&i, A_L + i, ldA, A_L + ip, ldA); + else + BLAS(dswap)(&i, A_L + i, ldA, Workl + ip - *kl, ldWorkl); + } + } + + // recursion(Ab_BR, ipiv_B) + RELAPACK_dgbtrf_rec(&m2, &n2, kl, ku, Ab_BR, ldAb, ipiv_B, Workl, ldWorkl, Worku, ldWorku, info); + if (*info) + *info += n1; + // shift pivots + for (i = 0; i < mn2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/dgemmt.c b/relapack/src/dgemmt.c new file mode 100644 index 0000000000..9c925b5861 --- /dev/null +++ b/relapack/src/dgemmt.c @@ -0,0 +1,165 @@ +#include "relapack.h" + +static void RELAPACK_dgemmt_rec(const char *, const char *, const char *, + const int *, const int *, const double *, const double *, const int *, + const double *, const int *, const double *, double *, const int *); + +static void RELAPACK_dgemmt_rec2(const char *, const char *, const char *, + const int *, const int *, const double *, const double *, const int *, + const double *, const int *, const double *, double *, const int *); + + +/** DGEMMT computes a matrix-matrix product with general matrices but updates + * only the upper or lower triangular part of the result matrix. + * + * This routine performs the same operation as the BLAS routine + * dgemm(transA, transB, n, n, k, alpha, A, ldA, B, ldB, beta, C, ldC) + * but only updates the triangular part of C specified by uplo: + * If (*uplo == 'L'), only the lower triangular part of C is updated, + * otherwise the upper triangular part is updated. + * */ +void RELAPACK_dgemmt( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + +#if HAVE_XGEMMT + BLAS(dgemmt)(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; +#else + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int notransA = LAPACK(lsame)(transA, "N"); + const int tranA = LAPACK(lsame)(transA, "T"); + const int notransB = LAPACK(lsame)(transB, "N"); + const int tranB = LAPACK(lsame)(transB, "T"); + int info = 0; + if (!lower && !upper) + info = 1; + else if (!tranA && !notransA) + info = 2; + else if (!tranB && !notransB) + info = 3; + else if (*n < 0) + info = 4; + else if (*k < 0) + info = 5; + else if (*ldA < MAX(1, notransA ? *n : *k)) + info = 8; + else if (*ldB < MAX(1, notransB ? *k : *n)) + info = 10; + else if (*ldC < MAX(1, *n)) + info = 13; + if (info) { + LAPACK(xerbla)("DGEMMT", &info); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleantransA = notransA ? 'N' : 'T'; + const char cleantransB = notransB ? 'N' : 'T'; + + // Recursive kernel + RELAPACK_dgemmt_rec(&cleanuplo, &cleantransA, &cleantransB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); +#endif +} + + +/** dgemmt's recursive compute kernel */ +static void RELAPACK_dgemmt_rec( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + + if (*n <= MAX(CROSSOVER_DGEMMT, 1)) { + // Unblocked + RELAPACK_dgemmt_rec2(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; + } + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_T + // A_B + const double *const A_T = A; + const double *const A_B = A + ((*transA == 'N') ? n1 : *ldA * n1); + + // B_L B_R + const double *const B_L = B; + const double *const B_R = B + ((*transB == 'N') ? *ldB * n1 : n1); + + // C_TL C_TR + // C_BL C_BR + double *const C_TL = C; + double *const C_TR = C + *ldC * n1; + double *const C_BL = C + n1; + double *const C_BR = C + *ldC * n1 + n1; + + // recursion(C_TL) + RELAPACK_dgemmt_rec(uplo, transA, transB, &n1, k, alpha, A_T, ldA, B_L, ldB, beta, C_TL, ldC); + + if (*uplo == 'L') + // C_BL = alpha A_B B_L + beta C_BL + BLAS(dgemm)(transA, transB, &n2, &n1, k, alpha, A_B, ldA, B_L, ldB, beta, C_BL, ldC); + else + // C_TR = alpha A_T B_R + beta C_TR + BLAS(dgemm)(transA, transB, &n1, &n2, k, alpha, A_T, ldA, B_R, ldB, beta, C_TR, ldC); + + // recursion(C_BR) + RELAPACK_dgemmt_rec(uplo, transA, transB, &n2, k, alpha, A_B, ldA, B_R, ldB, beta, C_BR, ldC); +} + + +/** dgemmt's unblocked compute kernel */ +static void RELAPACK_dgemmt_rec2( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + + const int incB = (*transB == 'N') ? 1 : *ldB; + const int incC = 1; + + int i; + for (i = 0; i < *n; i++) { + // A_0 + // A_i + const double *const A_0 = A; + const double *const A_i = A + ((*transA == 'N') ? i : *ldA * i); + + // * B_i * + const double *const B_i = B + ((*transB == 'N') ? *ldB * i : i); + + // * C_0i * + // * C_ii * + double *const C_0i = C + *ldC * i; + double *const C_ii = C + *ldC * i + i; + + if (*uplo == 'L') { + const int nmi = *n - i; + if (*transA == 'N') + BLAS(dgemv)(transA, &nmi, k, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + else + BLAS(dgemv)(transA, k, &nmi, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + } else { + const int ip1 = i + 1; + if (*transA == 'N') + BLAS(dgemv)(transA, &ip1, k, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + else + BLAS(dgemv)(transA, k, &ip1, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + } + } +} diff --git a/relapack/src/dgetrf.c b/relapack/src/dgetrf.c new file mode 100644 index 0000000000..07f5472fd1 --- /dev/null +++ b/relapack/src/dgetrf.c @@ -0,0 +1,117 @@ +#include "relapack.h" + +static void RELAPACK_dgetrf_rec(const int *, const int *, double *, + const int *, int *, int *); + + +/** DGETRF computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's dgetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d3/d6a/dgetrf_8f.html + * */ +void RELAPACK_dgetrf( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DGETRF", &minfo); + return; + } + + const int sn = MIN(*m, *n); + + RELAPACK_dgetrf_rec(m, &sn, A, ldA, ipiv, info); + + // Right remainder + if (*m < *n) { + // Constants + const double ONE[] = { 1. }; + const int iONE[] = { 1. }; + + // Splitting + const int rn = *n - *m; + + // A_L A_R + const double *const A_L = A; + double *const A_R = A + *ldA * *m; + + // A_R = apply(ipiv, A_R) + LAPACK(dlaswp)(&rn, A_R, ldA, iONE, m, ipiv, iONE); + // A_R = A_S \ A_R + BLAS(dtrsm)("L", "L", "N", "U", m, &rn, ONE, A_L, ldA, A_R, ldA); + } +} + + +/** dgetrf's recursive compute kernel */ +static void RELAPACK_dgetrf_rec( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + + if (*n <= MAX(CROSSOVER_DGETRF, 1)) { + // Unblocked + LAPACK(dgetf2)(m, n, A, ldA, ipiv, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + const int m2 = *m - n1; + + // A_L A_R + double *const A_L = A; + double *const A_R = A + *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // recursion(A_L, ipiv_T) + RELAPACK_dgetrf_rec(m, &n1, A_L, ldA, ipiv_T, info); + // apply pivots to A_R + LAPACK(dlaswp)(&n2, A_R, ldA, iONE, &n1, ipiv_T, iONE); + + // A_TR = A_TL \ A_TR + BLAS(dtrsm)("L", "L", "N", "U", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_BL * A_TR + BLAS(dgemm)("N", "N", &m2, &n2, &n1, MONE, A_BL, ldA, A_TR, ldA, ONE, A_BR, ldA); + + // recursion(A_BR, ipiv_B) + RELAPACK_dgetrf_rec(&m2, &n2, A_BR, ldA, ipiv_B, info); + if (*info) + *info += n1; + // apply pivots to A_BL + LAPACK(dlaswp)(&n1, A_BL, ldA, iONE, &n2, ipiv_B, iONE); + // shift pivots + int i; + for (i = 0; i < n2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/dlauum.c b/relapack/src/dlauum.c new file mode 100644 index 0000000000..d722ea809f --- /dev/null +++ b/relapack/src/dlauum.c @@ -0,0 +1,87 @@ +#include "relapack.h" + +static void RELAPACK_dlauum_rec(const char *, const int *, double *, + const int *, int *); + + +/** DLAUUM computes the product U * U**T or L**T * L, where the triangular factor U or L is stored in the upper or lower triangular part of the array A. + * + * This routine is functionally equivalent to LAPACK's dlauum. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d0/dc2/dlauum_8f.html + * */ +void RELAPACK_dlauum( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DLAUUM", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_dlauum_rec(&cleanuplo, n, A, ldA, info); +} + + +/** dlauum's recursive compute kernel */ +static void RELAPACK_dlauum_rec( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_DLAUUM, 1)) { + // Unblocked + LAPACK(dlauu2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_dlauum_rec(uplo, &n1, A_TL, ldA, info); + + if (*uplo == 'L') { + // A_TL = A_TL + A_BL' * A_BL + BLAS(dsyrk)("L", "T", &n1, &n2, ONE, A_BL, ldA, ONE, A_TL, ldA); + // A_BL = A_BR' * A_BL + BLAS(dtrmm)("L", "L", "T", "N", &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TL = A_TL + A_TR * A_TR' + BLAS(dsyrk)("U", "N", &n1, &n2, ONE, A_TR, ldA, ONE, A_TL, ldA); + // A_TR = A_TR * A_BR' + BLAS(dtrmm)("R", "U", "T", "N", &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_dlauum_rec(uplo, &n2, A_BR, ldA, info); +} diff --git a/relapack/src/dpbtrf.c b/relapack/src/dpbtrf.c new file mode 100644 index 0000000000..6fd0ebe481 --- /dev/null +++ b/relapack/src/dpbtrf.c @@ -0,0 +1,157 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_dpbtrf_rec(const char *, const int *, const int *, + double *, const int *, double *, const int *, int *); + + +/** DPBTRF computes the Cholesky factorization of a real symmetric positive definite band matrix A. + * + * This routine is functionally equivalent to LAPACK's dpbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/df/da9/dpbtrf_8f.html + * */ +void RELAPACK_dpbtrf( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kd < 0) + *info = -3; + else if (*ldAb < *kd + 1) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DPBTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Constant + const double ZERO[] = { 0. }; + + // Allocate work space + const int n1 = DREC_SPLIT(*n); + const int mWork = (*kd > n1) ? (lower ? *n - *kd : n1) : *kd; + const int nWork = (*kd > n1) ? (lower ? n1 : *n - *kd) : *kd; + double *Work = malloc(mWork * nWork * sizeof(double)); + LAPACK(dlaset)(uplo, &mWork, &nWork, ZERO, ZERO, Work, &mWork); + + // Recursive kernel + RELAPACK_dpbtrf_rec(&cleanuplo, n, kd, Ab, ldAb, Work, &mWork, info); + + // Free work space + free(Work); +} + + +/** dpbtrf's recursive compute kernel */ +static void RELAPACK_dpbtrf_rec( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + double *Work, const int *ldWork, + int *info +){ + + if (*n <= MAX(CROSSOVER_DPBTRF, 1)) { + // Unblocked + LAPACK(dpbtf2)(uplo, n, kd, Ab, ldAb, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + ((*uplo == 'L') ? 0 : *kd); + + // Splitting + const int n1 = MIN(DREC_SPLIT(*n), *kd); + const int n2 = *n - n1; + + // * * + // * Ab_BR + double *const Ab_BR = Ab + *ldAb * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_dpotrf(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + // Banded splitting + const int n21 = MIN(n2, *kd - n1); + const int n22 = MIN(n2 - n21, n1); + + // n1 n21 n22 + // n1 * A_TRl A_TRr + // n21 A_BLt A_BRtl A_BRtr + // n22 A_BLb A_BRbl A_BRbr + double *const A_TRl = A_TR; + double *const A_TRr = A_TR + *ldA * n21; + double *const A_BLt = A_BL; + double *const A_BLb = A_BL + n21; + double *const A_BRtl = A_BR; + double *const A_BRtr = A_BR + *ldA * n21; + double *const A_BRbl = A_BR + n21; + double *const A_BRbr = A_BR + *ldA * n21 + n21; + + if (*uplo == 'L') { + // A_BLt = ABLt / A_TL' + BLAS(dtrsm)("R", "L", "T", "N", &n21, &n1, ONE, A_TL, ldA, A_BLt, ldA); + // A_BRtl = A_BRtl - A_BLt * A_BLt' + BLAS(dsyrk)("L", "N", &n21, &n1, MONE, A_BLt, ldA, ONE, A_BRtl, ldA); + // Work = A_BLb + LAPACK(dlacpy)("U", &n22, &n1, A_BLb, ldA, Work, ldWork); + // Work = Work / A_TL' + BLAS(dtrsm)("R", "L", "T", "N", &n22, &n1, ONE, A_TL, ldA, Work, ldWork); + // A_BRbl = A_BRbl - Work * A_BLt' + BLAS(dgemm)("N", "T", &n22, &n21, &n1, MONE, Work, ldWork, A_BLt, ldA, ONE, A_BRbl, ldA); + // A_BRbr = A_BRbr - Work * Work' + BLAS(dsyrk)("L", "N", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_BLb = Work + LAPACK(dlacpy)("U", &n22, &n1, Work, ldWork, A_BLb, ldA); + } else { + // A_TRl = A_TL' \ A_TRl + BLAS(dtrsm)("L", "U", "T", "N", &n1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // A_BRtl = A_BRtl - A_TRl' * A_TRl + BLAS(dsyrk)("U", "T", &n21, &n1, MONE, A_TRl, ldA, ONE, A_BRtl, ldA); + // Work = A_TRr + LAPACK(dlacpy)("L", &n1, &n22, A_TRr, ldA, Work, ldWork); + // Work = A_TL' \ Work + BLAS(dtrsm)("L", "U", "T", "N", &n1, &n22, ONE, A_TL, ldA, Work, ldWork); + // A_BRtr = A_BRtr - A_TRl' * Work + BLAS(dgemm)("T", "N", &n21, &n22, &n1, MONE, A_TRl, ldA, Work, ldWork, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Work' * Work + BLAS(dsyrk)("U", "T", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_TRr = Work + LAPACK(dlacpy)("L", &n1, &n22, Work, ldWork, A_TRr, ldA); + } + + // recursion(A_BR) + if (*kd > n1) + RELAPACK_dpotrf(uplo, &n2, A_BR, ldA, info); + else + RELAPACK_dpbtrf_rec(uplo, &n2, kd, Ab_BR, ldAb, Work, ldWork, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/dpotrf.c b/relapack/src/dpotrf.c new file mode 100644 index 0000000000..c14fb3d718 --- /dev/null +++ b/relapack/src/dpotrf.c @@ -0,0 +1,92 @@ +#include "relapack.h" + +static void RELAPACK_dpotrf_rec(const char *, const int *, double *, + const int *, int *); + + +/** DPOTRF computes the Cholesky factorization of a real symmetric positive definite matrix A. + * + * This routine is functionally equivalent to LAPACK's dpotrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d0/d8a/dpotrf_8f.html + * */ +void RELAPACK_dpotrf( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DPOTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_dpotrf_rec(&cleanuplo, n, A, ldA, info); +} + + +/** dpotrf's recursive compute kernel */ +static void RELAPACK_dpotrf_rec( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_DPOTRF, 1)) { + // Unblocked + LAPACK(dpotf2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_dpotrf_rec(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = A_BL / A_TL' + BLAS(dtrsm)("R", "L", "T", "N", &n2, &n1, ONE, A_TL, ldA, A_BL, ldA); + // A_BR = A_BR - A_BL * A_BL' + BLAS(dsyrk)("L", "N", &n2, &n1, MONE, A_BL, ldA, ONE, A_BR, ldA); + } else { + // A_TR = A_TL' \ A_TR + BLAS(dtrsm)("L", "U", "T", "N", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_TR' * A_TR + BLAS(dsyrk)("U", "T", &n2, &n1, MONE, A_TR, ldA, ONE, A_BR, ldA); + } + + // recursion(A_BR) + RELAPACK_dpotrf_rec(uplo, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/dsygst.c b/relapack/src/dsygst.c new file mode 100644 index 0000000000..0228068cef --- /dev/null +++ b/relapack/src/dsygst.c @@ -0,0 +1,212 @@ +#include "relapack.h" +#if XSYGST_ALLOW_MALLOC +#include "stdlib.h" +#endif + +static void RELAPACK_dsygst_rec(const int *, const char *, const int *, + double *, const int *, const double *, const int *, + double *, const int *, int *); + + +/** DSYGST reduces a real symmetric-definite generalized eigenproblem to standard form. + * + * This routine is functionally equivalent to LAPACK's dsygst. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dc/d04/dsygst_8f.html + * */ +void RELAPACK_dsygst( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (*itype < 1 || *itype > 3) + *info = -1; + else if (!lower && !upper) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + else if (*ldB < MAX(1, *n)) + *info = -7; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DSYGST", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Allocate work space + double *Work = NULL; + int lWork = 0; +#if XSYGST_ALLOW_MALLOC + const int n1 = DREC_SPLIT(*n); + lWork = n1 * (*n - n1); + Work = malloc(lWork * sizeof(double)); + if (!Work) + lWork = 0; +#endif + + // recursive kernel + RELAPACK_dsygst_rec(itype, &cleanuplo, n, A, ldA, B, ldB, Work, &lWork, info); + + // Free work space +#if XSYGST_ALLOW_MALLOC + if (Work) + free(Work); +#endif +} + + +/** dsygst's recursive compute kernel */ +static void RELAPACK_dsygst_rec( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + double *Work, const int *lWork, int *info +) { + + if (*n <= MAX(CROSSOVER_SSYGST, 1)) { + // Unblocked + LAPACK(dsygs2)(itype, uplo, n, A, ldA, B, ldB, info); + return; + } + + // Constants + const double ZERO[] = { 0. }; + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const double HALF[] = { .5 }; + const double MHALF[] = { -.5 }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // B_TL B_TR + // B_BL B_BR + const double *const B_TL = B; + const double *const B_TR = B + *ldB * n1; + const double *const B_BL = B + n1; + const double *const B_BR = B + *ldB * n1 + n1; + + // recursion(A_TL, B_TL) + RELAPACK_dsygst_rec(itype, uplo, &n1, A_TL, ldA, B_TL, ldB, Work, lWork, info); + + if (*itype == 1) + if (*uplo == 'L') { + // A_BL = A_BL / B_TL' + BLAS(dtrsm)("R", "L", "T", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * B_BL * A_TL + BLAS(dsymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(daxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + } else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(dsymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BR = A_BR - A_BL * B_BL' - B_BL * A_BL' + BLAS(dsyr2k)("L", "N", &n2, &n1, MONE, A_BL, ldA, B_BL, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(daxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(dsymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR \ A_BL + BLAS(dtrsm)("L", "L", "N", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL' \ A_TR + BLAS(dtrsm)("L", "U", "T", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * A_TL * B_TR + BLAS(dsymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(daxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + } else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(dsymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_BR = A_BR - A_TR' * B_TR - B_TR' * A_TR + BLAS(dsyr2k)("U", "T", &n2, &n1, MONE, A_TR, ldA, B_TR, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(daxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(dsymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR / B_BR + BLAS(dtrsm)("R", "U", "N", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + else + if (*uplo == 'L') { + // A_BL = A_BL * B_TL + BLAS(dtrmm)("R", "L", "N", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * A_BR * B_BL + BLAS(dsymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(daxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + } else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(dsymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_TL = A_TL + A_BL' * B_BL + B_BL' * A_BL + BLAS(dsyr2k)("L", "T", &n1, &n2, ONE, A_BL, ldA, B_BL, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(daxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(dsymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR * A_BL + BLAS(dtrmm)("L", "L", "T", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL * A_TR + BLAS(dtrmm)("L", "U", "N", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * B_TR * A_BR + BLAS(dsymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(daxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + } else + // A_TR = A_TR + 1/2 B_TR A_BR + BLAS(dsymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TL = A_TL + A_TR * B_TR' + B_TR * A_TR' + BLAS(dsyr2k)("U", "N", &n1, &n2, ONE, A_TR, ldA, B_TR, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(daxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + else + // A_TR = A_TR + 1/2 B_TR * A_BR + BLAS(dsymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR * B_BR + BLAS(dtrmm)("R", "U", "T", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + + // recursion(A_BR, B_BR) + RELAPACK_dsygst_rec(itype, uplo, &n2, A_BR, ldA, B_BR, ldB, Work, lWork, info); +} diff --git a/relapack/src/dsytrf.c b/relapack/src/dsytrf.c new file mode 100644 index 0000000000..80b119336a --- /dev/null +++ b/relapack/src/dsytrf.c @@ -0,0 +1,238 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_dsytrf_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** DSYTRF computes the factorization of a complex symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's dsytrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dd/df4/dsytrf_8f.html + * */ +void RELAPACK_dsytrf( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy arguments + int nout; + + // Recursive kernel + RELAPACK_dsytrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** dsytrf's recursive compute kernel */ +static void RELAPACK_dsytrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_DSYTRF, 3)) { + // Unblocked + if (top) { + LAPACK(dsytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_dsytrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = DREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_dsytrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + double *const A_BL_B = A + *n; + double *const A_BR_B = A + *ldA * n1 + *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + n1; + double *const Work_BR = top ? Work : Work + *ldWork * n1 + n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_dgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(dgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_dsytrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + *ldA * n2_out + n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(dgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = DREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_dsytrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + *ldA * n_rest; + double *const A_TR_T = A + *ldA * (n_rest + n1); + double *const A_TL = A + *ldA * n_rest + n_rest; + double *const A_TR = A + *ldA * (n_rest + n1) + n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + *ldWork * (top ? n2_diff : n1) + n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_dgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(dgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_dsytrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(dgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/dsytrf_rec2.c b/relapack/src/dsytrf_rec2.c new file mode 100644 index 0000000000..72ef827b16 --- /dev/null +++ b/relapack/src/dsytrf_rec2.c @@ -0,0 +1,352 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static double c_b8 = -1.; +static double c_b9 = 1.; + +/** DSYTRF_REC2 computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagon al pivoting method. + * + * This routine is a minor modification of LAPACK's dlasyf. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_dsytrf_rec2(char *uplo, int *n, int * + nb, int *kb, double *a, int *lda, int *ipiv, + double *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Builtin functions */ + double sqrt(double); + + /* Local variables */ + static int j, k; + static double t, r1, d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static double alpha; + extern /* Subroutine */ int dscal_(int *, double *, double *, + int *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemv_(char *, int *, int *, + double *, double *, int *, double *, int *, + double *, double *, int *, ftnlen), dcopy_(int *, + double *, int *, double *, int *), dswap_(int + *, double *, int *, double *, int *); + static int kstep; + static double absakk; + extern int idamax_(int *, double *, int *); + static double colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + kstep = 1; + absakk = (d__1 = w[k + kw * w_dim1], abs(d__1)); + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1], + abs(d__1)); + rowmax = max(d__2,d__3); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >= + alpha * rowmax) { + kp = imax; + dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kk - 1 - kp; + dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + dcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + dswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + r1 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + if (k > 2) { + d21 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d21; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) + * w_dim1] - w[j + kw * w_dim1]); + a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]); +/* L20: */ + } + } + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + i__1 = *n - k + 1; + dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1, (ftnlen)12); + kstep = 1; + absakk = (d__1 = w[k + k * w_dim1], abs(d__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (d__1 = w[imax + k * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1], + abs(d__1)); + rowmax = max(d__2,d__3); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >= + alpha * rowmax) { + kp = imax; + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + kk = k + kstep - 1; + if (kp != kk) { + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kp - kk - 1; + dcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + dswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + r1 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + if (k < *n - 1) { + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - + w[j + (k + 1) * w_dim1]); + a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]); +/* L80: */ + } + } + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/dsytrf_rook.c b/relapack/src/dsytrf_rook.c new file mode 100644 index 0000000000..19a875c7ad --- /dev/null +++ b/relapack/src/dsytrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_dsytrf_rook_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** DSYTRF_ROOK computes the factorization of a real symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's dsytrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/db/df4/dsytrf__rook_8f.html + * */ +void RELAPACK_dsytrf_rook( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_dsytrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** dsytrf_rook's recursive compute kernel */ +static void RELAPACK_dsytrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_DSYTRF_ROOK, 3)) { + // Unblocked + if (top) { + LAPACK(dsytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_dsytrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = DREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_dsytrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + double *const A_BL_B = A + *n; + double *const A_BR_B = A + *ldA * n1 + *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + n1; + double *const Work_BR = top ? Work : Work + *ldWork * n1 + n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_dgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(dgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_dsytrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + *ldA * n2_out + n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(dgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = DREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_dsytrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + *ldA * n_rest; + double *const A_TR_T = A + *ldA * (n_rest + n1); + double *const A_TL = A + *ldA * n_rest + n_rest; + double *const A_TR = A + *ldA * (n_rest + n1) + n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + *ldWork * (top ? n2_diff : n1) + n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_dgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(dgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_dsytrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(dgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/dsytrf_rook_rec2.c b/relapack/src/dsytrf_rook_rec2.c new file mode 100644 index 0000000000..105ef5ed3e --- /dev/null +++ b/relapack/src/dsytrf_rook_rec2.c @@ -0,0 +1,451 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static double c_b9 = -1.; +static double c_b10 = 1.; + +/** DSYTRF_ROOK_REC2 computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufma n ("rook") diagonal pivoting method. + * + * This routine is a minor modification of LAPACK's dlasyf. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_dsytrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, double *a, int *lda, int *ipiv, + double *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; + double d__1; + + /* Builtin functions */ + double sqrt(double); + + /* Local variables */ + static int j, k, p; + static double t, r1, d11, d12, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static double alpha; + extern /* Subroutine */ int dscal_(int *, double *, double *, + int *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int dgemv_(char *, int *, int *, + double *, double *, int *, double *, int *, + double *, double *, int *, ftnlen); + static double dtemp, sfmin; + static int itemp; + extern /* Subroutine */ int dcopy_(int *, double *, int *, + double *, int *), dswap_(int *, double *, int + *, double *, int *); + static int kstep; + extern double dlamch_(char *, ftnlen); + static double absakk; + extern int idamax_(int *, double *, int *); + static double colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + sfmin = dlamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b10, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + absakk = (d__1 = w[k + kw * w_dim1], abs(d__1)); + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b10, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + dtemp = (d__1 = w[itemp + (kw - 1) * w_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + if (! ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) < + alpha * rowmax)) { + kp = imax; + dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = k - p; + dcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + dcopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + i__1 = *n - k + 1; + dswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + dswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = k - 1 - kp; + dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + dcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = *n - kk + 1; + dswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + r1 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else if (a[k + k * a_dim1] != 0.) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L14: */ + } + } + } + } else { + if (k > 2) { + d12 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d12; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d12; + t = 1. / (d11 * d22 - 1.); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d12); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d12); +/* L20: */ + } + } + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + dswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + dswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = *n - k + 1; + dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b10, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + } + absakk = (d__1 = w[k + k * w_dim1], abs(d__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (d__1 = w[imax + k * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b10, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1)); + } else { + rowmax = 0.; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + dtemp = (d__1 = w[itemp + (k + 1) * w_dim1], abs(d__1)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + if (! ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) < alpha + * rowmax)) { + kp = imax; + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p - k; + dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + dcopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + dswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + dswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = kp - k - 1; + dcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + dcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + dswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + if ((d__1 = a[k + k * a_dim1], abs(d__1)) >= sfmin) { + r1 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else if (a[k + k * a_dim1] != 0.) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L74: */ + } + } + } + } else { + if (k < *n - 1) { + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); +/* L80: */ + } + } + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + dswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + dswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/dtgsyl.c b/relapack/src/dtgsyl.c new file mode 100644 index 0000000000..c506926af2 --- /dev/null +++ b/relapack/src/dtgsyl.c @@ -0,0 +1,274 @@ +#include "relapack.h" +#include + +static void RELAPACK_dtgsyl_rec(const char *, const int *, const int *, + const int *, const double *, const int *, const double *, const int *, + double *, const int *, const double *, const int *, const double *, + const int *, double *, const int *, double *, double *, double *, int *, + int *, int *); + + +/** DTGSYL solves the generalized Sylvester equation. + * + * This routine is functionally equivalent to LAPACK's dtgsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/db/d88/dtgsyl_8f.html + * */ +void RELAPACK_dtgsyl( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + + // Parse arguments + const int notran = LAPACK(lsame)(trans, "N"); + const int tran = LAPACK(lsame)(trans, "T"); + + // Compute work buffer size + int lwmin = 1; + if (notran && (*ijob == 1 || *ijob == 2)) + lwmin = MAX(1, 2 * *m * *n); + *info = 0; + + // Check arguments + if (!tran && !notran) + *info = -1; + else if (notran && (*ijob < 0 || *ijob > 4)) + *info = -2; + else if (*m <= 0) + *info = -3; + else if (*n <= 0) + *info = -4; + else if (*ldA < MAX(1, *m)) + *info = -6; + else if (*ldB < MAX(1, *n)) + *info = -8; + else if (*ldC < MAX(1, *m)) + *info = -10; + else if (*ldD < MAX(1, *m)) + *info = -12; + else if (*ldE < MAX(1, *n)) + *info = -14; + else if (*ldF < MAX(1, *m)) + *info = -16; + else if (*lWork < lwmin && *lWork != -1) + *info = -20; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DTGSYL", &minfo); + return; + } + + if (*lWork == -1) { + // Work size query + *Work = lwmin; + return; + } + + // Clean char * arguments + const char cleantrans = notran ? 'N' : 'T'; + + // Constant + const double ZERO[] = { 0. }; + + int isolve = 1; + int ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + LAPACK(dlaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(dlaset)("F", m, n, ZERO, ZERO, F, ldF); + } else if (*ijob >= 1) + isolve = 2; + } + + double scale2; + int iround; + for (iround = 1; iround <= isolve; iround++) { + *scale = 1; + double dscale = 0; + double dsum = 1; + int pq; + RELAPACK_dtgsyl_rec(&cleantrans, &ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, &dsum, &dscale, iWork, &pq, info); + if (dscale != 0) { + if (*ijob == 1 || *ijob == 3) + *dif = sqrt(2 * *m * *n) / (dscale * sqrt(dsum)); + else + *dif = sqrt(pq) / (dscale * sqrt(dsum)); + } + if (isolve == 2) { + if (iround == 1) { + if (notran) + ifunc = *ijob; + scale2 = *scale; + LAPACK(dlacpy)("F", m, n, C, ldC, Work, m); + LAPACK(dlacpy)("F", m, n, F, ldF, Work + *m * *n, m); + LAPACK(dlaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(dlaset)("F", m, n, ZERO, ZERO, F, ldF); + } else { + LAPACK(dlacpy)("F", m, n, Work, m, C, ldC); + LAPACK(dlacpy)("F", m, n, Work + *m * *n, m, F, ldF); + *scale = scale2; + } + } + } +} + + +/** dtgsyl's recursive vompute kernel */ +static void RELAPACK_dtgsyl_rec( + const char *trans, const int *ifunc, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dsum, double *dscale, + int *iWork, int *pq, int *info +) { + + if (*m <= MAX(CROSSOVER_DTGSYL, 1) && *n <= MAX(CROSSOVER_DTGSYL, 1)) { + // Unblocked + LAPACK(dtgsy2)(trans, ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dsum, dscale, iWork, pq, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Outputs + double scale1[] = { 1. }; + double scale2[] = { 1. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + int m1 = DREC_SPLIT(*m); + if (A[m1 + *ldA * (m1 - 1)]) + m1++; + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const double *const A_TL = A; + const double *const A_TR = A + *ldA * m1; + const double *const A_BR = A + *ldA * m1 + m1; + + // C_T + // C_B + double *const C_T = C; + double *const C_B = C + m1; + + // D_TL D_TR + // 0 D_BR + const double *const D_TL = D; + const double *const D_TR = D + *ldD * m1; + const double *const D_BR = D + *ldD * m1 + m1; + + // F_T + // F_B + double *const F_T = F; + double *const F_B = F + m1; + + if (*trans == 'N') { + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_dtgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale1, dsum, dscale, iWork, pq, info1); + // C_T = C_T - A_TR * C_B + BLAS(dgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // F_T = F_T - D_TR * C_B + BLAS(dgemm)("N", "N", &m1, n, &m2, MONE, D_TR, ldD, C_B, ldC, scale1, F_T, ldF); + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_dtgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m2, n, F_B, ldF, info); + } + } else { + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_dtgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale1, dsum, dscale, iWork, pq, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale1, &m2, n, F_B, ldF, info); + // C_B = C_B - A_TR^H * C_T + BLAS(dgemm)("T", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // C_B = C_B - D_TR^H * F_T + BLAS(dgemm)("T", "N", &m2, n, &m1, MONE, D_TR, ldD, F_T, ldC, ONE, C_B, ldC); + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_dtgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_T, ldC, info); + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m1, n, F_T, ldF, info); + } + } + } else { + // Splitting + int n1 = DREC_SPLIT(*n); + if (B[n1 + *ldB * (n1 - 1)]) + n1++; + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const double *const B_TL = B; + const double *const B_TR = B + *ldB * n1; + const double *const B_BR = B + *ldB * n1 + n1; + + // C_L C_R + double *const C_L = C; + double *const C_R = C + *ldC * n1; + + // E_TL E_TR + // 0 E_BR + const double *const E_TL = E; + const double *const E_TR = E + *ldE * n1; + const double *const E_BR = E + *ldE * n1 + n1; + + // F_L F_R + double *const F_L = F; + double *const F_R = F + *ldF * n1; + + if (*trans == 'N') { + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_dtgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale1, dsum, dscale, iWork, pq, info1); + // C_R = C_R + F_L * B_TR + BLAS(dgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, B_TR, ldB, scale1, C_R, ldC); + // F_R = F_R + F_L * E_TR + BLAS(dgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, E_TR, ldE, scale1, F_R, ldF); + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_dtgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n1, F_L, ldF, info); + } + } else { + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_dtgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale1, dsum, dscale, iWork, pq, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale1, m, &n1, C_L, ldC, info); + // F_L = F_L + C_R * B_TR + BLAS(dgemm)("N", "T", m, &n1, &n2, ONE, C_R, ldC, B_TR, ldB, scale1, F_L, ldF); + // F_L = F_L + F_R * E_TR + BLAS(dgemm)("N", "T", m, &n1, &n2, ONE, F_R, ldF, E_TR, ldB, ONE, F_L, ldF); + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_dtgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n2, F_R, ldF, info); + } + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/dtrsyl.c b/relapack/src/dtrsyl.c new file mode 100644 index 0000000000..c87b53ae52 --- /dev/null +++ b/relapack/src/dtrsyl.c @@ -0,0 +1,169 @@ +#include "relapack.h" + +static void RELAPACK_dtrsyl_rec(const char *, const char *, const int *, + const int *, const int *, const double *, const int *, const double *, + const int *, double *, const int *, double *, int *); + + +/** DTRSYL solves the real Sylvester matrix equation. + * + * This routine is functionally equivalent to LAPACK's dtrsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d6/d43/dtrsyl_8f.html + * */ +void RELAPACK_dtrsyl( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + + // Check arguments + const int notransA = LAPACK(lsame)(tranA, "N"); + const int transA = LAPACK(lsame)(tranA, "T"); + const int ctransA = LAPACK(lsame)(tranA, "C"); + const int notransB = LAPACK(lsame)(tranB, "N"); + const int transB = LAPACK(lsame)(tranB, "T"); + const int ctransB = LAPACK(lsame)(tranB, "C"); + *info = 0; + if (!transA && !ctransA && !notransA) + *info = -1; + else if (!transB && !ctransB && !notransB) + *info = -2; + else if (*isgn != 1 && *isgn != -1) + *info = -3; + else if (*m < 0) + *info = -4; + else if (*n < 0) + *info = -5; + else if (*ldA < MAX(1, *m)) + *info = -7; + else if (*ldB < MAX(1, *n)) + *info = -9; + else if (*ldC < MAX(1, *m)) + *info = -11; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DTRSYL", &minfo); + return; + } + + // Clean char * arguments + const char cleantranA = notransA ? 'N' : (transA ? 'T' : 'C'); + const char cleantranB = notransB ? 'N' : (transB ? 'T' : 'C'); + + // Recursive kernel + RELAPACK_dtrsyl_rec(&cleantranA, &cleantranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} + + +/** dtrsyl's recursive compute kernel */ +static void RELAPACK_dtrsyl_rec( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + + if (*m <= MAX(CROSSOVER_DTRSYL, 1) && *n <= MAX(CROSSOVER_DTRSYL, 1)) { + // Unblocked + RELAPACK_dtrsyl_rec2(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + const double MSGN[] = { -*isgn }; + const int iONE[] = { 1 }; + + // Outputs + double scale1[] = { 1. }; + double scale2[] = { 1. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + int m1 = DREC_SPLIT(*m); + if (A[m1 + *ldA * (m1 - 1)]) + m1++; + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const double *const A_TL = A; + const double *const A_TR = A + *ldA * m1; + const double *const A_BR = A + *ldA * m1 + m1; + + // C_T + // C_B + double *const C_T = C; + double *const C_B = C + m1; + + if (*tranA == 'N') { + // recusion(A_BR, B, C_B) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale1, info1); + // C_T = C_T - A_TR * C_B + BLAS(dgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // recusion(A_TL, B, C_T) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + } else { + // recusion(A_TL, B, C_T) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale1, info1); + // C_B = C_B - A_TR' * C_T + BLAS(dgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // recusion(A_BR, B, C_B) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_B, ldC, info); + } + } else { + // Splitting + int n1 = DREC_SPLIT(*n); + if (B[n1 + *ldB * (n1 - 1)]) + n1++; + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const double *const B_TL = B; + const double *const B_TR = B + *ldB * n1; + const double *const B_BR = B + *ldB * n1 + n1; + + // C_L C_R + double *const C_L = C; + double *const C_R = C + *ldC * n1; + + if (*tranB == 'N') { + // recusion(A, B_TL, C_L) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale1, info1); + // C_R = C_R -/+ C_L * B_TR + BLAS(dgemm)("N", "N", m, &n2, &n1, MSGN, C_L, ldC, B_TR, ldB, scale1, C_R, ldC); + // recusion(A, B_BR, C_R) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + } else { + // recusion(A, B_BR, C_R) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale1, info1); + // C_L = C_L -/+ C_R * B_TR' + BLAS(dgemm)("N", "C", m, &n1, &n2, MSGN, C_R, ldC, B_TR, ldB, scale1, C_L, ldC); + // recusion(A, B_TL, C_L) + RELAPACK_dtrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(dlascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/dtrsyl_rec2.c b/relapack/src/dtrsyl_rec2.c new file mode 100644 index 0000000000..479c7f340a --- /dev/null +++ b/relapack/src/dtrsyl_rec2.c @@ -0,0 +1,1034 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static int c_false = FALSE_; +static int c__2 = 2; +static double c_b26 = 1.; +static double c_b30 = 0.; +static int c_true = TRUE_; + +int RELAPACK_dtrsyl_rec2(char *trana, char *tranb, int *isgn, int + *m, int *n, double *a, int *lda, double *b, int * + ldb, double *c__, int *ldc, double *scale, int *info, + ftnlen trana_len, ftnlen tranb_len) +{ + /* System generated locals */ + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + double d__1, d__2; + + /* Local variables */ + static int j, k, l; + static double x[4] /* was [2][2] */; + static int k1, k2, l1, l2; + static double a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, + sgn; + extern double ddot_(int *, double *, int *, double *, + int *); + static int ierr; + static double smin, suml, sumr; + extern /* Subroutine */ int dscal_(int *, double *, double *, + int *); + extern int lsame_(char *, char *, ftnlen, ftnlen); + static int knext, lnext; + static double xnorm; + extern /* Subroutine */ int dlaln2_(int *, int *, int *, + double *, double *, double *, int *, double *, + double *, double *, int *, double *, double * + , double *, int *, double *, double *, int *), + dlasy2_(int *, int *, int *, int *, int *, + double *, int *, double *, int *, double *, + int *, double *, double *, int *, double *, + int *), dlabad_(double *, double *); + extern double dlamch_(char *, ftnlen), dlange_(char *, int *, + int *, double *, int *, double *, ftnlen); + static double scaloc; + extern /* Subroutine */ int xerbla_(char *, int *, ftnlen); + static double bignum; + static int notrna, notrnb; + static double smlnum; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N", (ftnlen)1, (ftnlen)1); + notrnb = lsame_(tranb, "N", (ftnlen)1, (ftnlen)1); + *info = 0; + if (! notrna && ! lsame_(trana, "T", (ftnlen)1, (ftnlen)1) && ! lsame_( + trana, "C", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "T", (ftnlen)1, (ftnlen)1) && ! + lsame_(tranb, "C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1,*m)) { + *info = -7; + } else if (*ldb < max(1,*n)) { + *info = -9; + } else if (*ldc < max(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSYL", &i__1, (ftnlen)6); + return 0; + } + *scale = 1.; + if (*m == 0 || *n == 0) { + return 0; + } + eps = dlamch_("P", (ftnlen)1); + smlnum = dlamch_("S", (ftnlen)1); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = smlnum * (double) (*m * *n) / eps; + bignum = 1. / smlnum; +/* Computing MAX */ + d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum, ( + ftnlen)1), d__1 = max(d__1,d__2), d__2 = eps * dlange_("M", n, n, + &b[b_offset], ldb, dum, (ftnlen)1); + smin = max(d__1,d__2); + sgn = (double) (*isgn); + if (notrna && notrnb) { + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L60; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L50; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + if (l1 == l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L20: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L30: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + + k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, + &c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L50: + ; + } +L60: + ; + } + } else if (! notrna && notrnb) { + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L120; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + knext = 1; + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (k < knext) { + goto L110; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + if (l1 == l2 && k1 == k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L80: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L110: + ; + } +L120: + ; + } + } else if (! notrna && ! notrnb) { + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L180; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + knext = 1; + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + if (k < knext) { + goto L170; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + if (l1 == l2 && k1 == k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l1; +/* Computing MIN */ + i__3 = l1 + 1; +/* Computing MIN */ + i__4 = l1 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * + a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L160: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L170: + ; + } +L180: + ; + } + } else if (notrna && ! notrnb) { + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L240; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L230; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + if (l1 == l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l1; +/* Computing MIN */ + i__2 = l1 + 1; +/* Computing MIN */ + i__3 = l1 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L200: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L210: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L220: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L230: + ; + } +L240: + ; + } + } + return 0; +} diff --git a/relapack/src/dtrtri.c b/relapack/src/dtrtri.c new file mode 100644 index 0000000000..0462609e9e --- /dev/null +++ b/relapack/src/dtrtri.c @@ -0,0 +1,107 @@ +#include "relapack.h" + +static void RELAPACK_dtrtri_rec(const char *, const char *, const int *, + double *, const int *, int *); + + +/** DTRTRI computes the inverse of a real upper or lower triangular matrix A. + * + * This routine is functionally equivalent to LAPACK's dtrtri. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d5/dba/dtrtri_8f.html + * */ +void RELAPACK_dtrtri( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int nounit = LAPACK(lsame)(diag, "N"); + const int unit = LAPACK(lsame)(diag, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (!nounit && !unit) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("DTRTRI", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleandiag = nounit ? 'N' : 'U'; + + // check for singularity + if (nounit) { + int i; + for (i = 0; i < *n; i++) + if (A[i + *ldA * i] == 0) { + *info = i; + return; + } + } + + // Recursive kernel + RELAPACK_dtrtri_rec(&cleanuplo, &cleandiag, n, A, ldA, info); +} + + +/** dtrtri's recursive compute kernel */ +static void RELAPACK_dtrtri_rec( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_DTRTRI, 1)) { + // Unblocked + LAPACK(dtrti2)(uplo, diag, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + + // Splitting + const int n1 = DREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + *ldA * n1; + double *const A_BL = A + n1; + double *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_dtrtri_rec(uplo, diag, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = - A_BL * A_TL + BLAS(dtrmm)("R", "L", "N", diag, &n2, &n1, MONE, A_TL, ldA, A_BL, ldA); + // A_BL = A_BR \ A_BL + BLAS(dtrsm)("L", "L", "N", diag, &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TR = - A_TL * A_TR + BLAS(dtrmm)("L", "U", "N", diag, &n1, &n2, MONE, A_TL, ldA, A_TR, ldA); + // A_TR = A_TR / A_BR + BLAS(dtrsm)("R", "U", "N", diag, &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_dtrtri_rec(uplo, diag, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/f2c.c b/relapack/src/f2c.c new file mode 100644 index 0000000000..5a34524191 --- /dev/null +++ b/relapack/src/f2c.c @@ -0,0 +1,109 @@ +#include "stdlib.h" +#include "stdio.h" +#include "signal.h" +#include "f2c.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +void sig_die(const char *s, int kill) { + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) { + fflush(stderr); + /* now get a core */ + signal(SIGIOT, SIG_DFL); + abort(); + } else + exit(1); +} + +void c_div(complex *c, complex *a, complex *b) { + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + float af, bf; + af = bf = abr; + if (a->i != 0 || a->r != 0) + af = 1.; + c->i = c->r = af / bf; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } else { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; +} + +void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) { + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + if (a->i != 0 || a->r != 0) + abi = 1.; + c->i = c->r = abi / abr; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } else { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; +} + +float r_imag(complex *z) { + return z->i; +} + +void r_cnjg(complex *r, complex *z) { + float zi = z->i; + r->r = z->r; + r->i = -zi; +} + +double d_imag(doublecomplex *z) { + return z->i; +} + +void d_cnjg(doublecomplex *r, doublecomplex *z) { + double zi = z->i; + r->r = z->r; + r->i = -zi; +} diff --git a/relapack/src/f2c.h b/relapack/src/f2c.h new file mode 100644 index 0000000000..b94ee7c8e1 --- /dev/null +++ b/relapack/src/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/relapack/src/lapack.h b/relapack/src/lapack.h new file mode 100644 index 0000000000..064276b7e0 --- /dev/null +++ b/relapack/src/lapack.h @@ -0,0 +1,80 @@ +#ifndef LAPACK_H +#define LAPACK_H + +extern int LAPACK(lsame)(const char *, const char *); +extern int LAPACK(xerbla)(const char *, const int *); + +extern void LAPACK(slaswp)(const int *, float *, const int *, const int *, const int *, const int *, const int *); +extern void LAPACK(dlaswp)(const int *, double *, const int *, const int *, const int *, const int *, const int *); +extern void LAPACK(claswp)(const int *, float *, const int *, const int *, const int *, const int *, const int *); +extern void LAPACK(zlaswp)(const int *, double *, const int *, const int *, const int *, const int *, const int *); + +extern void LAPACK(slaset)(const char *, const int *, const int *, const float *, const float *, float *, const int *); +extern void LAPACK(dlaset)(const char *, const int *, const int *, const double *, const double *, double *, const int *); +extern void LAPACK(claset)(const char *, const int *, const int *, const float *, const float *, float *, const int *); +extern void LAPACK(zlaset)(const char *, const int *, const int *, const double *, const double *, double *, const int *); + +extern void LAPACK(slacpy)(const char *, const int *, const int *, const float *, const int *, float *, const int *); +extern void LAPACK(dlacpy)(const char *, const int *, const int *, const double *, const int *, double *, const int *); +extern void LAPACK(clacpy)(const char *, const int *, const int *, const float *, const int *, float *, const int *); +extern void LAPACK(zlacpy)(const char *, const int *, const int *, const double *, const int *, double *, const int *); + +extern void LAPACK(slascl)(const char *, const int *, const int *, const float *, const float *, const int *, const int *, float *, const int *, int *); +extern void LAPACK(dlascl)(const char *, const int *, const int *, const double *, const double *, const int *, const int *, double *, const int *, int *); +extern void LAPACK(clascl)(const char *, const int *, const int *, const float *, const float *, const int *, const int *, float *, const int *, int *); +extern void LAPACK(zlascl)(const char *, const int *, const int *, const double *, const double *, const int *, const int *, double *, const int *, int *); + +extern void LAPACK(slauu2)(const char *, const int *, float *, const int *, int *); +extern void LAPACK(dlauu2)(const char *, const int *, double *, const int *, int *); +extern void LAPACK(clauu2)(const char *, const int *, float *, const int *, int *); +extern void LAPACK(zlauu2)(const char *, const int *, double *, const int *, int *); + +extern void LAPACK(ssygs2)(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +extern void LAPACK(dsygs2)(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); +extern void LAPACK(chegs2)(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +extern void LAPACK(zhegs2)(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); + +extern void LAPACK(strti2)(const char *, const char *, const int *, float *, const int *, int *); +extern void LAPACK(dtrti2)(const char *, const char *, const int *, double *, const int *, int *); +extern void LAPACK(ctrti2)(const char *, const char *, const int *, float *, const int *, int *); +extern void LAPACK(ztrti2)(const char *, const char *, const int *, double *, const int *, int *); + +extern void LAPACK(spotf2)(const char *, const int *, float *, const int *, int *); +extern void LAPACK(dpotf2)(const char *, const int *, double *, const int *, int *); +extern void LAPACK(cpotf2)(const char *, const int *, float *, const int *, int *); +extern void LAPACK(zpotf2)(const char *, const int *, double *, const int *, int *); + +extern void LAPACK(spbtf2)(const char *, const int *, const int *, float *, const int *, int *); +extern void LAPACK(dpbtf2)(const char *, const int *, const int *, double *, const int *, int *); +extern void LAPACK(cpbtf2)(const char *, const int *, const int *, float *, const int *, int *); +extern void LAPACK(zpbtf2)(const char *, const int *, const int *, double *, const int *, int *); + +extern void LAPACK(ssytf2)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(dsytf2)(const char *, const int *, double *, const int *, int *, int *); +extern void LAPACK(csytf2)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(chetf2)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(zsytf2)(const char *, const int *, double *, const int *, int *, int *); +extern void LAPACK(zhetf2)(const char *, const int *, double *, const int *, int *, int *); +extern void LAPACK(ssytf2_rook)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(dsytf2_rook)(const char *, const int *, double *, const int *, int *, int *); +extern void LAPACK(csytf2_rook)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(chetf2_rook)(const char *, const int *, float *, const int *, int *, int *); +extern void LAPACK(zsytf2_rook)(const char *, const int *, double *, const int *, int *, int *); +extern void LAPACK(zhetf2_rook)(const char *, const int *, double *, const int *, int *, int *); + +extern void LAPACK(sgetf2)(const int *, const int *, float *, const int *, int *, int *); +extern void LAPACK(dgetf2)(const int *, const int *, double *, const int *, int *, int *); +extern void LAPACK(cgetf2)(const int *, const int *, float *, const int *, int *, int *); +extern void LAPACK(zgetf2)(const int *, const int *, double *, const int *, int *, int *); + +extern void LAPACK(sgbtf2)(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +extern void LAPACK(dgbtf2)(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); +extern void LAPACK(cgbtf2)(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +extern void LAPACK(zgbtf2)(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); + +extern void LAPACK(stgsy2)(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, int *, int *, int *); +extern void LAPACK(dtgsy2)(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, int *, int *, int *); +extern void LAPACK(ctgsy2)(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, int *); +extern void LAPACK(ztgsy2)(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, int *); + +#endif /* LAPACK_H */ diff --git a/relapack/src/lapack_wrappers.c b/relapack/src/lapack_wrappers.c new file mode 100644 index 0000000000..4885472603 --- /dev/null +++ b/relapack/src/lapack_wrappers.c @@ -0,0 +1,607 @@ +#include "relapack.h" + +//////////// +// XLAUUM // +//////////// + +#if INCLUDE_SLAUUM +void LAPACK(slauum)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_slauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DLAUUM +void LAPACK(dlauum)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dlauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CLAUUM +void LAPACK(clauum)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_clauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZLAUUM +void LAPACK(zlauum)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_zlauum(uplo, n, A, ldA, info); +} +#endif + + +//////////// +// XSYGST // +//////////// + +#if INCLUDE_SSYGST +void LAPACK(ssygst)( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + RELAPACK_ssygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_DSYGST +void LAPACK(dsygst)( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + RELAPACK_dsygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_CHEGST +void LAPACK(chegst)( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + RELAPACK_chegst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_ZHEGST +void LAPACK(zhegst)( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + RELAPACK_zhegst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + + +//////////// +// XTRTRI // +//////////// + +#if INCLUDE_STRTRI +void LAPACK(strtri)( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_strtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_DTRTRI +void LAPACK(dtrtri)( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dtrtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_CTRTRI +void LAPACK(ctrtri)( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_ctrtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZTRTRI +void LAPACK(ztrtri)( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_ztrtri(uplo, diag, n, A, ldA, info); +} +#endif + + +//////////// +// XPOTRF // +//////////// + +#if INCLUDE_SPOTRF +void LAPACK(spotrf)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_spotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DPOTRF +void LAPACK(dpotrf)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dpotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CPOTRF +void LAPACK(cpotrf)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_cpotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZPOTRF +void LAPACK(zpotrf)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_zpotrf(uplo, n, A, ldA, info); +} +#endif + + +//////////// +// XPBTRF // +//////////// + +#if INCLUDE_SPBTRF +void LAPACK(spbtrf)( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + RELAPACK_spbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_DPBTRF +void LAPACK(dpbtrf)( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + RELAPACK_dpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_CPBTRF +void LAPACK(cpbtrf)( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + RELAPACK_cpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_ZPBTRF +void LAPACK(zpbtrf)( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + RELAPACK_zpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + + +//////////// +// XSYTRF // +//////////// + +#if INCLUDE_SSYTRF +void LAPACK(ssytrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_ssytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_DSYTRF +void LAPACK(dsytrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_dsytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CSYTRF +void LAPACK(csytrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_csytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZSYTRF +void LAPACK(zsytrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zsytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CHETRF +void LAPACK(chetrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_chetrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZHETRF +void LAPACK(zhetrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zhetrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_SSYTRF_ROOK +void LAPACK(ssytrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_ssytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_DSYTRF_ROOK +void LAPACK(dsytrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_dsytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CSYTRF_ROOK +void LAPACK(csytrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_csytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZSYTRF_ROOK +void LAPACK(zsytrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zsytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CHETRF_ROOK +void LAPACK(chetrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_chetrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZHETRF_ROOK +void LAPACK(zhetrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zhetrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + + +//////////// +// XGETRF // +//////////// + +#if INCLUDE_SGETRF +void LAPACK(sgetrf)( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_sgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_DGETRF +void LAPACK(dgetrf)( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_dgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_CGETRF +void LAPACK(cgetrf)( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_cgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_ZGETRF +void LAPACK(zgetrf)( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_zgetrf(m, n, A, ldA, ipiv, info); +} +#endif + + +//////////// +// XGBTRF // +//////////// + +#if INCLUDE_SGBTRF +void LAPACK(sgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_sgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_DGBTRF +void LAPACK(dgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_dgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_CGBTRF +void LAPACK(cgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_cgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_ZGBTRF +void LAPACK(zgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_zgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + + +//////////// +// XTRSYL // +//////////// + +#if INCLUDE_STRSYL +void LAPACK(strsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + RELAPACK_strsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_DTRSYL +void LAPACK(dtrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + RELAPACK_dtrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_CTRSYL +void LAPACK(ctrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + RELAPACK_ctrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_ZTRSYL +void LAPACK(ztrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + RELAPACK_ztrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + + +//////////// +// XTGSYL // +//////////// + +#if INCLUDE_STGSYL +void LAPACK(stgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_stgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_DTGSYL +void LAPACK(dtgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_dtgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_CTGSYL +void LAPACK(ctgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_ctgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_ZTGSYL +void LAPACK(ztgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_ztgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + + +//////////// +// XGEMMT // +//////////// + +#if INCLUDE_SGEMMT +void LAPACK(sgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + RELAPACK_sgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DGEMMT +void LAPACK(dgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + RELAPACK_dgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CGEMMT +void LAPACK(cgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + RELAPACK_cgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZGEMMT +void LAPACK(zgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + RELAPACK_zgemmt(uplo, n, A, ldA, info); +} +#endif diff --git a/relapack/src/lapack_wrappers.c.orig b/relapack/src/lapack_wrappers.c.orig new file mode 100644 index 0000000000..d89d2fe2f6 --- /dev/null +++ b/relapack/src/lapack_wrappers.c.orig @@ -0,0 +1,607 @@ +#include "relapack.h" + +//////////// +// XLAUUM // +//////////// + +#if INCLUDE_SLAUUM +void LAPACK(slauum)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_slauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DLAUUM +void LAPACK(dlauum)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dlauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CLAUUM +void LAPACK(clauum)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_clauum(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZLAUUM +void LAPACK(zlauum)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_zlauum(uplo, n, A, ldA, info); +} +#endif + + +//////////// +// XSYGST // +//////////// + +#if INCLUDE_SSYGST +void LAPACK(ssygst)( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + RELAPACK_ssygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_DSYGST +void LAPACK(dsygst)( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + RELAPACK_dsygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_CSYGST +void LAPACK(csygst)( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + RELAPACK_csygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + +#if INCLUDE_ZSYGST +void LAPACK(zsygst)( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + RELAPACK_zsygst(itype, uplo, n, A, ldA, B, ldB, info); +} +#endif + + +//////////// +// XTRTRI // +//////////// + +#if INCLUDE_STRTRI +void LAPACK(strtri)( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_strtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_DTRTRI +void LAPACK(dtrtri)( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dtrtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_CTRTRI +void LAPACK(ctrtri)( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_ctrtri(uplo, diag, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZTRTRI +void LAPACK(ztrtri)( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_ztrtri(uplo, diag, n, A, ldA, info); +} +#endif + + +//////////// +// XPOTRF // +//////////// + +#if INCLUDE_SPOTRF +void LAPACK(spotrf)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_spotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DPOTRF +void LAPACK(dpotrf)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_dpotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CPOTRF +void LAPACK(cpotrf)( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + RELAPACK_cpotrf(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZPOTRF +void LAPACK(zpotrf)( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + RELAPACK_zpotrf(uplo, n, A, ldA, info); +} +#endif + + +//////////// +// XPBTRF // +//////////// + +#if INCLUDE_SPBTRF +void LAPACK(spbtrf)( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + RELAPACK_spbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_DPBTRF +void LAPACK(dpbtrf)( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + RELAPACK_dpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_CPBTRF +void LAPACK(cpbtrf)( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + RELAPACK_cpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + +#if INCLUDE_ZPBTRF +void LAPACK(zpbtrf)( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + RELAPACK_zpbtrf(uplo, n, kd, Ab, ldAb, info); +} +#endif + + +//////////// +// XSYTRF // +//////////// + +#if INCLUDE_SSYTRF +void LAPACK(ssytrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_ssytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_DSYTRF +void LAPACK(dsytrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_dsytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CSYTRF +void LAPACK(csytrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_csytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZSYTRF +void LAPACK(zsytrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zsytrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CHETRF +void LAPACK(chetrf)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_chetrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZHETRF +void LAPACK(zhetrf)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zhetrf(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_SSYTRF_ROOK +void LAPACK(ssytrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_ssytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_DSYTRF_ROOK +void LAPACK(dsytrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_dsytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CSYTRF_ROOK +void LAPACK(csytrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_csytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZSYTRF_ROOK +void LAPACK(zsytrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zsytrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_CHETRF_ROOK +void LAPACK(chetrf_rook)( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + RELAPACK_chetrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + +#if INCLUDE_ZHETRF_ROOK +void LAPACK(zhetrf_rook)( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + RELAPACK_zhetrf_rook(uplo, n, A, ldA, ipiv, Work, lWork, info); +} +#endif + + +//////////// +// XGETRF // +//////////// + +#if INCLUDE_SGETRF +void LAPACK(sgetrf)( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_sgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_DGETRF +void LAPACK(dgetrf)( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_dgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_CGETRF +void LAPACK(cgetrf)( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_cgetrf(m, n, A, ldA, ipiv, info); +} +#endif + +#if INCLUDE_ZGETRF +void LAPACK(zgetrf)( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + RELAPACK_zgetrf(m, n, A, ldA, ipiv, info); +} +#endif + + +//////////// +// XGBTRF // +//////////// + +#if INCLUDE_SGBTRF +void LAPACK(sgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_sgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_DGBTRF +void LAPACK(dgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_dgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_CGBTRF +void LAPACK(cgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_cgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + +#if INCLUDE_ZGBTRF +void LAPACK(zgbtrf)( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + RELAPACK_zgbtrf(m, n, kl, ku, Ab, ldAb, ipiv, info); +} +#endif + + +//////////// +// XTRSYL // +//////////// + +#if INCLUDE_STRSYL +void LAPACK(strsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + RELAPACK_strsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_DTRSYL +void LAPACK(dtrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + RELAPACK_dtrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_CTRSYL +void LAPACK(ctrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + RELAPACK_ctrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + +#if INCLUDE_ZTRSYL +void LAPACK(ztrsyl)( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + RELAPACK_ztrsyl(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} +#endif + + +//////////// +// XTGSYL // +//////////// + +#if INCLUDE_STGSYL +void LAPACK(stgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_stgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_DTGSYL +void LAPACK(dtgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_dtgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_CTGSYL +void LAPACK(ctgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_ctgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + +#if INCLUDE_ZTGSYL +void LAPACK(ztgsyl)( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + RELAPACK_ztgsyl(trans, ijob, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dif, Work, lWork, iWork, info); +} +#endif + + +//////////// +// XGEMMT // +//////////// + +#if INCLUDE_SGEMMT +void LAPACK(sgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + RELAPACK_sgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_DGEMMT +void LAPACK(dgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + RELAPACK_dgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_CGEMMT +void LAPACK(cgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + RELAPACK_cgemmt(uplo, n, A, ldA, info); +} +#endif + +#if INCLUDE_ZGEMMT +void LAPACK(zgemmt)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + RELAPACK_zgemmt(uplo, n, A, ldA, info); +} +#endif diff --git a/relapack/src/relapack.h b/relapack/src/relapack.h new file mode 100644 index 0000000000..2cb061c323 --- /dev/null +++ b/relapack/src/relapack.h @@ -0,0 +1,60 @@ +#ifndef RELAPACK_INT_H +#define RELAPACK_INT_H + +#include "../config.h" + +#include "../inc/relapack.h" + +// add an underscore to BLAS routines (or not) +#if BLAS_UNDERSCORE +#define BLAS(routine) routine ## _ +#else +#define BLAS(routine) routine +#endif + +// add an underscore to LAPACK routines (or not) +#if LAPACK_UNDERSCORE +#define LAPACK(routine) routine ## _ +#else +#define LAPACK(routine) routine +#endif + +// minimum and maximum macros +#define MAX(a, b) ((a) > (b) ? (a) : (b)) +#define MIN(a, b) ((a) < (b) ? (a) : (b)) + +// REC_SPLIT(n) returns how a problem of size n is split recursively. +// If n >= 16, we ensure that the size of at least one of the halves is +// divisible by 8 (the cache line size in most CPUs), while both halves are +// still as close as possible in size. +// If n < 16 the problem is simply split in the middle. (Note that the +// crossoversize is usually larger than 16.) +#define SREC_SPLIT(n) ((n >= 32) ? ((n + 16) / 32) * 16 : n / 2) +#define DREC_SPLIT(n) ((n >= 16) ? ((n + 8) / 16) * 8 : n / 2) +#define CREC_SPLIT(n) ((n >= 16) ? ((n + 8) / 16) * 8 : n / 2) +#define ZREC_SPLIT(n) ((n >= 8) ? ((n + 4) / 8) * 4 : n / 2) + +#include "lapack.h" +#include "blas.h" + +// sytrf helper routines +void RELAPACK_ssytrf_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_dsytrf_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_csytrf_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_chetrf_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_zsytrf_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_zhetrf_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_ssytrf_rook_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_dsytrf_rook_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_csytrf_rook_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_chetrf_rook_rec2(const char *, const int *, const int *, int *, float *, const int *, int *, float *, const int *, int *); +void RELAPACK_zsytrf_rook_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); +void RELAPACK_zhetrf_rook_rec2(const char *, const int *, const int *, int *, double *, const int *, int *, double *, const int *, int *); + +// trsyl helper routines +void RELAPACK_strsyl_rec2(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void RELAPACK_dtrsyl_rec2(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); +void RELAPACK_ctrsyl_rec2(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void RELAPACK_ztrsyl_rec2(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); + +#endif /* RELAPACK_INT_H */ diff --git a/relapack/src/sgbtrf.c b/relapack/src/sgbtrf.c new file mode 100644 index 0000000000..bc20e744b2 --- /dev/null +++ b/relapack/src/sgbtrf.c @@ -0,0 +1,227 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_sgbtrf_rec(const int *, const int *, const int *, + const int *, float *, const int *, int *, float *, const int *, float *, + const int *, int *); + + +/** SGBTRF computes an LU factorization of a real m-by-n band matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's sgbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d5/d72/sgbtrf_8f.html + * */ +void RELAPACK_sgbtrf( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kl < 0) + *info = -3; + else if (*ku < 0) + *info = -4; + else if (*ldAb < 2 * *kl + *ku + 1) + *info = -6; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SGBTRF", &minfo); + return; + } + + // Constant + const float ZERO[] = { 0. }; + + // Result upper band width + const int kv = *ku + *kl; + + // Unskewg A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + kv; + + // Zero upper diagonal fill-in elements + int i, j; + for (j = 0; j < *n; j++) { + float *const A_j = A + *ldA * j; + for (i = MAX(0, j - kv); i < j - *ku; i++) + A_j[i] = 0.; + } + + // Allocate work space + const int n1 = SREC_SPLIT(*n); + const int mWorkl = (kv > n1) ? MAX(1, *m - *kl) : kv; + const int nWorkl = (kv > n1) ? n1 : kv; + const int mWorku = (*kl > n1) ? n1 : *kl; + const int nWorku = (*kl > n1) ? MAX(0, *n - *kl) : *kl; + float *Workl = malloc(mWorkl * nWorkl * sizeof(float)); + float *Worku = malloc(mWorku * nWorku * sizeof(float)); + LAPACK(slaset)("L", &mWorkl, &nWorkl, ZERO, ZERO, Workl, &mWorkl); + LAPACK(slaset)("U", &mWorku, &nWorku, ZERO, ZERO, Worku, &mWorku); + + // Recursive kernel + RELAPACK_sgbtrf_rec(m, n, kl, ku, Ab, ldAb, ipiv, Workl, &mWorkl, Worku, &mWorku, info); + + // Free work space + free(Workl); + free(Worku); +} + + +/** sgbtrf's recursive compute kernel */ +static void RELAPACK_sgbtrf_rec( + const int *m, const int *n, const int *kl, const int *ku, + float *Ab, const int *ldAb, int *ipiv, + float *Workl, const int *ldWorkl, float *Worku, const int *ldWorku, + int *info +) { + + if (*n <= MAX(CROSSOVER_SGBTRF, 1)) { + // Unblocked + LAPACK(sgbtf2)(m, n, kl, ku, Ab, ldAb, ipiv, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Loop iterators + int i, j; + + // Output upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + kv; + + // Splitting + const int n1 = MIN(SREC_SPLIT(*n), *kl); + const int n2 = *n - n1; + const int m1 = MIN(n1, *m); + const int m2 = *m - m1; + const int mn1 = MIN(m1, n1); + const int mn2 = MIN(m2, n2); + + // Ab_L * + // Ab_BR + float *const Ab_L = Ab; + float *const Ab_BR = Ab + *ldAb * n1; + + // A_L A_R + float *const A_L = A; + float *const A_R = A + *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + m1; + float *const A_BR = A + *ldA * n1 + m1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // Banded splitting + const int n21 = MIN(n2, kv - n1); + const int n22 = MIN(n2 - n21, n1); + const int m21 = MIN(m2, *kl - m1); + const int m22 = MIN(m2 - m21, m1); + + // n1 n21 n22 + // m * A_Rl ARr + float *const A_Rl = A_R; + float *const A_Rr = A_R + *ldA * n21; + + // n1 n21 n22 + // m1 * A_TRl A_TRr + // m21 A_BLt A_BRtl A_BRtr + // m22 A_BLb A_BRbl A_BRbr + float *const A_TRl = A_TR; + float *const A_TRr = A_TR + *ldA * n21; + float *const A_BLt = A_BL; + float *const A_BLb = A_BL + m21; + float *const A_BRtl = A_BR; + float *const A_BRtr = A_BR + *ldA * n21; + float *const A_BRbl = A_BR + m21; + float *const A_BRbr = A_BR + *ldA * n21 + m21; + + // recursion(Ab_L, ipiv_T) + RELAPACK_sgbtrf_rec(m, &n1, kl, ku, Ab_L, ldAb, ipiv_T, Workl, ldWorkl, Worku, ldWorku, info); + + // Workl = A_BLb + LAPACK(slacpy)("U", &m22, &n1, A_BLb, ldA, Workl, ldWorkl); + + // partially redo swaps in A_L + for (i = 0; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(sswap)(&i, A_L + i, ldA, A_L + ip, ldA); + else + BLAS(sswap)(&i, A_L + i, ldA, Workl + ip - *kl, ldWorkl); + } + } + + // apply pivots to A_Rl + LAPACK(slaswp)(&n21, A_Rl, ldA, iONE, &mn1, ipiv_T, iONE); + + // apply pivots to A_Rr columnwise + for (j = 0; j < n22; j++) { + float *const A_Rrj = A_Rr + *ldA * j; + for (i = j; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + const float tmp = A_Rrj[i]; + A_Rrj[i] = A_Rr[ip]; + A_Rrj[ip] = tmp; + } + } + } + + // A_TRl = A_TL \ A_TRl + BLAS(strsm)("L", "L", "N", "U", &m1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // Worku = A_TRr + LAPACK(slacpy)("L", &m1, &n22, A_TRr, ldA, Worku, ldWorku); + // Worku = A_TL \ Worku + BLAS(strsm)("L", "L", "N", "U", &m1, &n22, ONE, A_TL, ldA, Worku, ldWorku); + // A_TRr = Worku + LAPACK(slacpy)("L", &m1, &n22, Worku, ldWorku, A_TRr, ldA); + // A_BRtl = A_BRtl - A_BLt * A_TRl + BLAS(sgemm)("N", "N", &m21, &n21, &n1, MONE, A_BLt, ldA, A_TRl, ldA, ONE, A_BRtl, ldA); + // A_BRbl = A_BRbl - Workl * A_TRl + BLAS(sgemm)("N", "N", &m22, &n21, &n1, MONE, Workl, ldWorkl, A_TRl, ldA, ONE, A_BRbl, ldA); + // A_BRtr = A_BRtr - A_BLt * Worku + BLAS(sgemm)("N", "N", &m21, &n22, &n1, MONE, A_BLt, ldA, Worku, ldWorku, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Workl * Worku + BLAS(sgemm)("N", "N", &m22, &n22, &n1, MONE, Workl, ldWorkl, Worku, ldWorku, ONE, A_BRbr, ldA); + + // partially undo swaps in A_L + for (i = mn1 - 1; i >= 0; i--) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(sswap)(&i, A_L + i, ldA, A_L + ip, ldA); + else + BLAS(sswap)(&i, A_L + i, ldA, Workl + ip - *kl, ldWorkl); + } + } + + // recursion(Ab_BR, ipiv_B) + RELAPACK_sgbtrf_rec(&m2, &n2, kl, ku, Ab_BR, ldAb, ipiv_B, Workl, ldWorkl, Worku, ldWorku, info); + if (*info) + *info += n1; + // shift pivots + for (i = 0; i < mn2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/sgemmt.c b/relapack/src/sgemmt.c new file mode 100644 index 0000000000..75f78fabd1 --- /dev/null +++ b/relapack/src/sgemmt.c @@ -0,0 +1,165 @@ +#include "relapack.h" + +static void RELAPACK_sgemmt_rec(const char *, const char *, const char *, + const int *, const int *, const float *, const float *, const int *, + const float *, const int *, const float *, float *, const int *); + +static void RELAPACK_sgemmt_rec2(const char *, const char *, const char *, + const int *, const int *, const float *, const float *, const int *, + const float *, const int *, const float *, float *, const int *); + + +/** SGEMMT computes a matrix-matrix product with general matrices but updates + * only the upper or lower triangular part of the result matrix. + * + * This routine performs the same operation as the BLAS routine + * sgemm(transA, transB, n, n, k, alpha, A, ldA, B, ldB, beta, C, ldC) + * but only updates the triangular part of C specified by uplo: + * If (*uplo == 'L'), only the lower triangular part of C is updated, + * otherwise the upper triangular part is updated. + * */ +void RELAPACK_sgemmt( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + +#if HAVE_XGEMMT + BLAS(sgemmt)(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; +#else + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int notransA = LAPACK(lsame)(transA, "N"); + const int tranA = LAPACK(lsame)(transA, "T"); + const int notransB = LAPACK(lsame)(transB, "N"); + const int tranB = LAPACK(lsame)(transB, "T"); + int info = 0; + if (!lower && !upper) + info = 1; + else if (!tranA && !notransA) + info = 2; + else if (!tranB && !notransB) + info = 3; + else if (*n < 0) + info = 4; + else if (*k < 0) + info = 5; + else if (*ldA < MAX(1, notransA ? *n : *k)) + info = 8; + else if (*ldB < MAX(1, notransB ? *k : *n)) + info = 10; + else if (*ldC < MAX(1, *n)) + info = 13; + if (info) { + LAPACK(xerbla)("SGEMMT", &info); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleantransA = notransA ? 'N' : 'T'; + const char cleantransB = notransB ? 'N' : 'T'; + + // Recursive kernel + RELAPACK_sgemmt_rec(&cleanuplo, &cleantransA, &cleantransB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); +#endif +} + + +/** sgemmt's recursive compute kernel */ +static void RELAPACK_sgemmt_rec( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + + if (*n <= MAX(CROSSOVER_SGEMMT, 1)) { + // Unblocked + RELAPACK_sgemmt_rec2(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; + } + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_T + // A_B + const float *const A_T = A; + const float *const A_B = A + ((*transA == 'N') ? n1 : *ldA * n1); + + // B_L B_R + const float *const B_L = B; + const float *const B_R = B + ((*transB == 'N') ? *ldB * n1 : n1); + + // C_TL C_TR + // C_BL C_BR + float *const C_TL = C; + float *const C_TR = C + *ldC * n1; + float *const C_BL = C + n1; + float *const C_BR = C + *ldC * n1 + n1; + + // recursion(C_TL) + RELAPACK_sgemmt_rec(uplo, transA, transB, &n1, k, alpha, A_T, ldA, B_L, ldB, beta, C_TL, ldC); + + if (*uplo == 'L') + // C_BL = alpha A_B B_L + beta C_BL + BLAS(sgemm)(transA, transB, &n2, &n1, k, alpha, A_B, ldA, B_L, ldB, beta, C_BL, ldC); + else + // C_TR = alpha A_T B_R + beta C_TR + BLAS(sgemm)(transA, transB, &n1, &n2, k, alpha, A_T, ldA, B_R, ldB, beta, C_TR, ldC); + + // recursion(C_BR) + RELAPACK_sgemmt_rec(uplo, transA, transB, &n2, k, alpha, A_B, ldA, B_R, ldB, beta, C_BR, ldC); +} + + +/** sgemmt's unblocked compute kernel */ +static void RELAPACK_sgemmt_rec2( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const float *alpha, const float *A, const int *ldA, + const float *B, const int *ldB, + const float *beta, float *C, const int *ldC +) { + + const int incB = (*transB == 'N') ? 1 : *ldB; + const int incC = 1; + + int i; + for (i = 0; i < *n; i++) { + // A_0 + // A_i + const float *const A_0 = A; + const float *const A_i = A + ((*transA == 'N') ? i : *ldA * i); + + // * B_i * + const float *const B_i = B + ((*transB == 'N') ? *ldB * i : i); + + // * C_0i * + // * C_ii * + float *const C_0i = C + *ldC * i; + float *const C_ii = C + *ldC * i + i; + + if (*uplo == 'L') { + const int nmi = *n - i; + if (*transA == 'N') + BLAS(sgemv)(transA, &nmi, k, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + else + BLAS(sgemv)(transA, k, &nmi, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + } else { + const int ip1 = i + 1; + if (*transA == 'N') + BLAS(sgemv)(transA, &ip1, k, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + else + BLAS(sgemv)(transA, k, &ip1, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + } + } +} diff --git a/relapack/src/sgetrf.c b/relapack/src/sgetrf.c new file mode 100644 index 0000000000..284f8cff67 --- /dev/null +++ b/relapack/src/sgetrf.c @@ -0,0 +1,117 @@ +#include "relapack.h" + +static void RELAPACK_sgetrf_rec(const int *, const int *, float *, const int *, + int *, int *); + + +/** SGETRF computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's sgetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/de/de2/sgetrf_8f.html + * */ +void RELAPACK_sgetrf( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SGETRF", &minfo); + return; + } + + const int sn = MIN(*m, *n); + + RELAPACK_sgetrf_rec(m, &sn, A, ldA, ipiv, info); + + // Right remainder + if (*m < *n) { + // Constants + const float ONE[] = { 1. }; + const int iONE[] = { 1. }; + + // Splitting + const int rn = *n - *m; + + // A_L A_R + const float *const A_L = A; + float *const A_R = A + *ldA * *m; + + // A_R = apply(ipiv, A_R) + LAPACK(slaswp)(&rn, A_R, ldA, iONE, m, ipiv, iONE); + // A_R = A_L \ A_R + BLAS(strsm)("L", "L", "N", "U", m, &rn, ONE, A_L, ldA, A_R, ldA); + } +} + + +/** sgetrf's recursive compute kernel */ +static void RELAPACK_sgetrf_rec( + const int *m, const int *n, + float *A, const int *ldA, int *ipiv, + int *info +) { + + if (*n <= MAX(CROSSOVER_SGETRF, 1)) { + // Unblocked + LAPACK(sgetf2)(m, n, A, ldA, ipiv, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + const int m2 = *m - n1; + + // A_L A_R + float *const A_L = A; + float *const A_R = A + *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // recursion(A_L, ipiv_T) + RELAPACK_sgetrf_rec(m, &n1, A_L, ldA, ipiv_T, info); + // apply pivots to A_R + LAPACK(slaswp)(&n2, A_R, ldA, iONE, &n1, ipiv_T, iONE); + + // A_TR = A_TL \ A_TR + BLAS(strsm)("L", "L", "N", "U", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_BL * A_TR + BLAS(sgemm)("N", "N", &m2, &n2, &n1, MONE, A_BL, ldA, A_TR, ldA, ONE, A_BR, ldA); + + // recursion(A_BR, ipiv_B) + RELAPACK_sgetrf_rec(&m2, &n2, A_BR, ldA, ipiv_B, info); + if (*info) + *info += n1; + // apply pivots to A_BL + LAPACK(slaswp)(&n1, A_BL, ldA, iONE, &n2, ipiv_B, iONE); + // shift pivots + int i; + for (i = 0; i < n2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/slauum.c b/relapack/src/slauum.c new file mode 100644 index 0000000000..280f141b31 --- /dev/null +++ b/relapack/src/slauum.c @@ -0,0 +1,87 @@ +#include "relapack.h" + +static void RELAPACK_slauum_rec(const char *, const int *, float *, + const int *, int *); + + +/** SLAUUM computes the product U * U**T or L**T * L, where the triangular factor U or L is stored in the upper or lower triangular part of the array A. + * + * This routine is functionally equivalent to LAPACK's slauum. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dd/d5a/slauum_8f.html + * */ +void RELAPACK_slauum( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SLAUUM", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_slauum_rec(&cleanuplo, n, A, ldA, info); +} + + +/** slauum's recursive compute kernel */ +static void RELAPACK_slauum_rec( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_SLAUUM, 1)) { + // Unblocked + LAPACK(slauu2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_slauum_rec(uplo, &n1, A_TL, ldA, info); + + if (*uplo == 'L') { + // A_TL = A_TL + A_BL' * A_BL + BLAS(ssyrk)("L", "T", &n1, &n2, ONE, A_BL, ldA, ONE, A_TL, ldA); + // A_BL = A_BR' * A_BL + BLAS(strmm)("L", "L", "T", "N", &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TL = A_TL + A_TR * A_TR' + BLAS(ssyrk)("U", "N", &n1, &n2, ONE, A_TR, ldA, ONE, A_TL, ldA); + // A_TR = A_TR * A_BR' + BLAS(strmm)("R", "U", "T", "N", &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_slauum_rec(uplo, &n2, A_BR, ldA, info); +} diff --git a/relapack/src/spbtrf.c b/relapack/src/spbtrf.c new file mode 100644 index 0000000000..ee0a5546e9 --- /dev/null +++ b/relapack/src/spbtrf.c @@ -0,0 +1,157 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_spbtrf_rec(const char *, const int *, const int *, + float *, const int *, float *, const int *, int *); + + +/** SPBTRF computes the Cholesky factorization of a real symmetric positive definite band matrix A. + * + * This routine is functionally equivalent to LAPACK's spbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d1/d22/spbtrf_8f.html + * */ +void RELAPACK_spbtrf( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kd < 0) + *info = -3; + else if (*ldAb < *kd + 1) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SPBTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Constant + const float ZERO[] = { 0. }; + + // Allocate work space + const int n1 = SREC_SPLIT(*n); + const int mWork = (*kd > n1) ? (lower ? *n - *kd : n1) : *kd; + const int nWork = (*kd > n1) ? (lower ? n1 : *n - *kd) : *kd; + float *Work = malloc(mWork * nWork * sizeof(float)); + LAPACK(slaset)(uplo, &mWork, &nWork, ZERO, ZERO, Work, &mWork); + + // Recursive kernel + RELAPACK_spbtrf_rec(&cleanuplo, n, kd, Ab, ldAb, Work, &mWork, info); + + // Free work space + free(Work); +} + + +/** spbtrf's recursive compute kernel */ +static void RELAPACK_spbtrf_rec( + const char *uplo, const int *n, const int *kd, + float *Ab, const int *ldAb, + float *Work, const int *ldWork, + int *info +){ + + if (*n <= MAX(CROSSOVER_SPBTRF, 1)) { + // Unblocked + LAPACK(spbtf2)(uplo, n, kd, Ab, ldAb, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + float *const A = Ab + ((*uplo == 'L') ? 0 : *kd); + + // Splitting + const int n1 = MIN(SREC_SPLIT(*n), *kd); + const int n2 = *n - n1; + + // * * + // * Ab_BR + float *const Ab_BR = Ab + *ldAb * n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_spotrf(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + // Banded splitting + const int n21 = MIN(n2, *kd - n1); + const int n22 = MIN(n2 - n21, *kd); + + // n1 n21 n22 + // n1 * A_TRl A_TRr + // n21 A_BLt A_BRtl A_BRtr + // n22 A_BLb A_BRbl A_BRbr + float *const A_TRl = A_TR; + float *const A_TRr = A_TR + *ldA * n21; + float *const A_BLt = A_BL; + float *const A_BLb = A_BL + n21; + float *const A_BRtl = A_BR; + float *const A_BRtr = A_BR + *ldA * n21; + float *const A_BRbl = A_BR + n21; + float *const A_BRbr = A_BR + *ldA * n21 + n21; + + if (*uplo == 'L') { + // A_BLt = ABLt / A_TL' + BLAS(strsm)("R", "L", "T", "N", &n21, &n1, ONE, A_TL, ldA, A_BLt, ldA); + // A_BRtl = A_BRtl - A_BLt * A_BLt' + BLAS(ssyrk)("L", "N", &n21, &n1, MONE, A_BLt, ldA, ONE, A_BRtl, ldA); + // Work = A_BLb + LAPACK(slacpy)("U", &n22, &n1, A_BLb, ldA, Work, ldWork); + // Work = Work / A_TL' + BLAS(strsm)("R", "L", "T", "N", &n22, &n1, ONE, A_TL, ldA, Work, ldWork); + // A_BRbl = A_BRbl - Work * A_BLt' + BLAS(sgemm)("N", "T", &n22, &n21, &n1, MONE, Work, ldWork, A_BLt, ldA, ONE, A_BRbl, ldA); + // A_BRbr = A_BRbr - Work * Work' + BLAS(ssyrk)("L", "N", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_BLb = Work + LAPACK(slacpy)("U", &n22, &n1, Work, ldWork, A_BLb, ldA); + } else { + // A_TRl = A_TL' \ A_TRl + BLAS(strsm)("L", "U", "T", "N", &n1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // A_BRtl = A_BRtl - A_TRl' * A_TRl + BLAS(ssyrk)("U", "T", &n21, &n1, MONE, A_TRl, ldA, ONE, A_BRtl, ldA); + // Work = A_TRr + LAPACK(slacpy)("L", &n1, &n22, A_TRr, ldA, Work, ldWork); + // Work = A_TL' \ Work + BLAS(strsm)("L", "U", "T", "N", &n1, &n22, ONE, A_TL, ldA, Work, ldWork); + // A_BRtr = A_BRtr - A_TRl' * Work + BLAS(sgemm)("T", "N", &n21, &n22, &n1, MONE, A_TRl, ldA, Work, ldWork, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Work' * Work + BLAS(ssyrk)("U", "T", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_TRr = Work + LAPACK(slacpy)("L", &n1, &n22, Work, ldWork, A_TRr, ldA); + } + + // recursion(A_BR) + if (*kd > n1) + RELAPACK_spotrf(uplo, &n2, A_BR, ldA, info); + else + RELAPACK_spbtrf_rec(uplo, &n2, kd, Ab_BR, ldAb, Work, ldWork, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/spotrf.c b/relapack/src/spotrf.c new file mode 100644 index 0000000000..2a609321be --- /dev/null +++ b/relapack/src/spotrf.c @@ -0,0 +1,92 @@ +#include "relapack.h" + +static void RELAPACK_spotrf_rec(const char *, const int *, float *, + const int *, int *); + + +/** SPOTRF computes the Cholesky factorization of a real symmetric positive definite matrix A. + * + * This routine is functionally equivalent to LAPACK's spotrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d0/da2/spotrf_8f.html + * */ +void RELAPACK_spotrf( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SPOTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_spotrf_rec(&cleanuplo, n, A, ldA, info); +} + + +/** spotrf's recursive compute kernel */ +static void RELAPACK_spotrf_rec( + const char *uplo, const int *n, + float *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_SPOTRF, 1)) { + // Unblocked + LAPACK(spotf2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_spotrf_rec(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = A_BL / A_TL' + BLAS(strsm)("R", "L", "T", "N", &n2, &n1, ONE, A_TL, ldA, A_BL, ldA); + // A_BR = A_BR - A_BL * A_BL' + BLAS(ssyrk)("L", "N", &n2, &n1, MONE, A_BL, ldA, ONE, A_BR, ldA); + } else { + // A_TR = A_TL' \ A_TR + BLAS(strsm)("L", "U", "T", "N", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_TR' * A_TR + BLAS(ssyrk)("U", "T", &n2, &n1, MONE, A_TR, ldA, ONE, A_BR, ldA); + } + + // recursion(A_BR) + RELAPACK_spotrf_rec(uplo, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/ssygst.c b/relapack/src/ssygst.c new file mode 100644 index 0000000000..7f145cdec9 --- /dev/null +++ b/relapack/src/ssygst.c @@ -0,0 +1,212 @@ +#include "relapack.h" +#if XSYGST_ALLOW_MALLOC +#include "stdlib.h" +#endif + +static void RELAPACK_ssygst_rec(const int *, const char *, const int *, + float *, const int *, const float *, const int *, + float *, const int *, int *); + + +/** SSYGST reduces a real symmetric-definite generalized eigenproblem to standard form. + * + * This routine is functionally equivalent to LAPACK's ssygst. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d8/d78/ssygst_8f.html + * */ +void RELAPACK_ssygst( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (*itype < 1 || *itype > 3) + *info = -1; + else if (!lower && !upper) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + else if (*ldB < MAX(1, *n)) + *info = -7; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SSYGST", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Allocate work space + float *Work = NULL; + int lWork = 0; +#if XSYGST_ALLOW_MALLOC + const int n1 = SREC_SPLIT(*n); + lWork = n1 * (*n - n1); + Work = malloc(lWork * sizeof(float)); + if (!Work) + lWork = 0; +#endif + + // Recursive kernel + RELAPACK_ssygst_rec(itype, &cleanuplo, n, A, ldA, B, ldB, Work, &lWork, info); + + // Free work space +#if XSYGST_ALLOW_MALLOC + if (Work) + free(Work); +#endif +} + + +/** ssygst's recursive compute kernel */ +static void RELAPACK_ssygst_rec( + const int *itype, const char *uplo, const int *n, + float *A, const int *ldA, const float *B, const int *ldB, + float *Work, const int *lWork, int *info +) { + + if (*n <= MAX(CROSSOVER_SSYGST, 1)) { + // Unblocked + LAPACK(ssygs2)(itype, uplo, n, A, ldA, B, ldB, info); + return; + } + + // Constants + const float ZERO[] = { 0. }; + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const float HALF[] = { .5 }; + const float MHALF[] = { -.5 }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // B_TL B_TR + // B_BL B_BR + const float *const B_TL = B; + const float *const B_TR = B + *ldB * n1; + const float *const B_BL = B + n1; + const float *const B_BR = B + *ldB * n1 + n1; + + // recursion(A_TL, B_TL) + RELAPACK_ssygst_rec(itype, uplo, &n1, A_TL, ldA, B_TL, ldB, Work, lWork, info); + + if (*itype == 1) + if (*uplo == 'L') { + // A_BL = A_BL / B_TL' + BLAS(strsm)("R", "L", "T", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * B_BL * A_TL + BLAS(ssymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(saxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + } else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(ssymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BR = A_BR - A_BL * B_BL' - B_BL * A_BL' + BLAS(ssyr2k)("L", "N", &n2, &n1, MONE, A_BL, ldA, B_BL, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(saxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(ssymm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR \ A_BL + BLAS(strsm)("L", "L", "N", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL' \ A_TR + BLAS(strsm)("L", "U", "T", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = -1/2 * A_TL * B_TR + BLAS(ssymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(saxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + } else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(ssymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_BR = A_BR - A_TR' * B_TR - B_TR' * A_TR + BLAS(ssyr2k)("U", "T", &n2, &n1, MONE, A_TR, ldA, B_TR, ldB, ONE, A_BR, ldA); + if (*lWork > n2 * n1) + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(saxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(ssymm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR / B_BR + BLAS(strsm)("R", "U", "N", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + else + if (*uplo == 'L') { + // A_BL = A_BL * B_TL + BLAS(strmm)("R", "L", "N", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * A_BR * B_BL + BLAS(ssymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(saxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + } else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(ssymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_TL = A_TL + A_BL' * B_BL + B_BL' * A_BL + BLAS(ssyr2k)("L", "T", &n1, &n2, ONE, A_BL, ldA, B_BL, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(saxpy)(&n2, ONE, Work + n2 * i, iONE, A_BL + *ldA * i, iONE); + else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(ssymm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR * A_BL + BLAS(strmm)("L", "L", "T", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL * A_TR + BLAS(strmm)("L", "U", "N", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork > n2 * n1) { + // T = 1/2 * B_TR * A_BR + BLAS(ssymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(saxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + } else + // A_TR = A_TR + 1/2 B_TR A_BR + BLAS(ssymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TL = A_TL + A_TR * B_TR' + B_TR * A_TR' + BLAS(ssyr2k)("U", "N", &n1, &n2, ONE, A_TR, ldA, B_TR, ldB, ONE, A_TL, ldA); + if (*lWork > n2 * n1) + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(saxpy)(&n1, ONE, Work + n1 * i, iONE, A_TR + *ldA * i, iONE); + else + // A_TR = A_TR + 1/2 B_TR * A_BR + BLAS(ssymm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR * B_BR + BLAS(strmm)("R", "U", "T", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + + // recursion(A_BR, B_BR) + RELAPACK_ssygst_rec(itype, uplo, &n2, A_BR, ldA, B_BR, ldB, Work, lWork, info); +} diff --git a/relapack/src/ssytrf.c b/relapack/src/ssytrf.c new file mode 100644 index 0000000000..8a4fad9f2a --- /dev/null +++ b/relapack/src/ssytrf.c @@ -0,0 +1,238 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_ssytrf_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** SSYTRF computes the factorization of a complex symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's ssytrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/da/de9/ssytrf_8f.html + * */ +void RELAPACK_ssytrf( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy arguments + int nout; + + // Recursive kernel + RELAPACK_ssytrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** ssytrf's recursive compute kernel */ +static void RELAPACK_ssytrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_SSYTRF, 3)) { + // Unblocked + if (top) { + LAPACK(ssytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_ssytrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = SREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_ssytrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + float *const A_BL_B = A + *n; + float *const A_BR_B = A + *ldA * n1 + *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + n1; + float *const Work_BR = top ? Work : Work + *ldWork * n1 + n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_sgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(sgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_ssytrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + *ldA * n2_out + n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(sgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = SREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_ssytrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + *ldA * n_rest; + float *const A_TR_T = A + *ldA * (n_rest + n1); + float *const A_TL = A + *ldA * n_rest + n_rest; + float *const A_TR = A + *ldA * (n_rest + n1) + n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + *ldWork * (top ? n2_diff : n1) + n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_sgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(sgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_ssytrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(sgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/ssytrf_rec2.c b/relapack/src/ssytrf_rec2.c new file mode 100644 index 0000000000..edc9269eca --- /dev/null +++ b/relapack/src/ssytrf_rec2.c @@ -0,0 +1,351 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static float c_b8 = -1.f; +static float c_b9 = 1.f; + +/** SSYTRF_REC2 computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagon al pivoting method. + * + * This routine is a minor modification of LAPACK's slasyf. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_ssytrf_rec2(char *uplo, int *n, int * + nb, int *kb, float *a, int *lda, int *ipiv, float *w, + int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; + float r__1, r__2, r__3; + + /* Builtin functions */ + double sqrt(double); + + /* Local variables */ + static int j, k; + static float t, r1, d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static float alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int sscal_(int *, float *, float *, int *), + sgemv_(char *, int *, int *, float *, float *, int *, + float *, int *, float *, float *, int *, ftnlen); + static int kstep; + extern /* Subroutine */ int scopy_(int *, float *, int *, float *, + int *), sswap_(int *, float *, int *, float *, int * + ); + static float absakk; + extern int isamax_(int *, float *, int *); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + kstep = 1; + absakk = (r__1 = w[k + kw * w_dim1], dabs(r__1)); + if (k > 1) { + i__1 = k - 1; + imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (r__1 = w[imax + kw * w_dim1], dabs(r__1)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + i__1 = k - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], dabs(r__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + r__2 = rowmax, r__3 = (r__1 = w[jmax + (kw - 1) * w_dim1], + dabs(r__1)); + rowmax = dmax(r__2,r__3); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else if ((r__1 = w[imax + (kw - 1) * w_dim1], dabs(r__1)) >= + alpha * rowmax) { + kp = imax; + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kk - 1 - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + scopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + sswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + r1 = 1.f / a[k + k * a_dim1]; + i__1 = k - 1; + sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + if (k > 2) { + d21 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d21; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + d21 = t / d21; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) + * w_dim1] - w[j + kw * w_dim1]); + a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]); +/* L20: */ + } + } + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + i__1 = *n - k + 1; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1, (ftnlen)12); + kstep = 1; + absakk = (r__1 = w[k + k * w_dim1], dabs(r__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (r__1 = w[imax + k * w_dim1], dabs(r__1)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax - k; + jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], dabs(r__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + r__2 = rowmax, r__3 = (r__1 = w[jmax + (k + 1) * w_dim1], + dabs(r__1)); + rowmax = dmax(r__2,r__3); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else if ((r__1 = w[imax + (k + 1) * w_dim1], dabs(r__1)) >= + alpha * rowmax) { + kp = imax; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + kk = k + kstep - 1; + if (kp != kk) { + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kp - kk - 1; + scopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + sswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = *n - k; + sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + if (k < *n - 1) { + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + d21 = t / d21; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - + w[j + (k + 1) * w_dim1]); + a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]); +/* L80: */ + } + } + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + sswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/ssytrf_rook.c b/relapack/src/ssytrf_rook.c new file mode 100644 index 0000000000..040df24840 --- /dev/null +++ b/relapack/src/ssytrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_ssytrf_rook_rec(const char *, const int *, const int *, int *, + float *, const int *, int *, float *, const int *, int *); + + +/** SSYTRF_ROOK computes the factorization of a real symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's ssytrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/de/da4/ssytrf__rook_8f.html + * */ +void RELAPACK_ssytrf_rook( + const char *uplo, const int *n, + float *A, const int *ldA, int *ipiv, + float *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + float *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * sizeof(float)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("SSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_ssytrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** ssytrf_rook's recursive compute kernel */ +static void RELAPACK_ssytrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + float *A, const int *ldA, int *ipiv, + float *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_SSYTRF_ROOK, 3)) { + // Unblocked + if (top) { + LAPACK(ssytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_ssytrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = SREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + float *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_ssytrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + float *const A_BL_B = A + *n; + float *const A_BR_B = A + *ldA * n1 + *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + float *const Work_BL = Work + n1; + float *const Work_BR = top ? Work : Work + *ldWork * n1 + n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_sgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(sgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_ssytrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + float *const A_BR_r = A_BR + *ldA * n2_out + n2_out; + + // last row of A_BL + float *const A_BL_b = A_BL + n2_out; + + // last row of Work_BL + float *const Work_BL_b = Work_BL + n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(sgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = SREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + float *const Work_R = top ? Work : Work + *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_ssytrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + float *const A_TL_T = A + *ldA * n_rest; + float *const A_TR_T = A + *ldA * (n_rest + n1); + float *const A_TL = A + *ldA * n_rest + n_rest; + float *const A_TR = A + *ldA * (n_rest + n1) + n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + float *const Work_L = Work; + float *const Work_TR = Work + *ldWork * (top ? n2_diff : n1) + n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_sgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(sgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_ssytrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(sgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/ssytrf_rook_rec2.c b/relapack/src/ssytrf_rook_rec2.c new file mode 100644 index 0000000000..3308826d7e --- /dev/null +++ b/relapack/src/ssytrf_rook_rec2.c @@ -0,0 +1,451 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static float c_b9 = -1.f; +static float c_b10 = 1.f; + +/** SSYTRF_ROOK_REC2 computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufma n ("rook") diagonal pivoting method. + * + * This routine is a minor modification of LAPACK's slasyf_rook. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_ssytrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, float *a, int *lda, int *ipiv, float * + w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; + float r__1; + + /* Builtin functions */ + double sqrt(double); + + /* Local variables */ + static int j, k, p; + static float t, r1, d11, d12, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static float alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int sscal_(int *, float *, float *, int *); + static float sfmin; + static int itemp; + extern /* Subroutine */ int sgemv_(char *, int *, int *, float *, + float *, int *, float *, int *, float *, float *, int *, + ftnlen); + static int kstep; + static float stemp; + extern /* Subroutine */ int scopy_(int *, float *, int *, float *, + int *), sswap_(int *, float *, int *, float *, int * + ); + static float absakk; + extern double slamch_(char *, ftnlen); + extern int isamax_(int *, float *, int *); + static float colmax, rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.f) + 1.f) / 8.f; + sfmin = slamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b10, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + absakk = (r__1 = w[k + kw * w_dim1], dabs(r__1)); + if (k > 1) { + i__1 = k - 1; + imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (r__1 = w[imax + kw * w_dim1], dabs(r__1)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b10, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], dabs(r__1)); + } else { + rowmax = 0.f; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + stemp = (r__1 = w[itemp + (kw - 1) * w_dim1], dabs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + if (! ((r__1 = w[imax + (kw - 1) * w_dim1], dabs(r__1)) < + alpha * rowmax)) { + kp = imax; + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = k - p; + scopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + scopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + i__1 = *n - k + 1; + sswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = k - 1 - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + scopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = *n - kk + 1; + sswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + if ((r__1 = a[k + k * a_dim1], dabs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = k - 1; + sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L14: */ + } + } + } + } else { + if (k > 2) { + d12 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d12; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d12; + t = 1.f / (d11 * d22 - 1.f); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d12); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d12); +/* L20: */ + } + } + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = *n - k + 1; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b10, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + } + absakk = (r__1 = w[k + k * w_dim1], dabs(r__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (r__1 = w[imax + k * w_dim1], dabs(r__1)); + } else { + colmax = 0.f; + } + if (dmax(absakk,colmax) == 0.f) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b10, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], dabs(r__1)); + } else { + rowmax = 0.f; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + stemp = (r__1 = w[itemp + (k + 1) * w_dim1], dabs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + if (! ((r__1 = w[imax + (k + 1) * w_dim1], dabs(r__1)) < + alpha * rowmax)) { + kp = imax; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p - k; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + scopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + sswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + sswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = kp - k - 1; + scopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + scopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + sswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + if ((r__1 = a[k + k * a_dim1], dabs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = *n - k; + sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L74: */ + } + } + } + } else { + if (k < *n - 1) { + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); +/* L80: */ + } + } + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + sswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + sswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/stgsyl.c b/relapack/src/stgsyl.c new file mode 100644 index 0000000000..1870fb9289 --- /dev/null +++ b/relapack/src/stgsyl.c @@ -0,0 +1,274 @@ +#include "relapack.h" +#include + +static void RELAPACK_stgsyl_rec(const char *, const int *, const int *, + const int *, const float *, const int *, const float *, const int *, + float *, const int *, const float *, const int *, const float *, + const int *, float *, const int *, float *, float *, float *, int *, int *, + int *); + + +/** STGSYL solves the generalized Sylvester equation. + * + * This routine is functionally equivalent to LAPACK's stgsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dc/d67/stgsyl_8f.html + * */ +void RELAPACK_stgsyl( + const char *trans, const int *ijob, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dif, + float *Work, const int *lWork, int *iWork, int *info +) { + + // Parse arguments + const int notran = LAPACK(lsame)(trans, "N"); + const int tran = LAPACK(lsame)(trans, "T"); + + // Compute work buffer size + int lwmin = 1; + if (notran && (*ijob == 1 || *ijob == 2)) + lwmin = MAX(1, 2 * *m * *n); + *info = 0; + + // Check arguments + if (!tran && !notran) + *info = -1; + else if (notran && (*ijob < 0 || *ijob > 4)) + *info = -2; + else if (*m <= 0) + *info = -3; + else if (*n <= 0) + *info = -4; + else if (*ldA < MAX(1, *m)) + *info = -6; + else if (*ldB < MAX(1, *n)) + *info = -8; + else if (*ldC < MAX(1, *m)) + *info = -10; + else if (*ldD < MAX(1, *m)) + *info = -12; + else if (*ldE < MAX(1, *n)) + *info = -14; + else if (*ldF < MAX(1, *m)) + *info = -16; + else if (*lWork < lwmin && *lWork != -1) + *info = -20; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("STGSYL", &minfo); + return; + } + + if (*lWork == -1) { + // Work size query + *Work = lwmin; + return; + } + + // Clean char * arguments + const char cleantrans = notran ? 'N' : 'T'; + + // Constant + const float ZERO[] = { 0. }; + + int isolve = 1; + int ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + LAPACK(slaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(slaset)("F", m, n, ZERO, ZERO, F, ldF); + } else if (*ijob >= 1) + isolve = 2; + } + + float scale2; + int iround; + for (iround = 1; iround <= isolve; iround++) { + *scale = 1; + float dscale = 0; + float dsum = 1; + int pq; + RELAPACK_stgsyl_rec(&cleantrans, &ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, &dsum, &dscale, iWork, &pq, info); + if (dscale != 0) { + if (*ijob == 1 || *ijob == 3) + *dif = sqrt(2 * *m * *n) / (dscale * sqrt(dsum)); + else + *dif = sqrt(pq) / (dscale * sqrt(dsum)); + } + if (isolve == 2) { + if (iround == 1) { + if (notran) + ifunc = *ijob; + scale2 = *scale; + LAPACK(slacpy)("F", m, n, C, ldC, Work, m); + LAPACK(slacpy)("F", m, n, F, ldF, Work + *m * *n, m); + LAPACK(slaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(slaset)("F", m, n, ZERO, ZERO, F, ldF); + } else { + LAPACK(slacpy)("F", m, n, Work, m, C, ldC); + LAPACK(slacpy)("F", m, n, Work + *m * *n, m, F, ldF); + *scale = scale2; + } + } + } +} + + +/** stgsyl's recursive vompute kernel */ +static void RELAPACK_stgsyl_rec( + const char *trans, const int *ifunc, const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, + const float *D, const int *ldD, const float *E, const int *ldE, + float *F, const int *ldF, + float *scale, float *dsum, float *dscale, + int *iWork, int *pq, int *info +) { + + if (*m <= MAX(CROSSOVER_STGSYL, 1) && *n <= MAX(CROSSOVER_STGSYL, 1)) { + // Unblocked + LAPACK(stgsy2)(trans, ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dsum, dscale, iWork, pq, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const int iONE[] = { 1 }; + + // Outputs + float scale1[] = { 1. }; + float scale2[] = { 1. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + int m1 = SREC_SPLIT(*m); + if (A[m1 + *ldA * (m1 - 1)]) + m1++; + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const float *const A_TL = A; + const float *const A_TR = A + *ldA * m1; + const float *const A_BR = A + *ldA * m1 + m1; + + // C_T + // C_B + float *const C_T = C; + float *const C_B = C + m1; + + // D_TL D_TR + // 0 D_BR + const float *const D_TL = D; + const float *const D_TR = D + *ldD * m1; + const float *const D_BR = D + *ldD * m1 + m1; + + // F_T + // F_B + float *const F_T = F; + float *const F_B = F + m1; + + if (*trans == 'N') { + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_stgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale1, dsum, dscale, iWork, pq, info1); + // C_T = C_T - A_TR * C_B + BLAS(sgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // F_T = F_T - D_TR * C_B + BLAS(sgemm)("N", "N", &m1, n, &m2, MONE, D_TR, ldD, C_B, ldC, scale1, F_T, ldF); + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_stgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m2, n, F_B, ldF, info); + } + } else { + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_stgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale1, dsum, dscale, iWork, pq, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale1, &m2, n, F_B, ldF, info); + // C_B = C_B - A_TR^H * C_T + BLAS(sgemm)("T", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // C_B = C_B - D_TR^H * F_T + BLAS(sgemm)("T", "N", &m2, n, &m1, MONE, D_TR, ldD, F_T, ldC, ONE, C_B, ldC); + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_stgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_T, ldC, info); + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m1, n, F_T, ldF, info); + } + } + } else { + // Splitting + int n1 = SREC_SPLIT(*n); + if (B[n1 + *ldB * (n1 - 1)]) + n1++; + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const float *const B_TL = B; + const float *const B_TR = B + *ldB * n1; + const float *const B_BR = B + *ldB * n1 + n1; + + // C_L C_R + float *const C_L = C; + float *const C_R = C + *ldC * n1; + + // E_TL E_TR + // 0 E_BR + const float *const E_TL = E; + const float *const E_TR = E + *ldE * n1; + const float *const E_BR = E + *ldE * n1 + n1; + + // F_L F_R + float *const F_L = F; + float *const F_R = F + *ldF * n1; + + if (*trans == 'N') { + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_stgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale1, dsum, dscale, iWork, pq, info1); + // C_R = C_R + F_L * B_TR + BLAS(sgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, B_TR, ldB, scale1, C_R, ldC); + // F_R = F_R + F_L * E_TR + BLAS(sgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, E_TR, ldE, scale1, F_R, ldF); + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_stgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n1, F_L, ldF, info); + } + } else { + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_stgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale1, dsum, dscale, iWork, pq, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale1, m, &n1, C_L, ldC, info); + // F_L = F_L + C_R * B_TR + BLAS(sgemm)("N", "T", m, &n1, &n2, ONE, C_R, ldC, B_TR, ldB, scale1, F_L, ldF); + // F_L = F_L + F_R * E_TR + BLAS(sgemm)("N", "T", m, &n1, &n2, ONE, F_R, ldF, E_TR, ldB, ONE, F_L, ldF); + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_stgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale2, dsum, dscale, iWork, pq, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n2, F_R, ldF, info); + } + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/strsyl.c b/relapack/src/strsyl.c new file mode 100644 index 0000000000..83947ef1a0 --- /dev/null +++ b/relapack/src/strsyl.c @@ -0,0 +1,169 @@ +#include "relapack.h" + +static void RELAPACK_strsyl_rec(const char *, const char *, const int *, + const int *, const int *, const float *, const int *, const float *, + const int *, float *, const int *, float *, int *); + + +/** STRSYL solves the real Sylvester matrix equation. + * + * This routine is functionally equivalent to LAPACK's strsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d4/d7d/strsyl_8f.html + * */ +void RELAPACK_strsyl( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + + // Check arguments + const int notransA = LAPACK(lsame)(tranA, "N"); + const int transA = LAPACK(lsame)(tranA, "T"); + const int ctransA = LAPACK(lsame)(tranA, "C"); + const int notransB = LAPACK(lsame)(tranB, "N"); + const int transB = LAPACK(lsame)(tranB, "T"); + const int ctransB = LAPACK(lsame)(tranB, "C"); + *info = 0; + if (!transA && !ctransA && !notransA) + *info = -1; + else if (!transB && !ctransB && !notransB) + *info = -2; + else if (*isgn != 1 && *isgn != -1) + *info = -3; + else if (*m < 0) + *info = -4; + else if (*n < 0) + *info = -5; + else if (*ldA < MAX(1, *m)) + *info = -7; + else if (*ldB < MAX(1, *n)) + *info = -9; + else if (*ldC < MAX(1, *m)) + *info = -11; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("STRSYL", &minfo); + return; + } + + // Clean char * arguments + const char cleantranA = notransA ? 'N' : (transA ? 'T' : 'C'); + const char cleantranB = notransB ? 'N' : (transB ? 'T' : 'C'); + + // Recursive kernel + RELAPACK_strsyl_rec(&cleantranA, &cleantranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} + + +/** strsyl's recursive compute kernel */ +static void RELAPACK_strsyl_rec( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const float *A, const int *ldA, const float *B, const int *ldB, + float *C, const int *ldC, float *scale, + int *info +) { + + if (*m <= MAX(CROSSOVER_STRSYL, 1) && *n <= MAX(CROSSOVER_STRSYL, 1)) { + // Unblocked + RELAPACK_strsyl_rec2(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + const float MSGN[] = { -*isgn }; + const int iONE[] = { 1 }; + + // Outputs + float scale1[] = { 1. }; + float scale2[] = { 1. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + int m1 = SREC_SPLIT(*m); + if (A[m1 + *ldA * (m1 - 1)]) + m1++; + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const float *const A_TL = A; + const float *const A_TR = A + *ldA * m1; + const float *const A_BR = A + *ldA * m1 + m1; + + // C_T + // C_B + float *const C_T = C; + float *const C_B = C + m1; + + if (*tranA == 'N') { + // recusion(A_BR, B, C_B) + RELAPACK_strsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale1, info1); + // C_T = C_T - A_TR * C_B + BLAS(sgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // recusion(A_TL, B, C_T) + RELAPACK_strsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + } else { + // recusion(A_TL, B, C_T) + RELAPACK_strsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale1, info1); + // C_B = C_B - A_TR' * C_T + BLAS(sgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // recusion(A_BR, B, C_B) + RELAPACK_strsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_B, ldC, info); + } + } else { + // Splitting + int n1 = SREC_SPLIT(*n); + if (B[n1 + *ldB * (n1 - 1)]) + n1++; + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const float *const B_TL = B; + const float *const B_TR = B + *ldB * n1; + const float *const B_BR = B + *ldB * n1 + n1; + + // C_L C_R + float *const C_L = C; + float *const C_R = C + *ldC * n1; + + if (*tranB == 'N') { + // recusion(A, B_TL, C_L) + RELAPACK_strsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale1, info1); + // C_R = C_R -/+ C_L * B_TR + BLAS(sgemm)("N", "N", m, &n2, &n1, MSGN, C_L, ldC, B_TR, ldB, scale1, C_R, ldC); + // recusion(A, B_BR, C_R) + RELAPACK_strsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + } else { + // recusion(A, B_BR, C_R) + RELAPACK_strsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale1, info1); + // C_L = C_L -/+ C_R * B_TR' + BLAS(sgemm)("N", "C", m, &n1, &n2, MSGN, C_R, ldC, B_TR, ldB, scale1, C_L, ldC); + // recusion(A, B_TL, C_L) + RELAPACK_strsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(slascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/strsyl_rec2.c b/relapack/src/strsyl_rec2.c new file mode 100644 index 0000000000..6d40a475d7 --- /dev/null +++ b/relapack/src/strsyl_rec2.c @@ -0,0 +1,1029 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static int c__1 = 1; +static int c_false = FALSE_; +static int c__2 = 2; +static float c_b26 = 1.f; +static float c_b30 = 0.f; +static int c_true = TRUE_; + +void RELAPACK_strsyl_rec2(char *trana, char *tranb, int *isgn, int + *m, int *n, float *a, int *lda, float *b, int *ldb, float * + c__, int *ldc, float *scale, int *info, ftnlen trana_len, + ftnlen tranb_len) +{ + /* System generated locals */ + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + float r__1, r__2; + + /* Local variables */ + static int j, k, l; + static float x[4] /* was [2][2] */; + static int k1, k2, l1, l2; + static float a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn; + static int ierr; + static float smin; + extern float sdot_(int *, float *, int *, float *, int *); + static float suml, sumr; + extern int lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int sscal_(int *, float *, float *, int *); + static int knext, lnext; + static float xnorm; + extern /* Subroutine */ int slaln2_(int *, int *, int *, float + *, float *, float *, int *, float *, float *, float *, int *, + float *, float *, float *, int *, float *, float *, int *), + slasy2_(int *, int *, int *, int *, int *, + float *, int *, float *, int *, float *, int *, float *, + float *, int *, float *, int *), slabad_(float *, float *); + static float scaloc; + extern float slamch_(char *, ftnlen), slange_(char *, int *, + int *, float *, int *, float *, ftnlen); + extern /* Subroutine */ int xerbla_(char *, int *, ftnlen); + static float bignum; + static int notrna, notrnb; + static float smlnum; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N", (ftnlen)1, (ftnlen)1); + notrnb = lsame_(tranb, "N", (ftnlen)1, (ftnlen)1); + *info = 0; + if (! notrna && ! lsame_(trana, "T", (ftnlen)1, (ftnlen)1) && ! lsame_( + trana, "C", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "T", (ftnlen)1, (ftnlen)1) && ! + lsame_(tranb, "C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1,*m)) { + *info = -7; + } else if (*ldb < max(1,*n)) { + *info = -9; + } else if (*ldc < max(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRSYL", &i__1, (ftnlen)6); + return; + } + *scale = 1.f; + if (*m == 0 || *n == 0) { + return; + } + eps = slamch_("P", (ftnlen)1); + smlnum = slamch_("S", (ftnlen)1); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum = smlnum * (float) (*m * *n) / eps; + bignum = 1.f / smlnum; +/* Computing MAX */ + r__1 = smlnum, r__2 = eps * slange_("M", m, m, &a[a_offset], lda, dum, ( + ftnlen)1), r__1 = max(r__1,r__2), r__2 = eps * slange_("M", n, n, + &b[b_offset], ldb, dum, (ftnlen)1); + smin = dmax(r__1,r__2); + sgn = (float) (*isgn); + if (notrna && notrnb) { + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L70; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.f) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L60; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.f) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + if (l1 == l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = dabs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = dabs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L20: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + min(i__3,*m) * a_dim1], lda, & + c__[min(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + slasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + + k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, + &c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L50: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L60: + ; + } +L70: + ; + } + } else if (! notrna && notrnb) { + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L130; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.f) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + knext = 1; + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (k < knext) { + goto L120; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.f) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + if (l1 == l2 && k1 == k2) { + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = dabs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = dabs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L80: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + slasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L120: + ; + } +L130: + ; + } + } else if (! notrna && ! notrnb) { + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L190; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.f) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + knext = 1; + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + if (k < knext) { + goto L180; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.f) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + if (l1 == l2 && k1 == k2) { + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l1; +/* Computing MIN */ + i__3 = l1 + 1; +/* Computing MIN */ + i__4 = l1 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = dabs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = dabs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L160: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l1 + min(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + min(i__3,*n) * c_dim1], ldc, + &b[l2 + min(i__4,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + slasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * + a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L170: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L180: + ; + } +L190: + ; + } + } else if (notrna && ! notrnb) { + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L250; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.f) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L240; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.f) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + if (l1 == l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l1; +/* Computing MIN */ + i__2 = l1 + 1; +/* Computing MIN */ + i__3 = l1 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = dabs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = dabs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L200: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + } else if (l1 == l2 && k1 != k2) { + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L210: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L220: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + } else if (l1 != l2 && k1 != k2) { + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l1 + min(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + min(i__2,*m) * a_dim1], lda, & + c__[min(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + min(i__2,*n) * c_dim1], ldc, + &b[l2 + min(i__3,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + slasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L230: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } +L240: + ; + } +L250: + ; + } + } +} diff --git a/relapack/src/strtri.c b/relapack/src/strtri.c new file mode 100644 index 0000000000..d35bbd49f4 --- /dev/null +++ b/relapack/src/strtri.c @@ -0,0 +1,107 @@ +#include "relapack.h" + +static void RELAPACK_strtri_rec(const char *, const char *, const int *, + float *, const int *, int *); + + +/** CTRTRI computes the inverse of a real upper or lower triangular matrix A. + * + * This routine is functionally equivalent to LAPACK's strtri. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/de/d76/strtri_8f.html + * */ +void RELAPACK_strtri( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int nounit = LAPACK(lsame)(diag, "N"); + const int unit = LAPACK(lsame)(diag, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (!nounit && !unit) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("STRTRI", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleandiag = nounit ? 'N' : 'U'; + + // check for singularity + if (nounit) { + int i; + for (i = 0; i < *n; i++) + if (A[i + *ldA * i] == 0) { + *info = i; + return; + } + } + + // Recursive kernel + RELAPACK_strtri_rec(&cleanuplo, &cleandiag, n, A, ldA, info); +} + + +/** strtri's recursive compute kernel */ +static void RELAPACK_strtri_rec( + const char *uplo, const char *diag, const int *n, + float *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_STRTRI, 1)) { + // Unblocked + LAPACK(strti2)(uplo, diag, n, A, ldA, info); + return; + } + + // Constants + const float ONE[] = { 1. }; + const float MONE[] = { -1. }; + + // Splitting + const int n1 = SREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + float *const A_TL = A; + float *const A_TR = A + *ldA * n1; + float *const A_BL = A + n1; + float *const A_BR = A + *ldA * n1 + n1; + + // recursion(A_TL) + RELAPACK_strtri_rec(uplo, diag, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = - A_BL * A_TL + BLAS(strmm)("R", "L", "N", diag, &n2, &n1, MONE, A_TL, ldA, A_BL, ldA); + // A_BL = A_BR \ A_BL + BLAS(strsm)("L", "L", "N", diag, &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TR = - A_TL * A_TR + BLAS(strmm)("L", "U", "N", diag, &n1, &n2, MONE, A_TL, ldA, A_TR, ldA); + // A_TR = A_TR / A_BR + BLAS(strsm)("R", "U", "N", diag, &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_strtri_rec(uplo, diag, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/zgbtrf.c b/relapack/src/zgbtrf.c new file mode 100644 index 0000000000..3aa6bf5318 --- /dev/null +++ b/relapack/src/zgbtrf.c @@ -0,0 +1,230 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_zgbtrf_rec(const int *, const int *, const int *, + const int *, double *, const int *, int *, double *, const int *, double *, + const int *, int *); + + +/** ZGBTRF computes an LU factorization of a complex m-by-n band matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's zgbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dc/dcb/zgbtrf_8f.html + * */ +void RELAPACK_zgbtrf( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kl < 0) + *info = -3; + else if (*ku < 0) + *info = -4; + else if (*ldAb < 2 * *kl + *ku + 1) + *info = -6; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZGBTRF", &minfo); + return; + } + + // Constant + const double ZERO[] = { 0., 0. }; + + // Result upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + 2 * kv; + + // Zero upper diagonal fill-in elements + int i, j; + for (j = 0; j < *n; j++) { + double *const A_j = A + 2 * *ldA * j; + for (i = MAX(0, j - kv); i < j - *ku; i++) + A_j[2 * i] = A_j[2 * i + 1] = 0.; + } + + // Allocate work space + const int n1 = ZREC_SPLIT(*n); + const int mWorkl = (kv > n1) ? MAX(1, *m - *kl) : kv; + const int nWorkl = (kv > n1) ? n1 : kv; + const int mWorku = (*kl > n1) ? n1 : *kl; + const int nWorku = (*kl > n1) ? MAX(0, *n - *kl) : *kl; + double *Workl = malloc(mWorkl * nWorkl * 2 * sizeof(double)); + double *Worku = malloc(mWorku * nWorku * 2 * sizeof(double)); + LAPACK(zlaset)("L", &mWorkl, &nWorkl, ZERO, ZERO, Workl, &mWorkl); + LAPACK(zlaset)("U", &mWorku, &nWorku, ZERO, ZERO, Worku, &mWorku); + + // Recursive kernel + RELAPACK_zgbtrf_rec(m, n, kl, ku, Ab, ldAb, ipiv, Workl, &mWorkl, Worku, &mWorku, info); + + // Free work space + free(Workl); + free(Worku); +} + + +/** zgbtrf's recursive compute kernel */ +static void RELAPACK_zgbtrf_rec( + const int *m, const int *n, const int *kl, const int *ku, + double *Ab, const int *ldAb, int *ipiv, + double *Workl, const int *ldWorkl, double *Worku, const int *ldWorku, + int *info +) { + + if (*n <= MAX(CROSSOVER_ZGBTRF, 1)) { + // Unblocked + LAPACK(zgbtf2)(m, n, kl, ku, Ab, ldAb, ipiv, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Loop iterators + int i, j; + + // Output upper band width + const int kv = *ku + *kl; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + 2 * kv; + + // Splitting + const int n1 = MIN(ZREC_SPLIT(*n), *kl); + const int n2 = *n - n1; + const int m1 = MIN(n1, *m); + const int m2 = *m - m1; + const int mn1 = MIN(m1, n1); + const int mn2 = MIN(m2, n2); + + // Ab_L * + // Ab_BR + double *const Ab_L = Ab; + double *const Ab_BR = Ab + 2 * *ldAb * n1; + + // A_L A_R + double *const A_L = A; + double *const A_R = A + 2 * *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * m1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * m1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // Banded splitting + const int n21 = MIN(n2, kv - n1); + const int n22 = MIN(n2 - n21, n1); + const int m21 = MIN(m2, *kl - m1); + const int m22 = MIN(m2 - m21, m1); + + // n1 n21 n22 + // m * A_Rl ARr + double *const A_Rl = A_R; + double *const A_Rr = A_R + 2 * *ldA * n21; + + // n1 n21 n22 + // m1 * A_TRl A_TRr + // m21 A_BLt A_BRtl A_BRtr + // m22 A_BLb A_BRbl A_BRbr + double *const A_TRl = A_TR; + double *const A_TRr = A_TR + 2 * *ldA * n21; + double *const A_BLt = A_BL; + double *const A_BLb = A_BL + 2 * m21; + double *const A_BRtl = A_BR; + double *const A_BRtr = A_BR + 2 * *ldA * n21; + double *const A_BRbl = A_BR + 2 * m21; + double *const A_BRbr = A_BR + 2 * *ldA * n21 + 2 * m21; + + // recursion(Ab_L, ipiv_T) + RELAPACK_zgbtrf_rec(m, &n1, kl, ku, Ab_L, ldAb, ipiv_T, Workl, ldWorkl, Worku, ldWorku, info); + + // Workl = A_BLb + LAPACK(zlacpy)("U", &m22, &n1, A_BLb, ldA, Workl, ldWorkl); + + // partially redo swaps in A_L + for (i = 0; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(zswap)(&i, A_L + 2 * i, ldA, A_L + 2 * ip, ldA); + else + BLAS(zswap)(&i, A_L + 2 * i, ldA, Workl + 2 * (ip - *kl), ldWorkl); + } + } + + // apply pivots to A_Rl + LAPACK(zlaswp)(&n21, A_Rl, ldA, iONE, &mn1, ipiv_T, iONE); + + // apply pivots to A_Rr columnwise + for (j = 0; j < n22; j++) { + double *const A_Rrj = A_Rr + 2 * *ldA * j; + for (i = j; i < mn1; i++) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + const double tmpr = A_Rrj[2 * i]; + const double tmpc = A_Rrj[2 * i + 1]; + A_Rrj[2 * i] = A_Rrj[2 * ip]; + A_Rrj[2 * i + 1] = A_Rrj[2 * ip + 1]; + A_Rrj[2 * ip] = tmpr; + A_Rrj[2 * ip + 1] = tmpc; + } + } + } + + // A_TRl = A_TL \ A_TRl + BLAS(ztrsm)("L", "L", "N", "U", &m1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // Worku = A_TRr + LAPACK(zlacpy)("L", &m1, &n22, A_TRr, ldA, Worku, ldWorku); + // Worku = A_TL \ Worku + BLAS(ztrsm)("L", "L", "N", "U", &m1, &n22, ONE, A_TL, ldA, Worku, ldWorku); + // A_TRr = Worku + LAPACK(zlacpy)("L", &m1, &n22, Worku, ldWorku, A_TRr, ldA); + // A_BRtl = A_BRtl - A_BLt * A_TRl + BLAS(zgemm)("N", "N", &m21, &n21, &n1, MONE, A_BLt, ldA, A_TRl, ldA, ONE, A_BRtl, ldA); + // A_BRbl = A_BRbl - Workl * A_TRl + BLAS(zgemm)("N", "N", &m22, &n21, &n1, MONE, Workl, ldWorkl, A_TRl, ldA, ONE, A_BRbl, ldA); + // A_BRtr = A_BRtr - A_BLt * Worku + BLAS(zgemm)("N", "N", &m21, &n22, &n1, MONE, A_BLt, ldA, Worku, ldWorku, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Workl * Worku + BLAS(zgemm)("N", "N", &m22, &n22, &n1, MONE, Workl, ldWorkl, Worku, ldWorku, ONE, A_BRbr, ldA); + + // partially undo swaps in A_L + for (i = mn1 - 1; i >= 0; i--) { + const int ip = ipiv_T[i] - 1; + if (ip != i) { + if (ip < *kl) + BLAS(zswap)(&i, A_L + 2 * i, ldA, A_L + 2 * ip, ldA); + else + BLAS(zswap)(&i, A_L + 2 * i, ldA, Workl + 2 * (ip - *kl), ldWorkl); + } + } + + // recursion(Ab_BR, ipiv_B) + RELAPACK_zgbtrf_rec(&m2, &n2, kl, ku, Ab_BR, ldAb, ipiv_B, Workl, ldWorkl, Worku, ldWorku, info); + if (*info) + *info += n1; + // shift pivots + for (i = 0; i < mn2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/zgemmt.c b/relapack/src/zgemmt.c new file mode 100644 index 0000000000..aa59302386 --- /dev/null +++ b/relapack/src/zgemmt.c @@ -0,0 +1,167 @@ +#include "relapack.h" + +static void RELAPACK_zgemmt_rec(const char *, const char *, const char *, + const int *, const int *, const double *, const double *, const int *, + const double *, const int *, const double *, double *, const int *); + +static void RELAPACK_zgemmt_rec2(const char *, const char *, const char *, + const int *, const int *, const double *, const double *, const int *, + const double *, const int *, const double *, double *, const int *); + + +/** ZGEMMT computes a matrix-matrix product with general matrices but updates + * only the upper or lower triangular part of the result matrix. + * + * This routine performs the same operation as the BLAS routine + * zgemm(transA, transB, n, n, k, alpha, A, ldA, B, ldB, beta, C, ldC) + * but only updates the triangular part of C specified by uplo: + * If (*uplo == 'L'), only the lower triangular part of C is updated, + * otherwise the upper triangular part is updated. + * */ +void RELAPACK_zgemmt( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + +#if HAVE_XGEMMT + BLAS(zgemmt)(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; +#else + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int notransA = LAPACK(lsame)(transA, "N"); + const int tranA = LAPACK(lsame)(transA, "T"); + const int ctransA = LAPACK(lsame)(transA, "C"); + const int notransB = LAPACK(lsame)(transB, "N"); + const int tranB = LAPACK(lsame)(transB, "T"); + const int ctransB = LAPACK(lsame)(transB, "C"); + int info = 0; + if (!lower && !upper) + info = 1; + else if (!tranA && !ctransA && !notransA) + info = 2; + else if (!tranB && !ctransB && !notransB) + info = 3; + else if (*n < 0) + info = 4; + else if (*k < 0) + info = 5; + else if (*ldA < MAX(1, notransA ? *n : *k)) + info = 8; + else if (*ldB < MAX(1, notransB ? *k : *n)) + info = 10; + else if (*ldC < MAX(1, *n)) + info = 13; + if (info) { + LAPACK(xerbla)("ZGEMMT", &info); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleantransA = notransA ? 'N' : (tranA ? 'T' : 'C'); + const char cleantransB = notransB ? 'N' : (tranB ? 'T' : 'C'); + + // Recursive kernel + RELAPACK_zgemmt_rec(&cleanuplo, &cleantransA, &cleantransB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); +#endif +} + + +/** zgemmt's recursive compute kernel */ +static void RELAPACK_zgemmt_rec( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + + if (*n <= MAX(CROSSOVER_ZGEMMT, 1)) { + // Unblocked + RELAPACK_zgemmt_rec2(uplo, transA, transB, n, k, alpha, A, ldA, B, ldB, beta, C, ldC); + return; + } + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_T + // A_B + const double *const A_T = A; + const double *const A_B = A + 2 * ((*transA == 'N') ? n1 : *ldA * n1); + + // B_L B_R + const double *const B_L = B; + const double *const B_R = B + 2 * ((*transB == 'N') ? *ldB * n1 : n1); + + // C_TL C_TR + // C_BL C_BR + double *const C_TL = C; + double *const C_TR = C + 2 * *ldC * n1; + double *const C_BL = C + 2 * n1; + double *const C_BR = C + 2 * *ldC * n1 + 2 * n1; + + // recursion(C_TL) + RELAPACK_zgemmt_rec(uplo, transA, transB, &n1, k, alpha, A_T, ldA, B_L, ldB, beta, C_TL, ldC); + + if (*uplo == 'L') + // C_BL = alpha A_B B_L + beta C_BL + BLAS(zgemm)(transA, transB, &n2, &n1, k, alpha, A_B, ldA, B_L, ldB, beta, C_BL, ldC); + else + // C_TR = alpha A_T B_R + beta C_TR + BLAS(zgemm)(transA, transB, &n1, &n2, k, alpha, A_T, ldA, B_R, ldB, beta, C_TR, ldC); + + // recursion(C_BR) + RELAPACK_zgemmt_rec(uplo, transA, transB, &n2, k, alpha, A_B, ldA, B_R, ldB, beta, C_BR, ldC); +} + + +/** zgemmt's unblocked compute kernel */ +static void RELAPACK_zgemmt_rec2( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const double *alpha, const double *A, const int *ldA, + const double *B, const int *ldB, + const double *beta, double *C, const int *ldC +) { + + const int incB = (*transB == 'N') ? 1 : *ldB; + const int incC = 1; + + int i; + for (i = 0; i < *n; i++) { + // A_0 + // A_i + const double *const A_0 = A; + const double *const A_i = A + 2 * ((*transA == 'N') ? i : *ldA * i); + + // * B_i * + const double *const B_i = B + 2 * ((*transB == 'N') ? *ldB * i : i); + + // * C_0i * + // * C_ii * + double *const C_0i = C + 2 * *ldC * i; + double *const C_ii = C + 2 * *ldC * i + 2 * i; + + if (*uplo == 'L') { + const int nmi = *n - i; + if (*transA == 'N') + BLAS(zgemv)(transA, &nmi, k, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + else + BLAS(zgemv)(transA, k, &nmi, alpha, A_i, ldA, B_i, &incB, beta, C_ii, &incC); + } else { + const int ip1 = i + 1; + if (*transA == 'N') + BLAS(zgemv)(transA, &ip1, k, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + else + BLAS(zgemv)(transA, k, &ip1, alpha, A_0, ldA, B_i, &incB, beta, C_0i, &incC); + } + } +} diff --git a/relapack/src/zgetrf.c b/relapack/src/zgetrf.c new file mode 100644 index 0000000000..cf8921e1f0 --- /dev/null +++ b/relapack/src/zgetrf.c @@ -0,0 +1,117 @@ +#include "relapack.h" + +static void RELAPACK_zgetrf_rec(const int *, const int *, double *, + const int *, int *, int *); + + +/** ZGETRF computes an LU factorization of a general M-by-N matrix A using partial pivoting with row interchanges. + * + * This routine is functionally equivalent to LAPACK's zgetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dd/dd1/zgetrf_8f.html + * */ +void RELAPACK_zgetrf( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + + // Check arguments + *info = 0; + if (*m < 0) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZGETRF", &minfo); + return; + } + + const int sn = MIN(*m, *n); + + RELAPACK_zgetrf_rec(m, &sn, A, ldA, ipiv, info); + + // Right remainder + if (*m < *n) { + // Constants + const double ONE[] = { 1., 0. }; + const int iONE[] = { 1 }; + + // Splitting + const int rn = *n - *m; + + // A_L A_R + const double *const A_L = A; + double *const A_R = A + 2 * *ldA * *m; + + // A_R = apply(ipiv, A_R) + LAPACK(zlaswp)(&rn, A_R, ldA, iONE, m, ipiv, iONE); + // A_R = A_L \ A_R + BLAS(ztrsm)("L", "L", "N", "U", m, &rn, ONE, A_L, ldA, A_R, ldA); + } +} + + +/** zgetrf's recursive compute kernel */ +static void RELAPACK_zgetrf_rec( + const int *m, const int *n, + double *A, const int *ldA, int *ipiv, + int *info +) { + + if (*n <= MAX(CROSSOVER_ZGETRF, 1)) { + // Unblocked + LAPACK(zgetf2)(m, n, A, ldA, ipiv, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1. }; + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + const int m2 = *m - n1; + + // A_L A_R + double *const A_L = A; + double *const A_R = A + 2 * *ldA * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // ipiv_T + // ipiv_B + int *const ipiv_T = ipiv; + int *const ipiv_B = ipiv + n1; + + // recursion(A_L, ipiv_T) + RELAPACK_zgetrf_rec(m, &n1, A_L, ldA, ipiv_T, info); + // apply pivots to A_R + LAPACK(zlaswp)(&n2, A_R, ldA, iONE, &n1, ipiv_T, iONE); + + // A_TR = A_TL \ A_TR + BLAS(ztrsm)("L", "L", "N", "U", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_BL * A_TR + BLAS(zgemm)("N", "N", &m2, &n2, &n1, MONE, A_BL, ldA, A_TR, ldA, ONE, A_BR, ldA); + + // recursion(A_BR, ipiv_B) + RELAPACK_zgetrf_rec(&m2, &n2, A_BR, ldA, ipiv_B, info); + if (*info) + *info += n1; + // apply pivots to A_BL + LAPACK(zlaswp)(&n1, A_BL, ldA, iONE, &n2, ipiv_B, iONE); + // shift pivots + int i; + for (i = 0; i < n2; i++) + ipiv_B[i] += n1; +} diff --git a/relapack/src/zhegst.c b/relapack/src/zhegst.c new file mode 100644 index 0000000000..d0ece21481 --- /dev/null +++ b/relapack/src/zhegst.c @@ -0,0 +1,212 @@ +#include "relapack.h" +#if XSYGST_ALLOW_MALLOC +#include "stdlib.h" +#endif + +static void RELAPACK_zhegst_rec(const int *, const char *, const int *, + double *, const int *, const double *, const int *, + double *, const int *, int *); + + +/** ZHEGST reduces a complex Hermitian-definite generalized eigenproblem to standard form. + * + * This routine is functionally equivalent to LAPACK's zhegst. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/dc/d68/zhegst_8f.html + * */ +void RELAPACK_zhegst( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (*itype < 1 || *itype > 3) + *info = -1; + else if (!lower && !upper) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + else if (*ldB < MAX(1, *n)) + *info = -7; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZHEGST", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Allocate work space + double *Work = NULL; + int lWork = 0; +#if XSYGST_ALLOW_MALLOC + const int n1 = ZREC_SPLIT(*n); + lWork = n1 * (*n - n1); + Work = malloc(lWork * 2 * sizeof(double)); + if (!Work) + lWork = 0; +#endif + + // recursive kernel + RELAPACK_zhegst_rec(itype, &cleanuplo, n, A, ldA, B, ldB, Work, &lWork, info); + + // Free work space +#if XSYGST_ALLOW_MALLOC + if (Work) + free(Work); +#endif +} + + +/** zhegst's recursive compute kernel */ +static void RELAPACK_zhegst_rec( + const int *itype, const char *uplo, const int *n, + double *A, const int *ldA, const double *B, const int *ldB, + double *Work, const int *lWork, int *info +) { + + if (*n <= MAX(CROSSOVER_ZHEGST, 1)) { + // Unblocked + LAPACK(zhegs2)(itype, uplo, n, A, ldA, B, ldB, info); + return; + } + + // Constants + const double ZERO[] = { 0., 0. }; + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const double HALF[] = { .5, 0. }; + const double MHALF[] = { -.5, 0. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // B_TL B_TR + // B_BL B_BR + const double *const B_TL = B; + const double *const B_TR = B + 2 * *ldB * n1; + const double *const B_BL = B + 2 * n1; + const double *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // recursion(A_TL, B_TL) + RELAPACK_zhegst_rec(itype, uplo, &n1, A_TL, ldA, B_TL, ldB, Work, lWork, info); + + if (*itype == 1) + if (*uplo == 'L') { + // A_BL = A_BL / B_TL' + BLAS(ztrsm)("R", "L", "C", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork >= n2 * n1) { + // T = -1/2 * B_BL * A_TL + BLAS(zhemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(zaxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + } else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(zhemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BR = A_BR - A_BL * B_BL' - B_BL * A_BL' + BLAS(zher2k)("L", "N", &n2, &n1, MONE, A_BL, ldA, B_BL, ldB, ONE, A_BR, ldA); + if (*lWork >= n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(zaxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + else + // A_BL = A_BL - 1/2 B_BL * A_TL + BLAS(zhemm)("R", "L", &n2, &n1, MHALF, A_TL, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR \ A_BL + BLAS(ztrsm)("L", "L", "N", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL' \ A_TR + BLAS(ztrsm)("L", "U", "C", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork >= n2 * n1) { + // T = -1/2 * A_TL * B_TR + BLAS(zhemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(zaxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + } else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(zhemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_BR = A_BR - A_TR' * B_TR - B_TR' * A_TR + BLAS(zher2k)("U", "C", &n2, &n1, MONE, A_TR, ldA, B_TR, ldB, ONE, A_BR, ldA); + if (*lWork >= n2 * n1) + // A_TR = A_BL + T + for (i = 0; i < n2; i++) + BLAS(zaxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + else + // A_TR = A_TR - 1/2 A_TL * B_TR + BLAS(zhemm)("L", "U", &n1, &n2, MHALF, A_TL, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR / B_BR + BLAS(ztrsm)("R", "U", "N", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + else + if (*uplo == 'L') { + // A_BL = A_BL * B_TL + BLAS(ztrmm)("R", "L", "N", "N", &n2, &n1, ONE, B_TL, ldB, A_BL, ldA); + if (*lWork >= n2 * n1) { + // T = 1/2 * A_BR * B_BL + BLAS(zhemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ZERO, Work, &n2); + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(zaxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + } else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(zhemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_TL = A_TL + A_BL' * B_BL + B_BL' * A_BL + BLAS(zher2k)("L", "C", &n1, &n2, ONE, A_BL, ldA, B_BL, ldB, ONE, A_TL, ldA); + if (*lWork >= n2 * n1) + // A_BL = A_BL + T + for (i = 0; i < n1; i++) + BLAS(zaxpy)(&n2, ONE, Work + 2 * n2 * i, iONE, A_BL + 2 * *ldA * i, iONE); + else + // A_BL = A_BL + 1/2 A_BR * B_BL + BLAS(zhemm)("L", "L", &n2, &n1, HALF, A_BR, ldA, B_BL, ldB, ONE, A_BL, ldA); + // A_BL = B_BR * A_BL + BLAS(ztrmm)("L", "L", "C", "N", &n2, &n1, ONE, B_BR, ldB, A_BL, ldA); + } else { + // A_TR = B_TL * A_TR + BLAS(ztrmm)("L", "U", "N", "N", &n1, &n2, ONE, B_TL, ldB, A_TR, ldA); + if (*lWork >= n2 * n1) { + // T = 1/2 * B_TR * A_BR + BLAS(zhemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ZERO, Work, &n1); + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(zaxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + } else + // A_TR = A_TR + 1/2 B_TR A_BR + BLAS(zhemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TL = A_TL + A_TR * B_TR' + B_TR * A_TR' + BLAS(zher2k)("U", "N", &n1, &n2, ONE, A_TR, ldA, B_TR, ldB, ONE, A_TL, ldA); + if (*lWork >= n2 * n1) + // A_TR = A_TR + T + for (i = 0; i < n2; i++) + BLAS(zaxpy)(&n1, ONE, Work + 2 * n1 * i, iONE, A_TR + 2 * *ldA * i, iONE); + else + // A_TR = A_TR + 1/2 B_TR * A_BR + BLAS(zhemm)("R", "U", &n1, &n2, HALF, A_BR, ldA, B_TR, ldB, ONE, A_TR, ldA); + // A_TR = A_TR * B_BR + BLAS(ztrmm)("R", "U", "C", "N", &n1, &n2, ONE, B_BR, ldB, A_TR, ldA); + } + + // recursion(A_BR, B_BR) + RELAPACK_zhegst_rec(itype, uplo, &n2, A_BR, ldA, B_BR, ldB, Work, lWork, info); +} diff --git a/relapack/src/zhetrf.c b/relapack/src/zhetrf.c new file mode 100644 index 0000000000..ef4e1f5d5d --- /dev/null +++ b/relapack/src/zhetrf.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_zhetrf_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** ZHETRF computes the factorization of a complex Hermitian matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's zhetrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d6/dd3/zhetrf_8f.html + * */ +void RELAPACK_zhetrf( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZHETRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_zhetrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** zhetrf's recursive compute kernel */ +static void RELAPACK_zhetrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_ZHETRF, 3)) { + // Unblocked + if (top) { + LAPACK(zhetf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_zhetrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = ZREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_zhetrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + double *const A_BL_B = A + 2 * *n; + double *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + 2 * n1; + double *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_zgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_zhetrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(zgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = ZREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_zhetrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + 2 * *ldA * n_rest; + double *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + double *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + double *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_zgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_zhetrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(zgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/zhetrf_rec2.c b/relapack/src/zhetrf_rec2.c new file mode 100644 index 0000000000..867ea64e15 --- /dev/null +++ b/relapack/src/zhetrf_rec2.c @@ -0,0 +1,524 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static doublecomplex c_b1 = {1.,0.}; +static int c__1 = 1; + +/** ZHETRF_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kau fman diagonal pivoting method + * + * This routine is a minor modification of LAPACK's zlahef. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_zhetrf_rec2(char *uplo, int *n, int * + nb, int *kb, doublecomplex *a, int *lda, int *ipiv, + doublecomplex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + double sqrt(double), d_imag(doublecomplex *); + void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *, + doublecomplex *, doublecomplex *); + + /* Local variables */ + static int j, k; + static double t, r1; + static doublecomplex d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static double alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + static int kstep; + extern /* Subroutine */ int zgemv_(char *, int *, int *, + doublecomplex *, doublecomplex *, int *, doublecomplex *, + int *, doublecomplex *, doublecomplex *, int *, ftnlen), + zcopy_(int *, doublecomplex *, int *, doublecomplex *, + int *), zswap_(int *, doublecomplex *, int *, + doublecomplex *, int *); + static double absakk; + extern /* Subroutine */ int zdscal_(int *, double *, + doublecomplex *, int *); + static double colmax; + extern /* Subroutine */ int zlacgv_(int *, doublecomplex *, int *) + ; + extern int izamax_(int *, doublecomplex *, int *); + static double rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - 1; + zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (kw - 1) * w_dim1]), abs(d__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs( + d__2)); + rowmax = max(d__3,d__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) { + kp = imax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + r1 = 1. / a[i__1].r; + i__1 = k - 1; + zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + kw * w_dim1], &z__2); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + z__2.r = t, z__2.i = 0.; + z_div(&z__1, &z__2, &d21); + d21.r = z__1.r, d21.i = z__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__2, &d21); + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (ftnlen)12); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (imax < *n) { + i__1 = *n - imax; + zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (k + 1) * w_dim1]), abs(d__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs( + d__2)); + rowmax = max(d__3,d__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) { + kp = imax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k + kstep - 1; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + r1 = 1. / a[i__1].r; + i__1 = *n - k; + zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + k * w_dim1], &z__2); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + z__2.r = t, z__2.i = 0.; + z_div(&z__1, &z__2, &d21); + d21.r = z__1.r, d21.i = z__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + d_cnjg(&z__2, &d21); + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/zhetrf_rook.c b/relapack/src/zhetrf_rook.c new file mode 100644 index 0000000000..15ceaeae7a --- /dev/null +++ b/relapack/src/zhetrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_zhetrf_rook_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's zhetrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d6/d6f/zhetrf__rook_8f.html + * */ +void RELAPACK_zhetrf_rook( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZHETRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_zhetrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** zhetrf_rook's recursive compute kernel */ +static void RELAPACK_zhetrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_ZHETRF_ROOK, 3)) { + // Unblocked + if (top) { + LAPACK(zhetf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_zhetrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = ZREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_zhetrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + double *const A_BL_B = A + 2 * *n; + double *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + 2 * n1; + double *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_zgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_zhetrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(zgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = ZREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_zhetrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + 2 * *ldA * n_rest; + double *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + double *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + double *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_zgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_zhetrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(zgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/zhetrf_rook_rec2.c b/relapack/src/zhetrf_rook_rec2.c new file mode 100644 index 0000000000..a56ad710b7 --- /dev/null +++ b/relapack/src/zhetrf_rook_rec2.c @@ -0,0 +1,662 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static doublecomplex c_b1 = {1.,0.}; +static int c__1 = 1; + +/** ZHETRF_ROOK_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the boun ded Bunch-Kaufman ("rook") diagonal pivoting method + * + * This routine is a minor modification of LAPACK's zlahef_rook. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_zhetrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, doublecomplex *a, int *lda, int * + ipiv, doublecomplex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + double d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Builtin functions */ + double sqrt(double), d_imag(doublecomplex *); + void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *, + doublecomplex *, doublecomplex *); + + /* Local variables */ + static int j, k, p; + static double t, r1; + static doublecomplex d11, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static double alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + static double dtemp, sfmin; + static int itemp, kstep; + extern /* Subroutine */ int zgemv_(char *, int *, int *, + doublecomplex *, doublecomplex *, int *, doublecomplex *, + int *, doublecomplex *, doublecomplex *, int *, ftnlen), + zcopy_(int *, doublecomplex *, int *, doublecomplex *, + int *), zswap_(int *, doublecomplex *, int *, + doublecomplex *, int *); + extern double dlamch_(char *, ftnlen); + static double absakk; + extern /* Subroutine */ int zdscal_(int *, double *, + doublecomplex *, int *); + static double colmax; + extern /* Subroutine */ int zlacgv_(int *, doublecomplex *, int *) + ; + extern int izamax_(int *, doublecomplex *, int *); + static double rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + sfmin = dlamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], & + c__1); + } + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], + &c__1); + } + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + if (imax > 1) { + i__1 = imax - 1; + zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + } + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + kp = imax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k - 1 - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + i__1 = k - 1 - p; + zlacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda); + if (p > 1) { + i__1 = p - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = k - 1; + zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + kw * w_dim1], &z__2); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + ++jj; + if (kstep == 2 && jp1 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k * + a_dim1], &c__1); + } + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (imax < *n) { + i__1 = *n - imax; + zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + kp = imax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = p - k - 1; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * + a_dim1], lda); + i__1 = p - k - 1; + zlacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda); + if (p < *n) { + i__1 = *n - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = *n - k; + zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + k * w_dim1], &z__2); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + zswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + --jj; + if (kstep == 2 && jp1 != jj && j >= 1) { + zswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/zlauum.c b/relapack/src/zlauum.c new file mode 100644 index 0000000000..490dcc82e9 --- /dev/null +++ b/relapack/src/zlauum.c @@ -0,0 +1,87 @@ +#include "relapack.h" + +static void RELAPACK_zlauum_rec(const char *, const int *, double *, + const int *, int *); + + +/** ZLAUUM computes the product U * U**H or L**H * L, where the triangular factor U or L is stored in the upper or lower triangular part of the array A. + * + * This routine is functionally equivalent to LAPACK's zlauum. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d8/d45/zlauum_8f.html + * */ +void RELAPACK_zlauum( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZLAUUM", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_zlauum_rec(&cleanuplo, n, A, ldA, info); +} + + +/** zlauum's recursive compute kernel */ +static void RELAPACK_zlauum_rec( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_ZLAUUM, 1)) { + // Unblocked + LAPACK(zlauu2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_zlauum_rec(uplo, &n1, A_TL, ldA, info); + + if (*uplo == 'L') { + // A_TL = A_TL + A_BL' * A_BL + BLAS(zherk)("L", "C", &n1, &n2, ONE, A_BL, ldA, ONE, A_TL, ldA); + // A_BL = A_BR' * A_BL + BLAS(ztrmm)("L", "L", "C", "N", &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TL = A_TL + A_TR * A_TR' + BLAS(zherk)("U", "N", &n1, &n2, ONE, A_TR, ldA, ONE, A_TL, ldA); + // A_TR = A_TR * A_BR' + BLAS(ztrmm)("R", "U", "C", "N", &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_zlauum_rec(uplo, &n2, A_BR, ldA, info); +} diff --git a/relapack/src/zpbtrf.c b/relapack/src/zpbtrf.c new file mode 100644 index 0000000000..37e711c9dd --- /dev/null +++ b/relapack/src/zpbtrf.c @@ -0,0 +1,157 @@ +#include "relapack.h" +#include "stdlib.h" + +static void RELAPACK_zpbtrf_rec(const char *, const int *, const int *, + double *, const int *, double *, const int *, int *); + + +/** ZPBTRF computes the Cholesky factorization of a complex Hermitian positive definite band matrix A. + * + * This routine is functionally equivalent to LAPACK's zpbtrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/db/da9/zpbtrf_8f.html + * */ +void RELAPACK_zpbtrf( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*kd < 0) + *info = -3; + else if (*ldAb < *kd + 1) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZPBTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Constant + const double ZERO[] = { 0., 0. }; + + // Allocate work space + const int n1 = ZREC_SPLIT(*n); + const int mWork = (*kd > n1) ? (lower ? *n - *kd : n1) : *kd; + const int nWork = (*kd > n1) ? (lower ? n1 : *n - *kd) : *kd; + double *Work = malloc(mWork * nWork * 2 * sizeof(double)); + LAPACK(zlaset)(uplo, &mWork, &nWork, ZERO, ZERO, Work, &mWork); + + // Recursive kernel + RELAPACK_zpbtrf_rec(&cleanuplo, n, kd, Ab, ldAb, Work, &mWork, info); + + // Free work space + free(Work); +} + + +/** zpbtrf's recursive compute kernel */ +static void RELAPACK_zpbtrf_rec( + const char *uplo, const int *n, const int *kd, + double *Ab, const int *ldAb, + double *Work, const int *ldWork, + int *info +){ + + if (*n <= MAX(CROSSOVER_ZPBTRF, 1)) { + // Unblocked + LAPACK(zpbtf2)(uplo, n, kd, Ab, ldAb, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + + // Unskew A + const int ldA[] = { *ldAb - 1 }; + double *const A = Ab + 2 * ((*uplo == 'L') ? 0 : *kd); + + // Splitting + const int n1 = MIN(ZREC_SPLIT(*n), *kd); + const int n2 = *n - n1; + + // * * + // * Ab_BR + double *const Ab_BR = Ab + 2 * *ldAb * n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_zpotrf(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + // Banded splitting + const int n21 = MIN(n2, *kd - n1); + const int n22 = MIN(n2 - n21, *kd); + + // n1 n21 n22 + // n1 * A_TRl A_TRr + // n21 A_BLt A_BRtl A_BRtr + // n22 A_BLb A_BRbl A_BRbr + double *const A_TRl = A_TR; + double *const A_TRr = A_TR + 2 * *ldA * n21; + double *const A_BLt = A_BL; + double *const A_BLb = A_BL + 2 * n21; + double *const A_BRtl = A_BR; + double *const A_BRtr = A_BR + 2 * *ldA * n21; + double *const A_BRbl = A_BR + 2 * n21; + double *const A_BRbr = A_BR + 2 * *ldA * n21 + 2 * n21; + + if (*uplo == 'L') { + // A_BLt = ABLt / A_TL' + BLAS(ztrsm)("R", "L", "C", "N", &n21, &n1, ONE, A_TL, ldA, A_BLt, ldA); + // A_BRtl = A_BRtl - A_BLt * A_BLt' + BLAS(zherk)("L", "N", &n21, &n1, MONE, A_BLt, ldA, ONE, A_BRtl, ldA); + // Work = A_BLb + LAPACK(zlacpy)("U", &n22, &n1, A_BLb, ldA, Work, ldWork); + // Work = Work / A_TL' + BLAS(ztrsm)("R", "L", "C", "N", &n22, &n1, ONE, A_TL, ldA, Work, ldWork); + // A_BRbl = A_BRbl - Work * A_BLt' + BLAS(zgemm)("N", "C", &n22, &n21, &n1, MONE, Work, ldWork, A_BLt, ldA, ONE, A_BRbl, ldA); + // A_BRbr = A_BRbr - Work * Work' + BLAS(zherk)("L", "N", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_BLb = Work + LAPACK(zlacpy)("U", &n22, &n1, Work, ldWork, A_BLb, ldA); + } else { + // A_TRl = A_TL' \ A_TRl + BLAS(ztrsm)("L", "U", "C", "N", &n1, &n21, ONE, A_TL, ldA, A_TRl, ldA); + // A_BRtl = A_BRtl - A_TRl' * A_TRl + BLAS(zherk)("U", "C", &n21, &n1, MONE, A_TRl, ldA, ONE, A_BRtl, ldA); + // Work = A_TRr + LAPACK(zlacpy)("L", &n1, &n22, A_TRr, ldA, Work, ldWork); + // Work = A_TL' \ Work + BLAS(ztrsm)("L", "U", "C", "N", &n1, &n22, ONE, A_TL, ldA, Work, ldWork); + // A_BRtr = A_BRtr - A_TRl' * Work + BLAS(zgemm)("C", "N", &n21, &n22, &n1, MONE, A_TRl, ldA, Work, ldWork, ONE, A_BRtr, ldA); + // A_BRbr = A_BRbr - Work' * Work + BLAS(zherk)("U", "C", &n22, &n1, MONE, Work, ldWork, ONE, A_BRbr, ldA); + // A_TRr = Work + LAPACK(zlacpy)("L", &n1, &n22, Work, ldWork, A_TRr, ldA); + } + + // recursion(A_BR) + if (*kd > n1) + RELAPACK_zpotrf(uplo, &n2, A_BR, ldA, info); + else + RELAPACK_zpbtrf_rec(uplo, &n2, kd, Ab_BR, ldAb, Work, ldWork, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/zpotrf.c b/relapack/src/zpotrf.c new file mode 100644 index 0000000000..411ac5fc0c --- /dev/null +++ b/relapack/src/zpotrf.c @@ -0,0 +1,92 @@ +#include "relapack.h" + +static void RELAPACK_zpotrf_rec(const char *, const int *, double *, + const int *, int *); + + +/** ZPOTRF computes the Cholesky factorization of a complex Hermitian positive definite matrix A. + * + * This routine is functionally equivalent to LAPACK's zpotrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d1/db9/zpotrf_8f.html + * */ +void RELAPACK_zpotrf( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZPOTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Recursive kernel + RELAPACK_zpotrf_rec(&cleanuplo, n, A, ldA, info); +} + + +/** zpotrf's recursive compute kernel */ +static void RELAPACK_zpotrf_rec( + const char *uplo, const int *n, + double *A, const int *ldA, + int *info +) { + + if (*n <= MAX(CROSSOVER_ZPOTRF, 1)) { + // Unblocked + LAPACK(zpotf2)(uplo, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_zpotrf_rec(uplo, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = A_BL / A_TL' + BLAS(ztrsm)("R", "L", "C", "N", &n2, &n1, ONE, A_TL, ldA, A_BL, ldA); + // A_BR = A_BR - A_BL * A_BL' + BLAS(zherk)("L", "N", &n2, &n1, MONE, A_BL, ldA, ONE, A_BR, ldA); + } else { + // A_TR = A_TL' \ A_TR + BLAS(ztrsm)("L", "U", "C", "N", &n1, &n2, ONE, A_TL, ldA, A_TR, ldA); + // A_BR = A_BR - A_TR' * A_TR + BLAS(zherk)("U", "C", &n2, &n1, MONE, A_TR, ldA, ONE, A_BR, ldA); + } + + // recursion(A_BR) + RELAPACK_zpotrf_rec(uplo, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/src/zsytrf.c b/relapack/src/zsytrf.c new file mode 100644 index 0000000000..3be21563a7 --- /dev/null +++ b/relapack/src/zsytrf.c @@ -0,0 +1,238 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_zsytrf_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** ZSYTRF computes the factorization of a complex symmetric matrix A using the Bunch-Kaufman diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's zsytrf. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/da/d94/zsytrf_8f.html + * */ +void RELAPACK_zsytrf( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy arguments + int nout; + + // Recursive kernel + RELAPACK_zsytrf_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** zsytrf's recursive compute kernel */ +static void RELAPACK_zsytrf_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_ZSYTRF, 3)) { + // Unblocked + if (top) { + LAPACK(zsytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_zsytrf_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Loop iterator + int i; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = ZREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_zsytrf_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + double *const A_BL_B = A + 2 * *n; + double *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + 2 * n1; + double *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_zgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_zsytrf_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(zgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = ZREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_zsytrf_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + 2 * *ldA * n_rest; + double *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + double *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + double *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_zgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_zsytrf_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(zgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/zsytrf_rec2.c b/relapack/src/zsytrf_rec2.c new file mode 100644 index 0000000000..33902ee9ed --- /dev/null +++ b/relapack/src/zsytrf_rec2.c @@ -0,0 +1,452 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static doublecomplex c_b1 = {1.,0.}; +static int c__1 = 1; + +/** ZSYTRF_REC2 computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagon al pivoting method. + * + * This routine is a minor modification of LAPACK's zlasyf. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_zsytrf_rec2(char *uplo, int *n, int * + nb, int *kb, doublecomplex *a, int *lda, int *ipiv, + doublecomplex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + double sqrt(double), d_imag(doublecomplex *); + void z_div(doublecomplex *, doublecomplex *, doublecomplex *); + + /* Local variables */ + static int j, k; + static doublecomplex t, r1, d11, d21, d22; + static int jj, kk, jp, kp, kw, kkw, imax, jmax; + static double alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern /* Subroutine */ int zscal_(int *, doublecomplex *, + doublecomplex *, int *); + static int kstep; + extern /* Subroutine */ int zgemv_(char *, int *, int *, + doublecomplex *, doublecomplex *, int *, doublecomplex *, + int *, doublecomplex *, doublecomplex *, int *, ftnlen), + zcopy_(int *, doublecomplex *, int *, doublecomplex *, + int *), zswap_(int *, doublecomplex *, int *, + doublecomplex *, int *); + static double absakk, colmax; + extern int izamax_(int *, doublecomplex *, int *); + static double rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + kstep = 1; + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw * + w_dim1]), abs(d__2)); + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (kw - 1) * w_dim1]), abs(d__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs( + d__2)); + rowmax = max(d__3,d__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + imax + (kw - 1) * w_dim1]), abs(d__2)) >= alpha * + rowmax) { + kp = imax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = k - 1; + zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + kw * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + z_div(&z__1, &t, &d21); + d21.r = z__1.r, d21.i = z__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + i__1 = *n - k + 1; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (ftnlen)12); + kstep = 1; + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k * + w_dim1]), abs(d__2)); + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + kp = k; + } else { + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1, (ftnlen)12); + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (k + 1) * w_dim1]), abs(d__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs( + d__2)); + rowmax = max(d__3,d__4); + } + if (absakk >= alpha * colmax * (colmax / rowmax)) { + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + imax + (k + 1) * w_dim1]), abs(d__2)) >= alpha * + rowmax) { + kp = imax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + kp = imax; + kstep = 2; + } + } + } + kk = k + kstep - 1; + if (kp != kk) { + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = *n - k; + zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k + k * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + z_div(&z__1, &t, &d21); + d21.r = z__1.r, d21.i = z__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/zsytrf_rook.c b/relapack/src/zsytrf_rook.c new file mode 100644 index 0000000000..c598f7b1eb --- /dev/null +++ b/relapack/src/zsytrf_rook.c @@ -0,0 +1,236 @@ +#include "relapack.h" +#if XSYTRF_ALLOW_MALLOC +#include +#endif + +static void RELAPACK_zsytrf_rook_rec(const char *, const int *, const int *, int *, + double *, const int *, int *, double *, const int *, int *); + + +/** ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. + * + * This routine is functionally equivalent to LAPACK's zsytrf_rook. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d6/d6e/zsytrf__rook_8f.html + * */ +void RELAPACK_zsytrf_rook( + const char *uplo, const int *n, + double *A, const int *ldA, int *ipiv, + double *Work, const int *lWork, int *info +) { + + // Required work size + const int cleanlWork = *n * (*n / 2); + int minlWork = cleanlWork; +#if XSYTRF_ALLOW_MALLOC + minlWork = 1; +#endif + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (*n < 0) + *info = -2; + else if (*ldA < MAX(1, *n)) + *info = -4; + else if (*lWork < minlWork && *lWork != -1) + *info = -7; + else if (*lWork == -1) { + // Work size query + *Work = cleanlWork; + return; + } + + // Ensure Work size + double *cleanWork = Work; +#if XSYTRF_ALLOW_MALLOC + if (!*info && *lWork < cleanlWork) { + cleanWork = malloc(cleanlWork * 2 * sizeof(double)); + if (!cleanWork) + *info = -7; + } +#endif + + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZSYTRF", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + + // Dummy argument + int nout; + + // Recursive kernel + RELAPACK_zsytrf_rook_rec(&cleanuplo, n, n, &nout, A, ldA, ipiv, cleanWork, n, info); + +#if XSYTRF_ALLOW_MALLOC + if (cleanWork != Work) + free(cleanWork); +#endif +} + + +/** zsytrf_rook's recursive compute kernel */ +static void RELAPACK_zsytrf_rook_rec( + const char *uplo, const int *n_full, const int *n, int *n_out, + double *A, const int *ldA, int *ipiv, + double *Work, const int *ldWork, int *info +) { + + // top recursion level? + const int top = *n_full == *n; + + if (*n <= MAX(CROSSOVER_ZSYTRF_ROOK, 3)) { + // Unblocked + if (top) { + LAPACK(zsytf2)(uplo, n, A, ldA, ipiv, info); + *n_out = *n; + } else + RELAPACK_zsytrf_rook_rec2(uplo, n_full, n, n_out, A, ldA, ipiv, Work, ldWork, info); + return; + } + + int info1, info2; + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + const int n_rest = *n_full - *n; + + if (*uplo == 'L') { + // Splitting (setup) + int n1 = ZREC_SPLIT(*n); + int n2 = *n - n1; + + // Work_L * + double *const Work_L = Work; + + // recursion(A_L) + int n1_out; + RELAPACK_zsytrf_rook_rec(uplo, n_full, &n1, &n1_out, A, ldA, ipiv, Work_L, ldWork, &info1); + n1 = n1_out; + + // Splitting (continued) + n2 = *n - n1; + const int n_full2 = *n_full - n1; + + // * * + // A_BL A_BR + // A_BL_B A_BR_B + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + double *const A_BL_B = A + 2 * *n; + double *const A_BR_B = A + 2 * *ldA * n1 + 2 * *n; + + // * * + // Work_BL Work_BR + // * * + // (top recursion level: use Work as Work_BR) + double *const Work_BL = Work + 2 * n1; + double *const Work_BR = top ? Work : Work + 2 * *ldWork * n1 + 2 * n1; + const int ldWork_BR = top ? n2 : *ldWork; + + // ipiv_T + // ipiv_B + int *const ipiv_B = ipiv + n1; + + // A_BR = A_BR - A_BL Work_BL' + RELAPACK_zgemmt(uplo, "N", "T", &n2, &n1, MONE, A_BL, ldA, Work_BL, ldWork, ONE, A_BR, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n2, &n1, MONE, A_BL_B, ldA, Work_BL, ldWork, ONE, A_BR_B, ldA); + + // recursion(A_BR) + int n2_out; + RELAPACK_zsytrf_rook_rec(uplo, &n_full2, &n2, &n2_out, A_BR, ldA, ipiv_B, Work_BR, &ldWork_BR, &info2); + + if (n2_out != n2) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // last column of A_BR + double *const A_BR_r = A_BR + 2 * *ldA * n2_out + 2 * n2_out; + + // last row of A_BL + double *const A_BL_b = A_BL + 2 * n2_out; + + // last row of Work_BL + double *const Work_BL_b = Work_BL + 2 * n2_out; + + // A_BR_r = A_BR_r + A_BL_b Work_BL_b' + BLAS(zgemv)("N", &n_restp1, &n1, ONE, A_BL_b, ldA, Work_BL_b, ldWork, ONE, A_BR_r, iONE); + } + n2 = n2_out; + + // shift pivots + int i; + for (i = 0; i < n2; i++) + if (ipiv_B[i] > 0) + ipiv_B[i] += n1; + else + ipiv_B[i] -= n1; + + *info = info1 || info2; + *n_out = n1 + n2; + } else { + // Splitting (setup) + int n2 = ZREC_SPLIT(*n); + int n1 = *n - n2; + + // * Work_R + // (top recursion level: use Work as Work_R) + double *const Work_R = top ? Work : Work + 2 * *ldWork * n1; + + // recursion(A_R) + int n2_out; + RELAPACK_zsytrf_rook_rec(uplo, n_full, &n2, &n2_out, A, ldA, ipiv, Work_R, ldWork, &info2); + const int n2_diff = n2 - n2_out; + n2 = n2_out; + + // Splitting (continued) + n1 = *n - n2; + const int n_full1 = *n_full - n2; + + // * A_TL_T A_TR_T + // * A_TL A_TR + // * * * + double *const A_TL_T = A + 2 * *ldA * n_rest; + double *const A_TR_T = A + 2 * *ldA * (n_rest + n1); + double *const A_TL = A + 2 * *ldA * n_rest + 2 * n_rest; + double *const A_TR = A + 2 * *ldA * (n_rest + n1) + 2 * n_rest; + + // Work_L * + // * Work_TR + // * * + // (top recursion level: Work_R was Work) + double *const Work_L = Work; + double *const Work_TR = Work + 2 * *ldWork * (top ? n2_diff : n1) + 2 * n_rest; + const int ldWork_L = top ? n1 : *ldWork; + + // A_TL = A_TL - A_TR Work_TR' + RELAPACK_zgemmt(uplo, "N", "T", &n1, &n2, MONE, A_TR, ldA, Work_TR, ldWork, ONE, A_TL, ldA); + BLAS(zgemm)("N", "T", &n_rest, &n1, &n2, MONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, ldA); + + // recursion(A_TL) + int n1_out; + RELAPACK_zsytrf_rook_rec(uplo, &n_full1, &n1, &n1_out, A, ldA, ipiv, Work_L, &ldWork_L, &info1); + + if (n1_out != n1) { + // undo 1 column of updates + const int n_restp1 = n_rest + 1; + + // A_TL_T_l = A_TL_T_l + A_TR_T Work_TR_t' + BLAS(zgemv)("N", &n_restp1, &n2, ONE, A_TR_T, ldA, Work_TR, ldWork, ONE, A_TL_T, iONE); + } + n1 = n1_out; + + *info = info2 || info1; + *n_out = n1 + n2; + } +} diff --git a/relapack/src/zsytrf_rook_rec2.c b/relapack/src/zsytrf_rook_rec2.c new file mode 100644 index 0000000000..9e111fe0cd --- /dev/null +++ b/relapack/src/zsytrf_rook_rec2.c @@ -0,0 +1,561 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static doublecomplex c_b1 = {1.,0.}; +static int c__1 = 1; + +/** ZSYTRF_ROOK_REC2 computes a partial factorization of a complex symmetric matrix using the bounded Bunch-K aufman ("rook") diagonal pivoting method. + * + * This routine is a minor modification of LAPACK's zlasyf_rook. + * It serves as an unblocked kernel in the recursive algorithms. + * The blocked BLAS Level 3 updates were removed and moved to the + * recursive algorithm. + * */ +/* Subroutine */ void RELAPACK_zsytrf_rook_rec2(char *uplo, int *n, + int *nb, int *kb, doublecomplex *a, int *lda, int * + ipiv, doublecomplex *w, int *ldw, int *info, ftnlen uplo_len) +{ + /* System generated locals */ + int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + double d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + double sqrt(double), d_imag(doublecomplex *); + void z_div(doublecomplex *, doublecomplex *, doublecomplex *); + + /* Local variables */ + static int j, k, p; + static doublecomplex t, r1, d11, d12, d21, d22; + static int ii, jj, kk, kp, kw, jp1, jp2, kkw; + static logical done; + static int imax, jmax; + static double alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + static double dtemp, sfmin; + extern /* Subroutine */ int zscal_(int *, doublecomplex *, + doublecomplex *, int *); + static int itemp, kstep; + extern /* Subroutine */ int zgemv_(char *, int *, int *, + doublecomplex *, doublecomplex *, int *, doublecomplex *, + int *, doublecomplex *, doublecomplex *, int *, ftnlen), + zcopy_(int *, doublecomplex *, int *, doublecomplex *, + int *), zswap_(int *, doublecomplex *, int *, + doublecomplex *, int *); + extern double dlamch_(char *, ftnlen); + static double absakk, colmax; + extern int izamax_(int *, doublecomplex *, int *); + static double rowmax; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + alpha = (sqrt(17.) + 1.) / 8.; + sfmin = dlamch_("S", (ftnlen)1); + if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { + k = *n; +L10: + kw = *nb + k - *n; + if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + goto L30; + } + kstep = 1; + p = k; + zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1, (ftnlen)12); + } + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw * + w_dim1]), abs(d__2)); + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L12: + zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, ( + ftnlen)12); + } + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (kw - 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + kp = imax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } + if (! done) { + goto L12; + } + } + kk = k - kstep + 1; + kkw = *nb + kk - *n; + if (kstep == 2 && p != k) { + i__1 = k - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + zcopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + i__1 = *n - k + 1; + zswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + if (kp != kk) { + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + zcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = *n - kk + 1; + zswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + if (kstep == 1) { + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = k - 1; + zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + } + } + } else { + if (k > 2) { + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + z_div(&z__1, &w[k + kw * w_dim1], &d12); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + k -= kstep; + goto L10; +L30: + j = k + 1; +L60: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + *kb = *n - k; + } else { + k = 1; +L70: + if ((k >= *nb && *nb < *n) || k > *n) { + goto L90; + } + kstep = 1; + p = k; + i__1 = *n - k + 1; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, ( + ftnlen)12); + } + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k * + w_dim1]), abs(d__2)); + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + if (max(absakk,colmax) == 0.) { + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + if (! (absakk < alpha * colmax)) { + kp = k; + } else { + done = FALSE_; +L72: + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1, (ftnlen)12); + } + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (k + 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + kp = imax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + done = TRUE_; + } else if (p == jmax || rowmax <= colmax) { + kp = imax; + kstep = 2; + done = TRUE_; + } else { + p = imax; + colmax = rowmax; + imax = jmax; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } + if (! done) { + goto L72; + } + } + kk = k + kstep - 1; + if (kstep == 2 && p != k) { + i__1 = p - k; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + zcopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + zswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + if (kp != kk) { + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + zcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + zcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + zswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + if (kstep == 1) { + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = *n - k; + zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + } + } + } else { + if (k < *n - 1) { + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k + k * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + k += kstep; + goto L70; +L90: + j = k - 1; +L120: + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + --j; + if (jp2 != jj && j >= 1) { + zswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + zswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + *kb = k - 1; + } + return; +} diff --git a/relapack/src/ztgsyl.c b/relapack/src/ztgsyl.c new file mode 100644 index 0000000000..2c8a35256d --- /dev/null +++ b/relapack/src/ztgsyl.c @@ -0,0 +1,268 @@ +#include "relapack.h" +#include + +static void RELAPACK_ztgsyl_rec(const char *, const int *, const int *, + const int *, const double *, const int *, const double *, const int *, + double *, const int *, const double *, const int *, const double *, + const int *, double *, const int *, double *, double *, double *, int *); + + +/** ZTGSYL solves the generalized Sylvester equation. + * + * This routine is functionally equivalent to LAPACK's ztgsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/db/d68/ztgsyl_8f.html + * */ +void RELAPACK_ztgsyl( + const char *trans, const int *ijob, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dif, + double *Work, const int *lWork, int *iWork, int *info +) { + + // Parse arguments + const int notran = LAPACK(lsame)(trans, "N"); + const int tran = LAPACK(lsame)(trans, "C"); + + // Compute work buffer size + int lwmin = 1; + if (notran && (*ijob == 1 || *ijob == 2)) + lwmin = MAX(1, 2 * *m * *n); + *info = 0; + + // Check arguments + if (!tran && !notran) + *info = -1; + else if (notran && (*ijob < 0 || *ijob > 4)) + *info = -2; + else if (*m <= 0) + *info = -3; + else if (*n <= 0) + *info = -4; + else if (*ldA < MAX(1, *m)) + *info = -6; + else if (*ldB < MAX(1, *n)) + *info = -8; + else if (*ldC < MAX(1, *m)) + *info = -10; + else if (*ldD < MAX(1, *m)) + *info = -12; + else if (*ldE < MAX(1, *n)) + *info = -14; + else if (*ldF < MAX(1, *m)) + *info = -16; + else if (*lWork < lwmin && *lWork != -1) + *info = -20; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZTGSYL", &minfo); + return; + } + + if (*lWork == -1) { + // Work size query + *Work = lwmin; + return; + } + + // Clean char * arguments + const char cleantrans = notran ? 'N' : 'C'; + + // Constant + const double ZERO[] = { 0., 0. }; + + int isolve = 1; + int ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + LAPACK(zlaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(zlaset)("F", m, n, ZERO, ZERO, F, ldF); + } else if (*ijob >= 1) + isolve = 2; + } + + double scale2; + int iround; + for (iround = 1; iround <= isolve; iround++) { + *scale = 1; + double dscale = 0; + double dsum = 1; + RELAPACK_ztgsyl_rec(&cleantrans, &ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, &dsum, &dscale, info); + if (dscale != 0) { + if (*ijob == 1 || *ijob == 3) + *dif = sqrt(2 * *m * *n) / (dscale * sqrt(dsum)); + else + *dif = sqrt(*m * *n) / (dscale * sqrt(dsum)); + } + if (isolve == 2) { + if (iround == 1) { + if (notran) + ifunc = *ijob; + scale2 = *scale; + LAPACK(zlacpy)("F", m, n, C, ldC, Work, m); + LAPACK(zlacpy)("F", m, n, F, ldF, Work + 2 * *m * *n, m); + LAPACK(zlaset)("F", m, n, ZERO, ZERO, C, ldC); + LAPACK(zlaset)("F", m, n, ZERO, ZERO, F, ldF); + } else { + LAPACK(zlacpy)("F", m, n, Work, m, C, ldC); + LAPACK(zlacpy)("F", m, n, Work + 2 * *m * *n, m, F, ldF); + *scale = scale2; + } + } + } +} + + +/** ztgsyl's recursive vompute kernel */ +static void RELAPACK_ztgsyl_rec( + const char *trans, const int *ifunc, const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, + const double *D, const int *ldD, const double *E, const int *ldE, + double *F, const int *ldF, + double *scale, double *dsum, double *dscale, + int *info +) { + + if (*m <= MAX(CROSSOVER_ZTGSYL, 1) && *n <= MAX(CROSSOVER_ZTGSYL, 1)) { + // Unblocked + LAPACK(ztgsy2)(trans, ifunc, m, n, A, ldA, B, ldB, C, ldC, D, ldD, E, ldE, F, ldF, scale, dsum, dscale, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const int iONE[] = { 1 }; + + // Outputs + double scale1[] = { 1., 0. }; + double scale2[] = { 1., 0. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + const int m1 = ZREC_SPLIT(*m); + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const double *const A_TL = A; + const double *const A_TR = A + 2 * *ldA * m1; + const double *const A_BR = A + 2 * *ldA * m1 + 2 * m1; + + // C_T + // C_B + double *const C_T = C; + double *const C_B = C + 2 * m1; + + // D_TL D_TR + // 0 D_BR + const double *const D_TL = D; + const double *const D_TR = D + 2 * *ldD * m1; + const double *const D_BR = D + 2 * *ldD * m1 + 2 * m1; + + // F_T + // F_B + double *const F_T = F; + double *const F_B = F + 2 * m1; + + if (*trans == 'N') { + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_ztgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale1, dsum, dscale, info1); + // C_T = C_T - A_TR * C_B + BLAS(zgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // F_T = F_T - D_TR * C_B + BLAS(zgemm)("N", "N", &m1, n, &m2, MONE, D_TR, ldD, C_B, ldC, scale1, F_T, ldF); + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_ztgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m2, n, F_B, ldF, info); + } + } else { + // recursion(A_TL, B, C_T, D_TL, E, F_T) + RELAPACK_ztgsyl_rec(trans, ifunc, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, D_TL, ldD, E, ldE, F_T, ldF, scale1, dsum, dscale, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale1, &m2, n, F_B, ldF, info); + // C_B = C_B - A_TR^H * C_T + BLAS(zgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // C_B = C_B - D_TR^H * F_T + BLAS(zgemm)("C", "N", &m2, n, &m1, MONE, D_TR, ldD, F_T, ldC, ONE, C_B, ldC); + // recursion(A_BR, B, C_B, D_BR, E, F_B) + RELAPACK_ztgsyl_rec(trans, ifunc, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, D_BR, ldD, E, ldE, F_B, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_T, ldC, info); + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m1, n, F_T, ldF, info); + } + } + } else { + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const double *const B_TL = B; + const double *const B_TR = B + 2 * *ldB * n1; + const double *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // C_L C_R + double *const C_L = C; + double *const C_R = C + 2 * *ldC * n1; + + // E_TL E_TR + // 0 E_BR + const double *const E_TL = E; + const double *const E_TR = E + 2 * *ldE * n1; + const double *const E_BR = E + 2 * *ldE * n1 + 2 * n1; + + // F_L F_R + double *const F_L = F; + double *const F_R = F + 2 * *ldF * n1; + + if (*trans == 'N') { + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_ztgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale1, dsum, dscale, info1); + // C_R = C_R + F_L * B_TR + BLAS(zgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, B_TR, ldB, scale1, C_R, ldC); + // F_R = F_R + F_L * E_TR + BLAS(zgemm)("N", "N", m, &n2, &n1, ONE, F_L, ldF, E_TR, ldE, scale1, F_R, ldF); + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_ztgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n1, F_L, ldF, info); + } + } else { + // recursion(A, B_BR, C_R, D, E_BR, F_R) + RELAPACK_ztgsyl_rec(trans, ifunc, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, D, ldD, E_BR, ldE, F_R, ldF, scale1, dsum, dscale, info1); + // apply scale + if (scale1[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale1, m, &n1, C_L, ldC, info); + // F_L = F_L + C_R * B_TR + BLAS(zgemm)("N", "C", m, &n1, &n2, ONE, C_R, ldC, B_TR, ldB, scale1, F_L, ldF); + // F_L = F_L + F_R * E_TR + BLAS(zgemm)("N", "C", m, &n1, &n2, ONE, F_R, ldF, E_TR, ldB, ONE, F_L, ldF); + // recursion(A, B_TL, C_L, D, E_TL, F_L) + RELAPACK_ztgsyl_rec(trans, ifunc, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, D, ldD, E_TL, ldE, F_L, ldF, scale2, dsum, dscale, info2); + // apply scale + if (scale2[0] != 1) { + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n2, F_R, ldF, info); + } + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/ztrsyl.c b/relapack/src/ztrsyl.c new file mode 100644 index 0000000000..82b2c88031 --- /dev/null +++ b/relapack/src/ztrsyl.c @@ -0,0 +1,163 @@ +#include "relapack.h" + +static void RELAPACK_ztrsyl_rec(const char *, const char *, const int *, + const int *, const int *, const double *, const int *, const double *, + const int *, double *, const int *, double *, int *); + + +/** ZTRSYL solves the complex Sylvester matrix equation. + * + * This routine is functionally equivalent to LAPACK's ztrsyl. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d1/d36/ztrsyl_8f.html + * */ +void RELAPACK_ztrsyl( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + + // Check arguments + const int notransA = LAPACK(lsame)(tranA, "N"); + const int ctransA = LAPACK(lsame)(tranA, "C"); + const int notransB = LAPACK(lsame)(tranB, "N"); + const int ctransB = LAPACK(lsame)(tranB, "C"); + *info = 0; + if (!ctransA && !notransA) + *info = -1; + else if (!ctransB && !notransB) + *info = -2; + else if (*isgn != 1 && *isgn != -1) + *info = -3; + else if (*m < 0) + *info = -4; + else if (*n < 0) + *info = -5; + else if (*ldA < MAX(1, *m)) + *info = -7; + else if (*ldB < MAX(1, *n)) + *info = -9; + else if (*ldC < MAX(1, *m)) + *info = -11; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZTRSYL", &minfo); + return; + } + + // Clean char * arguments + const char cleantranA = notransA ? 'N' : 'C'; + const char cleantranB = notransB ? 'N' : 'C'; + + // Recursive kernel + RELAPACK_ztrsyl_rec(&cleantranA, &cleantranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); +} + + +/** ztrsyl's recursive compute kernel */ +static void RELAPACK_ztrsyl_rec( + const char *tranA, const char *tranB, const int *isgn, + const int *m, const int *n, + const double *A, const int *ldA, const double *B, const int *ldB, + double *C, const int *ldC, double *scale, + int *info +) { + + if (*m <= MAX(CROSSOVER_ZTRSYL, 1) && *n <= MAX(CROSSOVER_ZTRSYL, 1)) { + // Unblocked + RELAPACK_ztrsyl_rec2(tranA, tranB, isgn, m, n, A, ldA, B, ldB, C, ldC, scale, info); + return; + } + + // Constants + const double ONE[] = { 1., 0. }; + const double MONE[] = { -1., 0. }; + const double MSGN[] = { -*isgn, 0. }; + const int iONE[] = { 1 }; + + // Outputs + double scale1[] = { 1., 0. }; + double scale2[] = { 1., 0. }; + int info1[] = { 0 }; + int info2[] = { 0 }; + + if (*m > *n) { + // Splitting + const int m1 = ZREC_SPLIT(*m); + const int m2 = *m - m1; + + // A_TL A_TR + // 0 A_BR + const double *const A_TL = A; + const double *const A_TR = A + 2 * *ldA * m1; + const double *const A_BR = A + 2 * *ldA * m1 + 2 * m1; + + // C_T + // C_B + double *const C_T = C; + double *const C_B = C + 2 * m1; + + if (*tranA == 'N') { + // recusion(A_BR, B, C_B) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale1, info1); + // C_T = C_T - A_TR * C_B + BLAS(zgemm)("N", "N", &m1, n, &m2, MONE, A_TR, ldA, C_B, ldC, scale1, C_T, ldC); + // recusion(A_TL, B, C_T) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m2, n, C_B, ldC, info); + } else { + // recusion(A_TL, B, C_T) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, &m1, n, A_TL, ldA, B, ldB, C_T, ldC, scale1, info1); + // C_B = C_B - A_TR' * C_T + BLAS(zgemm)("C", "N", &m2, n, &m1, MONE, A_TR, ldA, C_T, ldC, scale1, C_B, ldC); + // recusion(A_BR, B, C_B) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, &m2, n, A_BR, ldA, B, ldB, C_B, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, &m1, n, C_B, ldC, info); + } + } else { + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // B_TL B_TR + // 0 B_BR + const double *const B_TL = B; + const double *const B_TR = B + 2 * *ldB * n1; + const double *const B_BR = B + 2 * *ldB * n1 + 2 * n1; + + // C_L C_R + double *const C_L = C; + double *const C_R = C + 2 * *ldC * n1; + + if (*tranB == 'N') { + // recusion(A, B_TL, C_L) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale1, info1); + // C_R = C_R -/+ C_L * B_TR + BLAS(zgemm)("N", "N", m, &n2, &n1, MSGN, C_L, ldC, B_TR, ldB, scale1, C_R, ldC); + // recusion(A, B_BR, C_R) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n1, C_L, ldC, info); + } else { + // recusion(A, B_BR, C_R) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, m, &n2, A, ldA, B_BR, ldB, C_R, ldC, scale1, info1); + // C_L = C_L -/+ C_R * B_TR' + BLAS(zgemm)("N", "C", m, &n1, &n2, MSGN, C_R, ldC, B_TR, ldB, scale1, C_L, ldC); + // recusion(A, B_TL, C_L) + RELAPACK_ztrsyl_rec(tranA, tranB, isgn, m, &n1, A, ldA, B_TL, ldB, C_L, ldC, scale2, info2); + // apply scale + if (scale2[0] != 1) + LAPACK(zlascl)("G", iONE, iONE, ONE, scale2, m, &n2, C_R, ldC, info); + } + } + + *scale = scale1[0] * scale2[0]; + *info = info1[0] || info2[0]; +} diff --git a/relapack/src/ztrsyl_rec2.c b/relapack/src/ztrsyl_rec2.c new file mode 100644 index 0000000000..526ab097cd --- /dev/null +++ b/relapack/src/ztrsyl_rec2.c @@ -0,0 +1,394 @@ +/* -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "../config.h" +#include "f2c.h" + +#if BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES +doublecomplex zdotu_fun(int *n, doublecomplex *x, int *incx, doublecomplex *y, int *incy) { + extern void zdotu_(doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, int *); + doublecomplex result; + zdotu_(&result, n, x, incx, y, incy); + return result; +} +#define zdotu_ zdotu_fun + +doublecomplex zdotc_fun(int *n, doublecomplex *x, int *incx, doublecomplex *y, int *incy) { + extern void zdotc_(doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, int *); + doublecomplex result; + zdotc_(&result, n, x, incx, y, incy); + return result; +} +#define zdotc_ zdotc_fun +#endif + +#if LAPACK_BLAS_COMPLEX_FUNCTIONS_AS_ROUTINES +doublecomplex zladiv_fun(doublecomplex *a, doublecomplex *b) { + extern void zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); + doublecomplex result; + zladiv_(&result, a, b); + return result; +} +#define zladiv_ zladiv_fun +#endif + +/* Table of constant values */ + +static int c__1 = 1; + +/** RELAPACK_ZTRSYL_REC2 solves the complex Sylvester matrix equation (unblocked algorithm) + * + * This routine is an exact copy of LAPACK's ztrsyl. + * It serves as an unblocked kernel in the recursive algorithms. + * */ +/* Subroutine */ void RELAPACK_ztrsyl_rec2(char *trana, char *tranb, int + *isgn, int *m, int *n, doublecomplex *a, int *lda, + doublecomplex *b, int *ldb, doublecomplex *c__, int *ldc, + double *scale, int *info, ftnlen trana_len, ftnlen tranb_len) +{ + /* System generated locals */ + int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + double d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + double d_imag(doublecomplex *); + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + static int j, k, l; + static doublecomplex a11; + static double db; + static doublecomplex x11; + static double da11; + static doublecomplex vec; + static double dum[1], eps, sgn, smin; + static doublecomplex suml, sumr; + extern int lsame_(char *, char *, ftnlen, ftnlen); + /* Double Complex */ doublecomplex zdotc_(int *, + doublecomplex *, int *, doublecomplex *, int *), zdotu_( + int *, doublecomplex *, int *, + doublecomplex *, int *); + extern /* Subroutine */ int dlabad_(double *, double *); + extern double dlamch_(char *, ftnlen); + static double scaloc; + extern /* Subroutine */ int xerbla_(char *, int *, ftnlen); + extern double zlange_(char *, int *, int *, doublecomplex *, + int *, double *, ftnlen); + static double bignum; + extern /* Subroutine */ int zdscal_(int *, double *, + doublecomplex *, int *); + /* Double Complex */ doublecomplex zladiv_(doublecomplex *, + doublecomplex *); + static int notrna, notrnb; + static double smlnum; + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N", (ftnlen)1, (ftnlen)1); + notrnb = lsame_(tranb, "N", (ftnlen)1, (ftnlen)1); + *info = 0; + if (! notrna && ! lsame_(trana, "C", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1,*m)) { + *info = -7; + } else if (*ldb < max(1,*n)) { + *info = -9; + } else if (*ldc < max(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZTRSY2", &i__1, (ftnlen)6); + return; + } + *scale = 1.; + if (*m == 0 || *n == 0) { + return; + } + eps = dlamch_("P", (ftnlen)1); + smlnum = dlamch_("S", (ftnlen)1); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = smlnum * (double) (*m * *n) / eps; + bignum = 1. / smlnum; +/* Computing MAX */ + d__1 = smlnum, d__2 = eps * zlange_("M", m, m, &a[a_offset], lda, dum, ( + ftnlen)1), d__1 = max(d__1,d__2), d__2 = eps * zlange_("M", n, n, + &b[b_offset], ldb, dum, (ftnlen)1); + smin = max(d__1,d__2); + sgn = (double) (*isgn); + if (notrna && notrnb) { + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + for (k = *m; k >= 1; --k) { + i__2 = *m - k; +/* Computing MIN */ + i__3 = k + 1; +/* Computing MIN */ + i__4 = k + 1; + z__1 = zdotu_(&i__2, &a[k + min(i__3,*m) * a_dim1], lda, &c__[ + min(i__4,*m) + l * c_dim1], &c__1); + suml.r = z__1.r, suml.i = z__1.i; + i__2 = l - 1; + z__1 = zdotu_(&i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = z__1.r, sumr.i = z__1.i; + i__2 = k + l * c_dim1; + z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i; + z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; + z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i; + vec.r = z__1.r, vec.i = z__1.i; + scaloc = 1.; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + z__2.r = sgn * b[i__3].r, z__2.i = sgn * b[i__3].i; + z__1.r = a[i__2].r + z__2.r, z__1.i = a[i__2].i + z__2.i; + a11.r = z__1.r, a11.i = z__1.i; + da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( + d__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.; + da11 = smin; + *info = 1; + } + db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( + d__2)); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + z__3.r = scaloc, z__3.i = 0.; + z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * + z__3.i + vec.i * z__3.r; + z__1 = zladiv_(&z__2, &a11); + x11.r = z__1.r, x11.i = z__1.i; + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; +/* L20: */ + } +/* L30: */ + } + } else if (! notrna && notrnb) { + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k - 1; + z__1 = zdotc_(&i__3, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = z__1.r, suml.i = z__1.i; + i__3 = l - 1; + z__1 = zdotu_(&i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1] + , &c__1); + sumr.r = z__1.r, sumr.i = z__1.i; + i__3 = k + l * c_dim1; + z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i; + z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + vec.r = z__1.r, vec.i = z__1.i; + scaloc = 1.; + d_cnjg(&z__2, &a[k + k * a_dim1]); + i__3 = l + l * b_dim1; + z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a11.r = z__1.r, a11.i = z__1.i; + da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( + d__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.; + da11 = smin; + *info = 1; + } + db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( + d__2)); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + z__3.r = scaloc, z__3.i = 0.; + z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * + z__3.i + vec.i * z__3.r; + z__1 = zladiv_(&z__2, &a11); + x11.r = z__1.r, x11.i = z__1.i; + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + i__3 = k + l * c_dim1; + c__[i__3].r = x11.r, c__[i__3].i = x11.i; +/* L50: */ + } +/* L60: */ + } + } else if (! notrna && ! notrnb) { + for (l = *n; l >= 1; --l) { + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + z__1 = zdotc_(&i__2, &a[k * a_dim1 + 1], &c__1, &c__[l * + c_dim1 + 1], &c__1); + suml.r = z__1.r, suml.i = z__1.i; + i__2 = *n - l; +/* Computing MIN */ + i__3 = l + 1; +/* Computing MIN */ + i__4 = l + 1; + z__1 = zdotc_(&i__2, &c__[k + min(i__3,*n) * c_dim1], ldc, &b[ + l + min(i__4,*n) * b_dim1], ldb); + sumr.r = z__1.r, sumr.i = z__1.i; + i__2 = k + l * c_dim1; + d_cnjg(&z__4, &sumr); + z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i; + z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; + z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i; + vec.r = z__1.r, vec.i = z__1.i; + scaloc = 1.; + i__2 = k + k * a_dim1; + i__3 = l + l * b_dim1; + z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i; + z__2.r = a[i__2].r + z__3.r, z__2.i = a[i__2].i + z__3.i; + d_cnjg(&z__1, &z__2); + a11.r = z__1.r, a11.i = z__1.i; + da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( + d__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.; + da11 = smin; + *info = 1; + } + db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( + d__2)); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + z__3.r = scaloc, z__3.i = 0.; + z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * + z__3.i + vec.i * z__3.r; + z__1 = zladiv_(&z__2, &a11); + x11.r = z__1.r, x11.i = z__1.i; + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + i__2 = k + l * c_dim1; + c__[i__2].r = x11.r, c__[i__2].i = x11.i; +/* L80: */ + } +/* L90: */ + } + } else if (notrna && ! notrnb) { + for (l = *n; l >= 1; --l) { + for (k = *m; k >= 1; --k) { + i__1 = *m - k; +/* Computing MIN */ + i__2 = k + 1; +/* Computing MIN */ + i__3 = k + 1; + z__1 = zdotu_(&i__1, &a[k + min(i__2,*m) * a_dim1], lda, &c__[ + min(i__3,*m) + l * c_dim1], &c__1); + suml.r = z__1.r, suml.i = z__1.i; + i__1 = *n - l; +/* Computing MIN */ + i__2 = l + 1; +/* Computing MIN */ + i__3 = l + 1; + z__1 = zdotc_(&i__1, &c__[k + min(i__2,*n) * c_dim1], ldc, &b[ + l + min(i__3,*n) * b_dim1], ldb); + sumr.r = z__1.r, sumr.i = z__1.i; + i__1 = k + l * c_dim1; + d_cnjg(&z__4, &sumr); + z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i; + z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i; + z__1.r = c__[i__1].r - z__2.r, z__1.i = c__[i__1].i - z__2.i; + vec.r = z__1.r, vec.i = z__1.i; + scaloc = 1.; + i__1 = k + k * a_dim1; + d_cnjg(&z__3, &b[l + l * b_dim1]); + z__2.r = sgn * z__3.r, z__2.i = sgn * z__3.i; + z__1.r = a[i__1].r + z__2.r, z__1.i = a[i__1].i + z__2.i; + a11.r = z__1.r, a11.i = z__1.i; + da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs( + d__2)); + if (da11 <= smin) { + a11.r = smin, a11.i = 0.; + da11 = smin; + *info = 1; + } + db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs( + d__2)); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + z__3.r = scaloc, z__3.i = 0.; + z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r * + z__3.i + vec.i * z__3.r; + z__1 = zladiv_(&z__2, &a11); + x11.r = z__1.r, x11.i = z__1.i; + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + i__1 = k + l * c_dim1; + c__[i__1].r = x11.r, c__[i__1].i = x11.i; +/* L110: */ + } +/* L120: */ + } + } + return; +} diff --git a/relapack/src/ztrtri.c b/relapack/src/ztrtri.c new file mode 100644 index 0000000000..ac9fe7bd48 --- /dev/null +++ b/relapack/src/ztrtri.c @@ -0,0 +1,107 @@ +#include "relapack.h" + +static void RELAPACK_ztrtri_rec(const char *, const char *, const int *, + double *, const int *, int *); + + +/** CTRTRI computes the inverse of a complex upper or lower triangular matrix A. + * + * This routine is functionally equivalent to LAPACK's ztrtri. + * For details on its interface, see + * http://www.netlib.org/lapack/explore-html/d1/d0e/ztrtri_8f.html + * */ +void RELAPACK_ztrtri( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +) { + + // Check arguments + const int lower = LAPACK(lsame)(uplo, "L"); + const int upper = LAPACK(lsame)(uplo, "U"); + const int nounit = LAPACK(lsame)(diag, "N"); + const int unit = LAPACK(lsame)(diag, "U"); + *info = 0; + if (!lower && !upper) + *info = -1; + else if (!nounit && !unit) + *info = -2; + else if (*n < 0) + *info = -3; + else if (*ldA < MAX(1, *n)) + *info = -5; + if (*info) { + const int minfo = -*info; + LAPACK(xerbla)("ZTRTRI", &minfo); + return; + } + + // Clean char * arguments + const char cleanuplo = lower ? 'L' : 'U'; + const char cleandiag = nounit ? 'N' : 'U'; + + // check for singularity + if (nounit) { + int i; + for (i = 0; i < *n; i++) + if (A[2 * (i + *ldA * i)] == 0 && A[2 * (i + *ldA * i) + 1] == 0) { + *info = i; + return; + } + } + + // Recursive kernel + RELAPACK_ztrtri_rec(&cleanuplo, &cleandiag, n, A, ldA, info); +} + + +/** ztrtri's recursive compute kernel */ +static void RELAPACK_ztrtri_rec( + const char *uplo, const char *diag, const int *n, + double *A, const int *ldA, + int *info +){ + + if (*n <= MAX(CROSSOVER_ZTRTRI, 1)) { + // Unblocked + LAPACK(ztrti2)(uplo, diag, n, A, ldA, info); + return; + } + + // Constants + const double ONE[] = { 1. }; + const double MONE[] = { -1. }; + + // Splitting + const int n1 = ZREC_SPLIT(*n); + const int n2 = *n - n1; + + // A_TL A_TR + // A_BL A_BR + double *const A_TL = A; + double *const A_TR = A + 2 * *ldA * n1; + double *const A_BL = A + 2 * n1; + double *const A_BR = A + 2 * *ldA * n1 + 2 * n1; + + // recursion(A_TL) + RELAPACK_ztrtri_rec(uplo, diag, &n1, A_TL, ldA, info); + if (*info) + return; + + if (*uplo == 'L') { + // A_BL = - A_BL * A_TL + BLAS(ztrmm)("R", "L", "N", diag, &n2, &n1, MONE, A_TL, ldA, A_BL, ldA); + // A_BL = A_BR \ A_BL + BLAS(ztrsm)("L", "L", "N", diag, &n2, &n1, ONE, A_BR, ldA, A_BL, ldA); + } else { + // A_TR = - A_TL * A_TR + BLAS(ztrmm)("L", "U", "N", diag, &n1, &n2, MONE, A_TL, ldA, A_TR, ldA); + // A_TR = A_TR / A_BR + BLAS(ztrsm)("R", "U", "N", diag, &n1, &n2, ONE, A_BR, ldA, A_TR, ldA); + } + + // recursion(A_BR) + RELAPACK_ztrtri_rec(uplo, diag, &n2, A_BR, ldA, info); + if (*info) + *info += n1; +} diff --git a/relapack/test/README.md b/relapack/test/README.md new file mode 100644 index 0000000000..48434b3cfb --- /dev/null +++ b/relapack/test/README.md @@ -0,0 +1,48 @@ +ReLAPACK Test Suite +=================== +This test suite compares ReLAPACK's recursive routines with LAPACK's compute +routines in terms of accuracy: For each test-case, we execute both ReLAPACK's +and LAPACK's routine on the same data and consider the numerical difference +between the two solutions. + +This difference is computed as the maximum error across all elements of the +routine's outputs, where the error for each element is the minimum of the +absolute error and the relative error (with LAPACK as the reference). If the +error is below the error bound configured in `config.h` (default: 1e-5 for +single precision and 1e-14 for double precision) the test-case is considered as +passed. + +For each routine the test-cases cover a variety of input argument combinations +to ensure that ReLAPACK's routines match the functionality of LAPACK for all use +cases. + +The matrix size for all experiments (default: 100) can also be specified in +`config.h`. + + +Implementation +-------------- +`test.h` provides the framework for our tests: It provides macros that allow to +generalize the tests for each operation in one file covering all data-types. +Such a file is structured as follows: + + * All matrices required by the test-cases are declared globally. For each + matrix, an array of two pointers is declared; one for the matrix copy passed + to ReLAPACK and one passed to LAPACK. + + * `tests()` contains the main control flow: it allocates (and later frees) the + copies of the globally declared matrices. It then defines the macro + `ROUTINE` to contain the name of the currently tested routine. + It then uses the macro `TEST` to perform the test-cases. + It receives the arguments of the routine, where matrices of which ReLAPACK + and LAPACK receive a copy are index with `i`. (Example: `TEST("L", &n, A[i], + &n, info);`) + + * The macro `TEST` first calls `pre()`, which initializes all relevant + matrices, then executes the ReLAPACK algorithm on the matrices with `i` = `0` + and then the LAPACK counter part with `i` = `1`. It then calls `post()`, + which computes the difference between the results, storing it in `error`. + Finally, the error is printed out and compared to the error bound. + +If all test-cases pass the error bound test, the program will have a `0` return +value, otherwise it is `1`, indicating an error. diff --git a/relapack/test/config.h b/relapack/test/config.h new file mode 100644 index 0000000000..ab06a2fff7 --- /dev/null +++ b/relapack/test/config.h @@ -0,0 +1,13 @@ +#ifndef TEST_CONFIG_H +#define TEST_CONFIG_H + +// error bound for single and single complex routines +#define SINGLE_ERR_BOUND 1e-4 + +// error bound for double an double complex routines +#define DOUBLE_ERR_BOUND 1e-13 + +// size of test matrices +#define TEST_SIZE 100 + +#endif /* TEST_CONFIG_H */ diff --git a/relapack/test/lapack.h b/relapack/test/lapack.h new file mode 100644 index 0000000000..80f5c419e8 --- /dev/null +++ b/relapack/test/lapack.h @@ -0,0 +1,64 @@ +#ifndef LAPACK_H2 +#define LAPACK_H2 + +#include "../config.h" + +void LAPACK(slauum)(const char *, const int *, float *, const int *, int *); +void LAPACK(dlauum)(const char *, const int *, double *, const int *, int *); +void LAPACK(clauum)(const char *, const int *, float *, const int *, int *); +void LAPACK(zlauum)(const char *, const int *, double *, const int *, int *); + +void LAPACK(strtri)(const char *, const char *, const int *, float *, const int *, int *); +void LAPACK(dtrtri)(const char *, const char *, const int *, double *, const int *, int *); +void LAPACK(ctrtri)(const char *, const char *, const int *, float *, const int *, int *); +void LAPACK(ztrtri)(const char *, const char *, const int *, double *, const int *, int *); + +void LAPACK(spotrf)(const char *, const int *, float *, const int *, int *); +void LAPACK(dpotrf)(const char *, const int *, double *, const int *, int *); +void LAPACK(cpotrf)(const char *, const int *, float *, const int *, int *); +void LAPACK(zpotrf)(const char *, const int *, double *, const int *, int *); + +void LAPACK(spbtrf)(const char *, const int *, const int *, float *, const int *, int *); +void LAPACK(dpbtrf)(const char *, const int *, const int *, double *, const int *, int *); +void LAPACK(cpbtrf)(const char *, const int *, const int *, float *, const int *, int *); +void LAPACK(zpbtrf)(const char *, const int *, const int *, double *, const int *, int *); + +void LAPACK(ssytrf)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(dsytrf)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void LAPACK(csytrf)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(chetrf)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(zsytrf)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void LAPACK(zhetrf)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void LAPACK(ssytrf_rook)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(dsytrf_rook)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void LAPACK(csytrf_rook)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(chetrf_rook)(const char *, const int *, float *, const int *, int *, float *, const int *, int *); +void LAPACK(zsytrf_rook)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); +void LAPACK(zhetrf_rook)(const char *, const int *, double *, const int *, int *, double *, const int *, int *); + +void LAPACK(sgetrf)(const int *, const int *, float *, const int *, int *, int *); +void LAPACK(dgetrf)(const int *, const int *, double *, const int *, int *, int *); +void LAPACK(cgetrf)(const int *, const int *, float *, const int *, int *, int *); +void LAPACK(zgetrf)(const int *, const int *, double *, const int *, int *, int *); + +void LAPACK(sgbtrf)(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +void LAPACK(dgbtrf)(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); +void LAPACK(cgbtrf)(const int *, const int *, const int *, const int *, float *, const int *, int *, int *); +void LAPACK(zgbtrf)(const int *, const int *, const int *, const int *, double *, const int *, int *, int *); + +void LAPACK(ssygst)(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +void LAPACK(dsygst)(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); +void LAPACK(chegst)(const int *, const char *, const int *, float *, const int *, const float *, const int *, int *); +void LAPACK(zhegst)(const int *, const char *, const int *, double *, const int *, const double *, const int *, int *); + +void LAPACK(strsyl)(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void LAPACK(dtrsyl)(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); +void LAPACK(ctrsyl)(const char *, const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, int *); +void LAPACK(ztrsyl)(const char *, const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, int *); + +void LAPACK(stgsyl)(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, const int *, int *, int *); +void LAPACK(dtgsyl)(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, const int *, int *, int *); +void LAPACK(ctgsyl)(const char *, const int *, const int *, const int *, const float *, const int *, const float *, const int *, float *, const int *, const float *, const int *, const float *, const int *, float *, const int *, float *, float *, float *, const int *, int *, int *); +void LAPACK(ztgsyl)(const char *, const int *, const int *, const int *, const double *, const int *, const double *, const int *, double *, const int *, const double *, const int *, const double *, const int *, double *, const int *, double *, double *, double *, const int *, int *, int *); + +#endif /* LAPACK_H2 */ diff --git a/relapack/test/test.h b/relapack/test/test.h new file mode 100644 index 0000000000..24089f3a85 --- /dev/null +++ b/relapack/test/test.h @@ -0,0 +1,136 @@ +#ifndef TEST_H +#define TEST_H + +#include "../config.h" +#include "config.h" + +#if BLAS_UNDERSCORE +#define BLAS(routine) routine ## _ +#else +#define BLAS(routine) routine +#endif + +#if LAPACK_UNDERSCORE +#define LAPACK(routine) routine ## _ +#else +#define LAPACK(routine) routine +#endif + +#include "../inc/relapack.h" +#include "lapack.h" +#include "util.h" +#include +#include +#include + +// some name mangling macros +#define CAT(A, B) A ## B +#define XCAT(A, B) CAT(A, B) +#define XLAPACK(X) LAPACK(X) +#define XRELAPACK(X) XCAT(RELAPACK_, X) +#define STR(X) #X +#define XSTR(X) STR(X) + +// default setup and error computation names: pre() and post() +#define PRE pre +#define POST post + +// TEST macro: +// run setup (pre()), ReLAPACK routine (i = 0), LAPACK routine (i = 1), compute +// error (post()), check error bound, and print setup and error +#define TEST(...) \ + PRE(); \ + i = 0; \ + XRELAPACK(ROUTINE)(__VA_ARGS__); \ + i = 1; \ + XLAPACK(ROUTINE)(__VA_ARGS__); \ + POST(); \ + fail |= error > ERR_BOUND; \ + printf("%s(%s)\t%g\n", XSTR(ROUTINE), #__VA_ARGS__, error); + +// generalized datatype treatment: DT_PREFIX determines the type s, d, c, or z +#define XPREF(A) XCAT(DT_PREFIX, A) + +// matrix generation and error computation routines +#define x2matgen XPREF(2matgen) +#define x2vecerr XPREF(2vecerr) + +// error bounds +#define ERR_BOUND XPREF(ERR_BOUND_) +#define sERR_BOUND_ SINGLE_ERR_BOUND +#define dERR_BOUND_ DOUBLE_ERR_BOUND +#define cERR_BOUND_ SINGLE_ERR_BOUND +#define zERR_BOUND_ DOUBLE_ERR_BOUND + +// C datatypes +#define datatype XPREF(datatype_) +#define sdatatype_ float +#define ddatatype_ double +#define cdatatype_ float +#define zdatatype_ double + +// number of C datatype elements per element +#define x1 XPREF(DT_MULT) +#define sDT_MULT 1 +#define dDT_MULT 1 +#define cDT_MULT 2 +#define zDT_MULT 2 + +// typed allocations +#define xmalloc XPREF(malloc) +#define imalloc(S) malloc((S) * sizeof(int)) +#define smalloc(S) malloc((S) * sizeof(float)) +#define dmalloc(S) malloc((S) * sizeof(double)) +#define cmalloc(S) malloc((S) * 2 * sizeof(float)) +#define zmalloc(S) malloc((S) * 2 * sizeof(double)) + +// transpositions +#define xCTRANS XPREF(CTRANS) +#define sCTRANS "T" +#define dCTRANS "T" +#define cCTRANS "C" +#define zCTRANS "C" + +// some constants +#define MONE XPREF(MONE) +const float sMONE[] = { -1. }; +const double dMONE[] = { -1. }; +const float cMONE[] = { -1., 0. }; +const double zMONE[] = { -1., 0. }; + +#define ZERO XPREF(ZERO) +const float sZERO[] = { 0. }; +const double dZERO[] = { 0. }; +const float cZERO[] = { 0., 0. }; +const double zZERO[] = { 0., 0. }; + +#define ONE XPREF(ONE) +const float sONE[] = { 1. }; +const double dONE[] = { 1. }; +const float cONE[] = { 1., 0. }; +const double zONE[] = { 1., 0. }; + +const int iMONE[] = { -1 }; +const int iZERO[] = { 0 }; +const int iONE[] = { 1 }; +const int iTWO[] = { 2 }; +const int iTHREE[] = { 3 }; +const int iFOUR[] = { 4 }; + +void tests(); + +// global variables (used in tests(), pre(), and post()) +int i, n, n2, fail; +double error; + +int main(int argc, char* argv[]) { + n = TEST_SIZE; + n2 = (3 * n) / 4; + fail = 0; + + tests(); + + return fail; +} + +#endif /* TEST_H */ diff --git a/relapack/test/util.c b/relapack/test/util.c new file mode 100644 index 0000000000..e0fca3eec9 --- /dev/null +++ b/relapack/test/util.c @@ -0,0 +1,116 @@ +#include "util.h" +#include +#include +#include + +#define MAX(a, b) ((a) > (b) ? (a) : (b)) +#define MIN(a, b) ((a) < (b) ? (a) : (b)) + +/////////////////////// +// matrix generation // +/////////////////////// +// Each routine x2matgen is passed the size (m, n) of the desired matrix and +// geneartes two copies of such a matrix in in its output arguments A and B. +// The generated matrices is filled with random entries in [0, 1[ (+i*[0, 1[ in +// the complex case). Then m is added to the diagonal; this is numerically +// favorable for routines working with triangular and symmetric matrices. For +// the same reason the imaginary part of the diagonal is set to 0. + +void s2matgen(const int m, const int n, float *A, float *B) { + srand(time(NULL) + (size_t) A); + int i, j; + for (i = 0; i < m; i++) + for (j = 0; j < n; j++) + A[i + m * j] = B[i + m * j] = (float) rand() / RAND_MAX + m * (i == j); +} + +void d2matgen(const int m, const int n, double *A, double *B) { + srand(time(NULL) + (size_t) A); + int i, j; + for (i = 0; i < m; i++) + for (j = 0; j < n; j++) + A[i + m * j] = B[i + m * j] = (double) rand() / RAND_MAX + m * (i == j); +} + +void c2matgen(const int m, const int n, float *A, float *B) { + srand(time(NULL) + (size_t) A); + int i, j; + for (i = 0; i < m; i++) + for (j = 0; j < n; j++) { + A[2* (i + m * j)] = B[2 * (i + m * j)] = (float) rand() / RAND_MAX + m * (i == j); + A[2* (i + m * j) + 1] = B[2 * (i + m * j) + 1] = ((float) rand() / RAND_MAX) * (i != j); + } +} + +void z2matgen(const int m, const int n, double *A, double *B) { + srand(time(NULL) + (size_t) A); + int i, j; + for (i = 0; i < m; i++) + for (j = 0; j < n; j++) { + A[2* (i + m * j)] = B[2 * (i + m * j)] = (double) rand() / RAND_MAX + m * (i == j); + A[2* (i + m * j) + 1] = B[2 * (i + m * j) + 1] = ((double) rand() / RAND_MAX) * (i != j); + } +} + +//////////////////////// +// error computations // +//////////////////////// +// Each routine x2vecerrr is passed a vector lengh n and two vectors x and y. +// It returns the maximum of the element-wise error between these two vectors. +// This error is the minimum of the absolute difference and the relative +// differene with respect to y. + +double i2vecerr(const int n, const int *x, const int *y) { + double error = 0; + int i; + for (i = 0; i < n; i++) { + double nom = abs(x[i] - y[i]); + double den = abs(y[i]); + error = MAX(error, (den > 0) ? MIN(nom, nom / den) : nom); + } + return error; +} + +double s2vecerr(const int n, const float *x, const float *y) { + float error = 0; + int i; + for (i = 0; i < n; i++) { + double nom = fabs((double) x[i] - y[i]); + double den = fabs(y[i]); + error = MAX(error, (den > 0) ? MIN(nom, nom / den) : nom); + } + return error; +} + +double d2vecerr(const int n, const double *x, const double *y) { + double error = 0; + int i; + for (i = 0; i < n; i++) { + double nom = fabs(x[i] - y[i]); + double den = fabs(y[i]); + error = MAX(error, (den > 0) ? MIN(nom, nom / den) : nom); + } + return error; +} + +double c2vecerr(const int n, const float *x, const float *y) { + double error = 0; + int i; + for (i = 0; i < n; i++) { + double nom = sqrt(((double) x[2 * i] - y[2 * i]) * ((double) x[2 * i] - y[2 * i]) + ((double) x[2 * i + 1] - y[2 * i + 1]) * ((double) x[2 * i + 1] - y[2 * i + 1])); + double den = sqrt((double) y[2 * i] * y[2 * i] + (double) y[2 * i + 1] * y[2 * i + 1]); + error = MAX(error, (den > 0) ? MIN(nom, nom / den) : nom); + } + return error; +} + +double z2vecerr(const int n, const double *x, const double *y) { + double error = 0; + int i; + for (i = 0; i < n; i++) { + double nom = sqrt((x[2 * i] - y[2 * i]) * (x[2 * i] - y[2 * i]) + (x[2 * i + 1] - y[2 * i + 1]) * (x[2 * i + 1] - y[2 * i + 1])); + double den = sqrt(y[2 * i] * y[2 * i] + y[2 * i + 1] * y[2 * i + 1]); + error = MAX(error, (den > 0) ? MIN(nom, nom / den) : nom); + } + return error; +} diff --git a/relapack/test/util.h b/relapack/test/util.h new file mode 100644 index 0000000000..11d2999e04 --- /dev/null +++ b/relapack/test/util.h @@ -0,0 +1,15 @@ +#ifndef TEST_UTIL_H +#define TEST_UTIL_H + +void s2matgen(int, int, float *, float *); +void d2matgen(int, int, double *, double *); +void c2matgen(int, int, float *, float *); +void z2matgen(int, int, double *, double *); + +double i2vecerr(int, const int *, const int *); +double s2vecerr(int, const float *, const float *); +double d2vecerr(int, const double *, const double *); +double c2vecerr(int, const float *, const float *); +double z2vecerr(int, const double *, const double *); + +#endif /* TEST_UTIL_H */ diff --git a/relapack/test/xgbtrf.c b/relapack/test/xgbtrf.c new file mode 100644 index 0000000000..f255006a51 --- /dev/null +++ b/relapack/test/xgbtrf.c @@ -0,0 +1,43 @@ +#include "test.h" + +datatype *A[2]; +int *ipiv[2], info; +int kl, ku, ld; + +void pre() { + int i; + x2matgen(ld, n, A[0], A[1]); + for (i = 0; i < n; i++) { + // set diagonal + A[0][x1 * (i + ld * i)] = + A[1][x1 * (i + ld * i)] = (datatype) rand() / RAND_MAX; + } + memset(ipiv[0], 0, n * sizeof(int)); + memset(ipiv[1], 0, n * sizeof(int)); +} + +void post() { + error = x2vecerr(ld * n, A[0], A[1]) + i2vecerr(n, ipiv[0], ipiv[1]); +} + +void tests() { + kl = n - 10; + ku = n; + ld = 2 * kl + ku + 1; + + A[0] = xmalloc(ld * n); + A[1] = xmalloc(ld * n); + ipiv[0] = imalloc(n); + ipiv[1] = imalloc(n); + + #define ROUTINE XPREF(gbtrf) + + TEST(&n, &n, &kl, &ku, A[i], &ld, ipiv[i], &info); + TEST(&n, &n2, &kl, &ku, A[i], &ld, ipiv[i], &info); + TEST(&n2, &n, &kl, &ku, A[i], &ld, ipiv[i], &info); + + free(A[0]); + free(A[1]); + free(ipiv[0]); + free(ipiv[1]); +} diff --git a/relapack/test/xgemmt.c b/relapack/test/xgemmt.c new file mode 100644 index 0000000000..ffc37049d8 --- /dev/null +++ b/relapack/test/xgemmt.c @@ -0,0 +1,65 @@ +#include "test.h" + +datatype *A[2], *B[2], *C[2], *Ctmp; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + x2matgen(n, n, B[0], B[1]); + x2matgen(n, n, C[0], C[1]); +} + +void post() { + error = x2vecerr(n * n, C[0], C[1]); +} + +#define ROUTINE XPREF(gemmt) + +#define xlacpy XPREF(LAPACK(lacpy)) +#define xgemm XPREF(BLAS(gemm)) + +extern void xlacpy(const char *, const int *, const int *, const datatype *, const int *, datatype *, const int *); +extern void xgemm(const char *, const char *, const int *, const int *, const int *, const datatype *, const datatype *, const int *, const datatype *, const int *, const datatype *, const datatype *, const int*); + +void XLAPACK(ROUTINE)( + const char *uplo, const char *transA, const char *transB, + const int *n, const int *k, + const datatype *alpha, const datatype *A, const int *ldA, + const datatype *B, const int *ldB, + const datatype *beta, datatype *C, const int *ldC +) { + xlacpy(uplo, n, n, C, ldC, Ctmp, n); + xgemm(transA, transB, n, n, k, alpha, A, ldA, B, ldB, beta, Ctmp, n); + xlacpy(uplo, n, n, Ctmp, ldC, C, n); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + B[0] = xmalloc(n * n); + B[1] = xmalloc(n * n); + C[0] = xmalloc(n * n); + C[1] = xmalloc(n * n); + Ctmp = xmalloc(n * n); + + TEST("L", "N", "N", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("L", "N", "N", &n, &n, ONE, A[i], &n, B[i], &n, MONE, C[i], &n); + TEST("L", "N", "N", &n, &n, MONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("L", "N", "T", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("L", "T", "N", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("L", "N", "N", &n, &n2, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("U", "N", "N", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("U", "N", "N", &n, &n, ONE, A[i], &n, B[i], &n, MONE, C[i], &n); + TEST("U", "N", "N", &n, &n, MONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("U", "N", "T", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("U", "T", "N", &n, &n, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + TEST("U", "N", "N", &n, &n2, ONE, A[i], &n, B[i], &n, ONE, C[i], &n); + + free(A[0]); + free(A[1]); + free(B[0]); + free(B[1]); + free(C[0]); + free(C[1]); + free(Ctmp); +} diff --git a/relapack/test/xgetrf.c b/relapack/test/xgetrf.c new file mode 100644 index 0000000000..4484a24af0 --- /dev/null +++ b/relapack/test/xgetrf.c @@ -0,0 +1,32 @@ +#include "test.h" + +datatype *A[2]; +int *ipiv[2], info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + memset(ipiv[0], 0, n * sizeof(int)); + memset(ipiv[1], 0, n * sizeof(int)); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]) + i2vecerr(n, ipiv[0], ipiv[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + ipiv[0] = imalloc(n); + ipiv[1] = imalloc(n); + + #define ROUTINE XPREF(getrf) + + TEST(&n, &n, A[i], &n, ipiv[i], &info); + TEST(&n, &n2, A[i], &n, ipiv[i], &info); + TEST(&n2, &n, A[i], &n, ipiv[i], &info); + + free(A[0]); + free(A[1]); + free(ipiv[0]); + free(ipiv[1]); +} diff --git a/relapack/test/xhegst.c b/relapack/test/xhegst.c new file mode 100644 index 0000000000..c318ef546e --- /dev/null +++ b/relapack/test/xhegst.c @@ -0,0 +1,32 @@ +#include "test.h" + +datatype *A[2], *B[2]; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + x2matgen(n, n, B[0], B[1]); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + B[0] = xmalloc(n * n); + B[1] = xmalloc(n * n); + + #define ROUTINE XPREF(hegst) + + TEST(iONE, "L", &n, A[i], &n, B[i], &n, &info); + TEST(iONE, "U", &n, A[i], &n, B[i], &n, &info); + TEST(iTWO, "L", &n, A[i], &n, B[i], &n, &info); + TEST(iTWO, "U", &n, A[i], &n, B[i], &n, &info); + + free(A[0]); + free(A[1]); + free(B[0]); + free(B[1]); +} diff --git a/relapack/test/xhetrf.c b/relapack/test/xhetrf.c new file mode 100644 index 0000000000..b5d54bdffe --- /dev/null +++ b/relapack/test/xhetrf.c @@ -0,0 +1,40 @@ +#include "test.h" + +datatype *A[2], *Work; +int *ipiv[2], info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + memset(ipiv[0], 0, n * sizeof(int)); + memset(ipiv[1], 0, n * sizeof(int)); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]) + i2vecerr(n, ipiv[0], ipiv[1]); +} + +void tests() { + const int lWork = n * n; + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + ipiv[0] = imalloc(n); + ipiv[1] = imalloc(n); + Work = xmalloc(lWork); + + #define ROUTINE XPREF(hetrf) + + TEST("L", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + TEST("U", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + + #undef ROUTINE + #define ROUTINE XPREF(hetrf_rook) + + TEST("L", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + TEST("U", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + + free(A[0]); + free(A[1]); + free(ipiv[0]); + free(ipiv[1]); + free(Work); +} diff --git a/relapack/test/xlauum.c b/relapack/test/xlauum.c new file mode 100644 index 0000000000..d2c42fa01e --- /dev/null +++ b/relapack/test/xlauum.c @@ -0,0 +1,25 @@ +#include "test.h" + +datatype *A[2]; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + + #define ROUTINE XPREF(lauum) + + TEST("L", &n, A[i], &n, &info); + TEST("U", &n, A[i], &n, &info); + + free(A[0]); + free(A[1]); +} diff --git a/relapack/test/xpbtrf.c b/relapack/test/xpbtrf.c new file mode 100644 index 0000000000..9a9babb6b2 --- /dev/null +++ b/relapack/test/xpbtrf.c @@ -0,0 +1,40 @@ +#include "test.h" + +datatype *A[2]; +int info[2]; +int n; + +void pre() { + int i; + x2matgen(n, n, A[0], A[1]); + for (i = 0; i < n; i++) { + // set diagonal + A[0][x1 * (i + n * i)] = + A[1][x1 * (i + n * i)] = (datatype) rand() / RAND_MAX; + // set first row + A[0][x1 * (n * i)] = + A[1][x1 * (n * i)] = (datatype) rand() / RAND_MAX + n; + } +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + + #define ROUTINE XPREF(pbtrf) + + const int + kd1 = n / 4, + kd2 = n * 3 / 4; + TEST("L", &n, &kd1, A[i], &n, &info[i]); + TEST("L", &n, &kd2, A[i], &n, &info[i]); + TEST("U", &n, &kd1, A[i] - x1 * kd1, &n, &info[i]); + TEST("U", &n, &kd2, A[i] - x1 * kd2, &n, &info[i]); + + free(A[0]); + free(A[1]); +} diff --git a/relapack/test/xpotrf.c b/relapack/test/xpotrf.c new file mode 100644 index 0000000000..5e04d426f1 --- /dev/null +++ b/relapack/test/xpotrf.c @@ -0,0 +1,25 @@ +#include "test.h" + +datatype *A[2]; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + + #define ROUTINE XPREF(potrf) + + TEST("L", &n, A[i], &n, &info); + TEST("U", &n, A[i], &n, &info); + + free(A[0]); + free(A[1]); +} diff --git a/relapack/test/xsygst.c b/relapack/test/xsygst.c new file mode 100644 index 0000000000..b473a59197 --- /dev/null +++ b/relapack/test/xsygst.c @@ -0,0 +1,32 @@ +#include "test.h" + +datatype *A[2], *B[2]; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + x2matgen(n, n, B[0], B[1]); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + B[0] = xmalloc(n * n); + B[1] = xmalloc(n * n); + + #define ROUTINE XPREF(sygst) + + TEST(iONE, "L", &n, A[i], &n, B[i], &n, &info); + TEST(iONE, "U", &n, A[i], &n, B[i], &n, &info); + TEST(iTWO, "L", &n, A[i], &n, B[i], &n, &info); + TEST(iTWO, "U", &n, A[i], &n, B[i], &n, &info); + + free(A[0]); + free(A[1]); + free(B[0]); + free(B[1]); +} diff --git a/relapack/test/xsytrf.c b/relapack/test/xsytrf.c new file mode 100644 index 0000000000..82d626f6f3 --- /dev/null +++ b/relapack/test/xsytrf.c @@ -0,0 +1,40 @@ +#include "test.h" + +datatype *A[2], *Work; +int *ipiv[2], info; + +void pre() { + x2matgen(n, n, A[0], A[1]); + memset(ipiv[0], 0, n * sizeof(int)); + memset(ipiv[1], 0, n * sizeof(int)); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]) + i2vecerr(n, ipiv[0], ipiv[1]); +} + +void tests() { + const int lWork = n * n; + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + ipiv[0] = imalloc(n); + ipiv[1] = imalloc(n); + Work = xmalloc(lWork); + + #define ROUTINE XPREF(sytrf) + + TEST("L", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + TEST("U", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + + #undef ROUTINE + #define ROUTINE XPREF(sytrf_rook) + + TEST("L", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + TEST("U", &n, A[i], &n, ipiv[i], Work, &lWork, &info); + + free(A[0]); + free(A[1]); + free(ipiv[0]); + free(ipiv[1]); + free(Work); +} diff --git a/relapack/test/xtgsyl.c b/relapack/test/xtgsyl.c new file mode 100644 index 0000000000..74db5005e4 --- /dev/null +++ b/relapack/test/xtgsyl.c @@ -0,0 +1,94 @@ +#include "test.h" + +datatype *A[2], *B[2], *C[2], *D[2], *E[2], *F[2], *Work, scale[2], dif[2]; +int *iWork, lWork, info; + +#define xlascl XPREF(LAPACK(lascl)) +void xlascl(const char *, const int *, const int *, const datatype *, const + datatype *, const int *, const int *, datatype *, const int *, int *); + +#define xscal XPREF(LAPACK(scal)) +void xscal(const int *, const datatype *, datatype *, const int *); + +void pre() { + int i; + + x2matgen(n, n, A[0], A[1]); + x2matgen(n, n, B[0], B[1]); + x2matgen(n, n, C[0], C[1]); + x2matgen(n, n, D[0], D[1]); + x2matgen(n, n, E[0], E[1]); + x2matgen(n, n, F[0], F[1]); + + for (i = 0; i < n; i++) { + // set diagonal + A[0][x1 * (i + n * i)] = + A[1][x1 * (i + n * i)] = (datatype) rand() / RAND_MAX; + E[0][x1 * (i + n * i)] = + E[1][x1 * (i + n * i)] = (datatype) rand() / RAND_MAX; + // clear first subdiagonal + A[0][x1 * (i + 1 + n * i)] = + A[1][x1 * (i + 1 + n * i)] = + B[0][x1 * (i + 1 + n * i)] = + B[1][x1 * (i + 1 + n * i)] = + A[0][x1 * (i + 1 + n * i) + x1 - 1] = + A[1][x1 * (i + 1 + n * i) + x1 - 1] = + B[0][x1 * (i + 1 + n * i) + x1 - 1] = + B[1][x1 * (i + 1 + n * i) + x1 - 1] = 0; + } +} + + +void post() { + if (scale[0] != 1 || scale[0] != 1) + printf("scale[RELAPACK] = %12g\tscale[LAPACK] = %12g\n", scale[0], scale[1]); + if (scale[0]) { + xlascl("G", iZERO, iZERO, &scale[0], &scale[1], &n, &n, C[0], &n, &info); + xlascl("G", iZERO, iZERO, &scale[0], &scale[1], &n, &n, F[0], &n, &info); + } + error = x2vecerr(n * n, C[0], C[1]) + x2vecerr(n * n, F[0], F[1]); +} + +void tests() { + lWork = 2 * n * n; + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + B[0] = xmalloc(n * n); + B[1] = xmalloc(n * n); + C[0] = xmalloc(n * n); + C[1] = xmalloc(n * n); + D[0] = xmalloc(n * n); + D[1] = xmalloc(n * n); + E[0] = xmalloc(n * n); + E[1] = xmalloc(n * n); + F[0] = xmalloc(n * n); + F[1] = xmalloc(n * n); + Work = xmalloc(lWork); + iWork = imalloc(n + n + 2); + + #define ROUTINE XPREF(tgsyl) + + TEST("N", iZERO, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iZERO, &n2, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iZERO, &n, &n2, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iTWO, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iTHREE, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST("N", iFOUR, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + TEST(xCTRANS, iZERO, &n, &n, A[i], &n, B[i], &n, C[i], &n, D[i], &n, E[i], &n, F[i], &n, &scale[i], &dif[i], Work, &lWork, iWork, &info); + + free(A[0]); + free(A[1]); + free(B[0]); + free(B[1]); + free(C[0]); + free(C[1]); + free(D[0]); + free(D[1]); + free(E[0]); + free(E[1]); + free(F[0]); + free(F[1]); + free(Work); + free(iWork); +} diff --git a/relapack/test/xtrsyl.c b/relapack/test/xtrsyl.c new file mode 100644 index 0000000000..358a892423 --- /dev/null +++ b/relapack/test/xtrsyl.c @@ -0,0 +1,65 @@ +#include "test.h" + +datatype *A[2], *B[2], *C[2], *Work, scale[2]; +int info; + +#define xlascl XPREF(LAPACK(lascl)) +void xlascl(const char *, const int *, const int *, const datatype *, const + datatype *, const int *, const int *, datatype *, const int *, int *); + +void pre() { + int i; + + x2matgen(n, n, A[0], A[1]); + x2matgen(n, n, B[0], B[1]); + x2matgen(n, n, C[0], C[1]); + + for (i = 0; i < n; i++) { + // set diagonal + A[0][x1 * (i + n * i)] = + A[1][x1 * (i + n * i)] = (datatype) rand() / RAND_MAX; + // clear first subdiagonal + A[0][x1 * (i + 1 + n * i)] = + A[1][x1 * (i + 1 + n * i)] = + B[0][x1 * (i + 1 + n * i)] = + B[1][x1 * (i + 1 + n * i)] = + A[0][x1 * (i + 1 + n * i) + x1 - 1] = + A[1][x1 * (i + 1 + n * i) + x1 - 1] = + B[0][x1 * (i + 1 + n * i) + x1 - 1] = + B[1][x1 * (i + 1 + n * i) + x1 - 1] = 0; + } +} + +void post() { + if (scale[0] != 1 || scale[0] != 1) + printf("scale[RELAPACK] = %12g\tscale[LAPACK] = %12g\n", scale[0], scale[1]); + if (scale[0]) + xlascl("G", iZERO, iZERO, &scale[0], &scale[1], &n, &n, C[0], &n, &info); + error = x2vecerr(n * n, C[0], C[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + B[0] = xmalloc(n * n); + B[1] = xmalloc(n * n); + C[0] = xmalloc(n * n); + C[1] = xmalloc(n * n); + + #define ROUTINE XPREF(trsyl) + + TEST("N", "N", iONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("N", "N", iONE, &n2, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("N", "N", iONE, &n, &n2, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("C", "N", iONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("N", "C", iONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("C", "C", iONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + TEST("N", "N", iMONE, &n, &n, A[i], &n, B[i], &n, C[i], &n, &scale[i], &info); + + free(A[0]); + free(A[1]); + free(B[0]); + free(B[1]); + free(C[0]); + free(C[1]); +} diff --git a/relapack/test/xtrtri.c b/relapack/test/xtrtri.c new file mode 100644 index 0000000000..106391bc8d --- /dev/null +++ b/relapack/test/xtrtri.c @@ -0,0 +1,25 @@ +#include "test.h" + +datatype *A[2]; +int info; + +void pre() { + x2matgen(n, n, A[0], A[1]); +} + +void post() { + error = x2vecerr(n * n, A[0], A[1]); +} + +void tests() { + A[0] = xmalloc(n * n); + A[1] = xmalloc(n * n); + + #define ROUTINE XPREF(trtri) + + TEST("L", "N", &n, A[i], &n, &info); + TEST("U", "N", &n, A[i], &n, &info); + + free(A[0]); + free(A[1]); +} diff --git a/utest/CMakeLists.txt b/utest/CMakeLists.txt index f0ffee0888..bd31ed9c67 100644 --- a/utest/CMakeLists.txt +++ b/utest/CMakeLists.txt @@ -21,6 +21,10 @@ if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") target_link_libraries(${OpenBLAS_utest_bin} m) endif() +if (${CMAKE_SYSTEM_NAME} STREQUAL "WindowsStore") +set_target_properties( ${OpenBLAS_utest_bin} PROPERTIES COMPILE_DEFINITIONS "_CRT_SECURE_NO_WARNINGS") +endif() + #Set output for utest set_target_properties( ${OpenBLAS_utest_bin} PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) foreach (OUTPUTCONFIG ${CMAKE_CONFIGURATION_TYPES}) @@ -31,7 +35,7 @@ endforeach() if (MSVC) add_custom_command(TARGET ${OpenBLAS_utest_bin} POST_BUILD - COMMAND ${CMAKE_COMMAND} -E copy ${PROJECT_BINARY_DIR}/lib/${OpenBLAS_LIBNAME}.dll ${CMAKE_CURRENT_BINARY_DIR}/. + COMMAND ${CMAKE_COMMAND} -E copy ${PROJECT_BINARY_DIR}/lib/$/${OpenBLAS_LIBNAME}.dll ${CMAKE_CURRENT_BINARY_DIR}/. ) endif() diff --git a/utest/Makefile b/utest/Makefile index 3ccc0a041d..ce809e3de0 100644 --- a/utest/Makefile +++ b/utest/Makefile @@ -18,7 +18,7 @@ endif all : run_test $(UTESTBIN): $(OBJS) - $(CC) $(CFLAGS) -o $@ $^ ../$(LIBNAME) $(EXTRALIB) $(FEXTRALIB) + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ ../$(LIBNAME) $(EXTRALIB) $(FEXTRALIB) run_test: $(UTESTBIN) ifndef CROSS diff --git a/utest/test_potrs.c b/utest/test_potrs.c index 41b3f6492c..f5dae50868 100644 --- a/utest/test_potrs.c +++ b/utest/test_potrs.c @@ -43,16 +43,110 @@ void BLASFUNC(zpotrs_(char*, BLASINT*, BLASINT*, complex double*, //https://github.com/xianyi/OpenBLAS/issues/695 CTEST(potrf, bug_695){ - openblas_complex_float A1[100] = {5.8525753+0.0*I, -0.79540455-0.7066077*I, 0.98274714-1.3824869*I, 2.619998-1.8532984*I, -1.8306153+1.2336911*I, 0.32275113-0.015575029*I, 2.1968813-1.0640624*I, 0.27894387-0.97911835*I, 3.0476584-0.18548489*I, 0.3842994-0.7050991*I, - -0.79540455+0.7066077*I, 8.313246+0.0*I, -1.8076122+0.8882447*I, 0.47806996-0.48494184*I, 0.5096429+0.5395974*I, -0.7285097+0.10360408*I, -1.1760061+2.7146957*I, -0.4271084-0.042899966*I, -1.7228563-2.8335886*I, 1.8942566-0.6389735*I, - 0.98274714+1.3824869*I, -1.8076122-0.8882447*I, 9.367975+0.0*I, -0.1838578-0.6468568*I, -1.8338387-0.7064959*I, 0.041852742+0.6556877*I, 2.5673025-1.9732997*I, -1.1148382+0.15693812*I, 2.4704504+1.0389464*I, 1.0858271+1.298006*I, - 2.619998+1.8532984*I, 0.47806996+0.48494184*I, -0.1838578+0.6468568*I, 3.1117508+0.0*I, -1.956626-0.22825956*I, 0.07081801+0.31801307*I, 0.3698375+0.5400855*I, 0.80686307-1.5315914*I, 1.5649154+1.6229297*I, -0.112077385-1.2014246*I, - -1.8306153-1.2336911*I, 0.5096429-0.5395974*I, -1.8338387+0.7064959*I, -1.956626+0.22825956*I, 3.6439795+0.0*I, -0.2594722-0.48786148*I, -0.47636223+0.27821827*I, -0.61608654+2.01858*I, -2.7767487-1.7693765*I, 0.048102796+0.9741874*I, - 0.32275113+0.015575029*I, -0.7285097-0.10360408*I, 0.041852742-0.6556877*I, 0.07081801-0.31801307*I, -0.2594722+0.48786148*I, 3.624376+0.0*I, -1.6697118-0.4017511*I, -1.4397877+0.7550918*I, -0.31456697+1.0403451*I, -0.31978557-0.13701046*I, - 2.1968813+1.0640624*I, -1.1760061-2.7146957*I, 2.5673025+1.9732997*I, 0.3698375-0.5400855*I, -0.47636223-0.27821827*I, -1.6697118+0.4017511*I, 6.8273163+0.0*I, -0.10051322-0.24303961*I, 1.4415971-0.29750675*I, 1.221786+0.85654986*I, - 0.27894387+0.97911835*I, -0.4271084+0.042899966*I, -1.1148382-0.15693812*I, 0.80686307+1.5315914*I, -0.61608654-2.01858*I, -1.4397877-0.7550918*I, -0.10051322+0.24303961*I, 3.4057708+0.0*I, -0.5856801+1.0203559*I, 0.7103452-0.8422135*I, - 3.0476584+0.18548489*I, -1.7228563+2.8335886*I, 2.4704504-1.0389464*I, 1.5649154-1.6229297*I, -2.7767487+1.7693765*I, -0.31456697-1.0403451*I, 1.4415971+0.29750675*I, -0.5856801-1.0203559*I, 7.005772+0.0*I, -0.9617417+1.2486815*I, - 0.3842994+0.7050991*I, 1.8942566+0.6389735*I, 1.0858271-1.298006*I, -0.112077385+1.2014246*I, 0.048102796-0.9741874*I, -0.31978557+0.13701046*I, 1.221786-0.85654986*I, 0.7103452+0.8422135*I, -0.9617417-1.2486815*I, 3.4629636+0.0*I}; + openblas_complex_float A1[100] = + { + openblas_make_complex_float(5.8525753, +0.0), + openblas_make_complex_float(-0.79540455, -0.7066077), + openblas_make_complex_float(0.98274714, -1.3824869), + openblas_make_complex_float(2.619998, -1.8532984), + openblas_make_complex_float(-1.8306153, +1.2336911), + openblas_make_complex_float(0.32275113, -0.015575029), + openblas_make_complex_float(2.1968813, -1.0640624), + openblas_make_complex_float(0.27894387, -0.97911835), + openblas_make_complex_float(3.0476584, -0.18548489), + openblas_make_complex_float(0.3842994, -0.7050991), + openblas_make_complex_float(-0.79540455, +0.7066077), + openblas_make_complex_float(8.313246, +0.0), + openblas_make_complex_float(-1.8076122, +0.8882447), + openblas_make_complex_float(0.47806996, -0.48494184), + openblas_make_complex_float(0.5096429, +0.5395974), + openblas_make_complex_float(-0.7285097, +0.10360408), + openblas_make_complex_float(-1.1760061, +2.7146957), + openblas_make_complex_float(-0.4271084, -0.042899966), + openblas_make_complex_float(-1.7228563, -2.8335886), + openblas_make_complex_float(1.8942566, -0.6389735), + openblas_make_complex_float(0.98274714, +1.3824869), + openblas_make_complex_float(-1.8076122, -0.8882447), + openblas_make_complex_float(9.367975, +0.0), + openblas_make_complex_float(-0.1838578, -0.6468568), + openblas_make_complex_float(-1.8338387, -0.7064959), + openblas_make_complex_float(0.041852742, +0.6556877), + openblas_make_complex_float(2.5673025, -1.9732997), + openblas_make_complex_float(-1.1148382, +0.15693812), + openblas_make_complex_float(2.4704504, +1.0389464), + openblas_make_complex_float(1.0858271, +1.298006), + openblas_make_complex_float(2.619998, +1.8532984), + openblas_make_complex_float(0.47806996, +0.48494184), + openblas_make_complex_float(-0.1838578, +0.6468568), + openblas_make_complex_float(3.1117508, +0.0), + openblas_make_complex_float(-1.956626, -0.22825956), + openblas_make_complex_float(0.07081801, +0.31801307), + openblas_make_complex_float(0.3698375, +0.5400855), + openblas_make_complex_float(0.80686307, -1.5315914), + openblas_make_complex_float(1.5649154, +1.6229297), + openblas_make_complex_float(-0.112077385, -1.2014246), + openblas_make_complex_float(-1.8306153, -1.2336911), + openblas_make_complex_float(0.5096429, -0.5395974), + openblas_make_complex_float(-1.8338387, +0.7064959), + openblas_make_complex_float(-1.956626, +0.22825956), + openblas_make_complex_float(3.6439795, +0.0), + openblas_make_complex_float(-0.2594722, -0.48786148), + openblas_make_complex_float(-0.47636223, +0.27821827), + openblas_make_complex_float(-0.61608654, +2.01858), + openblas_make_complex_float(-2.7767487, -1.7693765), + openblas_make_complex_float(0.048102796, +0.9741874), + openblas_make_complex_float(0.32275113, +0.015575029), + openblas_make_complex_float(-0.7285097, -0.10360408), + openblas_make_complex_float(0.041852742, -0.6556877), + openblas_make_complex_float(0.07081801, -0.31801307), + openblas_make_complex_float(-0.2594722, +0.48786148), + openblas_make_complex_float(3.624376, +0.0), + openblas_make_complex_float(-1.6697118, -0.4017511), + openblas_make_complex_float(-1.4397877, +0.7550918), + openblas_make_complex_float(-0.31456697, +1.0403451), + openblas_make_complex_float(-0.31978557, -0.13701046), + openblas_make_complex_float(2.1968813, +1.0640624), + openblas_make_complex_float(-1.1760061, -2.7146957), + openblas_make_complex_float(2.5673025, +1.9732997), + openblas_make_complex_float(0.3698375, -0.5400855), + openblas_make_complex_float(-0.47636223, -0.27821827), + openblas_make_complex_float(-1.6697118, +0.4017511), + openblas_make_complex_float(6.8273163, +0.0), + openblas_make_complex_float(-0.10051322, -0.24303961), + openblas_make_complex_float(1.4415971, -0.29750675), + openblas_make_complex_float(1.221786, +0.85654986), + openblas_make_complex_float(0.27894387, +0.97911835), + openblas_make_complex_float(-0.4271084, +0.042899966), + openblas_make_complex_float(-1.1148382, -0.15693812), + openblas_make_complex_float(0.80686307, +1.5315914), + openblas_make_complex_float(-0.61608654, -2.01858), + openblas_make_complex_float(-1.4397877, -0.7550918), + openblas_make_complex_float(-0.10051322, +0.24303961), + openblas_make_complex_float(3.4057708, +0.0), + openblas_make_complex_float(-0.5856801, +1.0203559), + openblas_make_complex_float(0.7103452, -0.8422135), + openblas_make_complex_float(3.0476584, +0.18548489), + openblas_make_complex_float(-1.7228563, +2.8335886), + openblas_make_complex_float(2.4704504, -1.0389464), + openblas_make_complex_float(1.5649154, -1.6229297), + openblas_make_complex_float(-2.7767487, +1.7693765), + openblas_make_complex_float(-0.31456697, -1.0403451), + openblas_make_complex_float(1.4415971, +0.29750675), + openblas_make_complex_float(-0.5856801, -1.0203559), + openblas_make_complex_float(7.005772, +0.0), + openblas_make_complex_float(-0.9617417, +1.2486815), + openblas_make_complex_float(0.3842994, +0.7050991), + openblas_make_complex_float(1.8942566, +0.6389735), + openblas_make_complex_float(1.0858271, -1.298006), + openblas_make_complex_float(-0.112077385, +1.2014246), + openblas_make_complex_float(0.048102796, -0.9741874), + openblas_make_complex_float(-0.31978557, +0.13701046), + openblas_make_complex_float(1.221786, -0.85654986), + openblas_make_complex_float(0.7103452, +0.8422135), + openblas_make_complex_float(-0.9617417, -1.2486815), + openblas_make_complex_float(3.4629636, +0.0) + }; + char up = 'U'; blasint n=10; @@ -60,34 +154,240 @@ CTEST(potrf, bug_695){ BLASFUNC(cpotrf)(&up, &n, (float*)(A1), &n, info); //printf("%g+%g*I\n", creal(A1[91]), cimag(A1[91])); - openblas_complex_double A2[100] = {3.0607147216796875+0.0*I, -0.5905849933624268-0.29020825028419495*I, 0.321084201335907+0.45168760418891907*I, 0.8387917876243591-0.644718587398529*I, -0.3642411530017853+0.051274992525577545*I, 0.8071482181549072+0.33944568037986755*I, 0.013674172572791576+0.21422699093818665*I, 0.35476258397102356+0.42408594489097595*I, -0.5991537570953369-0.23082709312438965*I, -0.0600702166557312-0.2113417387008667*I, - -0.7954045534133911+0.7066076993942261*I, 2.807175397872925+0.0*I, -0.1691000759601593+0.313548743724823*I, -0.30911174416542053+0.7447023987770081*I, -0.22347848117351532+0.03316075727343559*I, -0.4088296890258789-1.0214389562606812*I, -0.2344931811094284+0.08056317269802094*I, 0.793269693851471-0.17507623136043549*I, 0.03163455054163933+0.20559945702552795*I, 0.13581633567810059-0.2110036462545395*I, - 0.9827471375465393+1.3824869394302368*I, -1.8076121807098389-0.8882446885108948*I, 2.3277781009674072+0.0*I, 0.830405056476593-0.19296252727508545*I, 0.1394239068031311-0.5260677933692932*I, 1.239942193031311-0.09915469586849213*I, 0.06731037050485611-0.059320636093616486*I, 0.11507681757211685-0.1984301060438156*I, -0.6843825578689575+0.4647614359855652*I, 1.213119387626648-0.7757048010826111*I, - 2.619997978210449+1.8532984256744385*I, 0.4780699610710144+0.48494184017181396*I, -0.18385779857635498+0.6468567848205566*I, 2.0811400413513184+0.0*I, -0.035075582563877106+0.09732913225889206*I, 0.27337002754211426-0.9032229781150818*I, -0.8374675512313843+0.0479498989880085*I, 0.6916252374649048+0.45711082220077515*I, 0.1883818507194519+0.06482727080583572*I, -0.32384994626045227+0.05857187137007713*I, - -1.8306152820587158-1.2336910963058472*I, 0.5096428990364075-0.5395973920822144*I, -1.833838701248169+0.7064958810806274*I, -1.956626057624817+0.22825956344604492*I, 1.706615924835205+0.0*I, -0.2895336151123047+0.17579378187656403*I, -0.923172116279602-0.4530014097690582*I, 0.5040621757507324-0.37026339769363403*I, -0.2824432849884033-1.0374568700790405*I, 0.1399831622838974+0.4977008104324341*I, - 0.32275113463401794+0.015575028955936432*I, -0.7285097241401672-0.10360407829284668*I, 0.041852742433547974-0.655687689781189*I, 0.07081800699234009-0.318013072013855*I, -0.25947219133377075+0.4878614842891693*I, 1.5735365152359009+0.0*I, -0.2647853195667267-0.26654252409935*I, -0.6190430521965027-0.24699924886226654*I, -0.6288471221923828+0.48154571652412415*I, 0.02446540631353855-0.2611822783946991*I, - 2.1968812942504883+1.0640623569488525*I, -1.1760060787200928-2.714695692062378*I, 2.5673024654388428+1.9732997417449951*I, 0.3698374927043915-0.54008549451828*I, -0.4763622283935547-0.27821826934814453*I, -1.6697118282318115+0.4017511010169983*I, 1.2674795389175415+0.0*I, 0.3079095482826233-0.07258892804384232*I, -0.5929520130157471-0.038360968232154846*I, 0.04388086497783661-0.025549031794071198*I, - 0.27894386649131775+0.9791183471679688*I, -0.42710840702056885+0.0428999662399292*I, -1.1148382425308228-0.1569381207227707*I, 0.8068630695343018+1.5315914154052734*I, -0.6160865426063538-2.0185799598693848*I, -1.439787745475769-0.7550917863845825*I, -0.10051321983337402+0.24303960800170898*I, 0.9066106081008911+0.0*I, 0.05315789580345154-0.06136537343263626*I, -0.21304509043693542+0.6494344472885132*I, - 3.0476584434509277+0.1854848861694336*I, -1.7228562831878662+2.8335886001586914*I, 2.4704504013061523-1.0389463901519775*I, 1.564915418624878-1.6229296922683716*I, -2.7767486572265625+1.769376516342163*I, -0.314566969871521-1.0403450727462769*I, 1.4415971040725708+0.29750674962997437*I, -0.5856801271438599-1.0203559398651123*I, 0.5668219923973083+0.0*I, 0.033351436257362366-0.07832501083612442*I, - 0.3842993974685669+0.7050991058349609*I, 1.894256591796875+0.6389734745025635*I, 1.085827112197876-1.2980060577392578*I, -0.11207738518714905+1.2014245986938477*I, 0.04810279607772827-0.9741873741149902*I, -0.31978556513786316+0.13701045513153076*I, 1.2217860221862793-0.856549859046936*I, 0.7103452086448669+0.84221351146698*I, -0.9617416858673096-1.2486815452575684*I, 0.0756804421544075+0.0*I}; - openblas_complex_double B[20] = {-0.21782716937787788-0.9222220085490986*I, -0.7620356655676837+0.15533508334193666*I, -0.905011814118756+0.2847570854574069*I, -0.3451346708401685+1.076948486041297*I, 0.25336108035924787+0.975317836492159*I, 0.11192755545114-0.1603741874112385*I, -0.20604111555491242+0.10570814584017311*I, -1.0568488936791578-0.06025820467086475*I, -0.6650468984506477-0.5000967284800251*I, -1.0509472322215125+0.5022165705328413*I, - -0.727775859267237+0.50638268521728*I, 0.39947219167701153-0.4576746001199889*I, -0.7122162951294634-0.630289556702497*I, 0.9870834574024372-0.2825689605519449*I, 0.0628393808469436-0.1253397353973715*I, 0.8439562576196216+1.0850814110398734*I, 0.562377322638969-0.2578030745663871*I, 0.12696236014017806-0.09853584666755086*I, -0.023682508769195098+0.18093440285319276*I, -0.7264975746431271+0.31670415674097235*I}; + openblas_complex_double A2[100] = + { + openblas_make_complex_double(3.0607147216796875, +0.0), + openblas_make_complex_double(-0.5905849933624268, -0.29020825028419495), + openblas_make_complex_double(0.321084201335907, +0.45168760418891907), + openblas_make_complex_double(0.8387917876243591, -0.644718587398529), + openblas_make_complex_double(-0.3642411530017853, +0.051274992525577545), + openblas_make_complex_double(0.8071482181549072, +0.33944568037986755), + openblas_make_complex_double(0.013674172572791576, +0.21422699093818665), + openblas_make_complex_double(0.35476258397102356, +0.42408594489097595), + openblas_make_complex_double(-0.5991537570953369, -0.23082709312438965), + openblas_make_complex_double(-0.0600702166557312, -0.2113417387008667), + openblas_make_complex_double(-0.7954045534133911, +0.7066076993942261), + openblas_make_complex_double(2.807175397872925, +0.0), + openblas_make_complex_double(-0.1691000759601593, +0.313548743724823), + openblas_make_complex_double(-0.30911174416542053, +0.7447023987770081), + openblas_make_complex_double(-0.22347848117351532, +0.03316075727343559), + openblas_make_complex_double(-0.4088296890258789, -1.0214389562606812), + openblas_make_complex_double(-0.2344931811094284, +0.08056317269802094), + openblas_make_complex_double(0.793269693851471, -0.17507623136043549), + openblas_make_complex_double(0.03163455054163933, +0.20559945702552795), + openblas_make_complex_double(0.13581633567810059, -0.2110036462545395), + openblas_make_complex_double(0.9827471375465393, +1.3824869394302368), + openblas_make_complex_double(-1.8076121807098389, -0.8882446885108948), + openblas_make_complex_double(2.3277781009674072, +0.0), + openblas_make_complex_double(0.830405056476593, -0.19296252727508545), + openblas_make_complex_double(0.1394239068031311, -0.5260677933692932), + openblas_make_complex_double(1.239942193031311, -0.09915469586849213), + openblas_make_complex_double(0.06731037050485611, -0.059320636093616486), + openblas_make_complex_double(0.11507681757211685, -0.1984301060438156), + openblas_make_complex_double(-0.6843825578689575, +0.4647614359855652), + openblas_make_complex_double(1.213119387626648, -0.7757048010826111), + openblas_make_complex_double(2.619997978210449, +1.8532984256744385), + openblas_make_complex_double(0.4780699610710144, +0.48494184017181396), + openblas_make_complex_double(-0.18385779857635498, +0.6468567848205566), + openblas_make_complex_double(2.0811400413513184, +0.0), + openblas_make_complex_double(-0.035075582563877106, +0.09732913225889206), + openblas_make_complex_double(0.27337002754211426, -0.9032229781150818), + openblas_make_complex_double(-0.8374675512313843, +0.0479498989880085), + openblas_make_complex_double(0.6916252374649048, +0.45711082220077515), + openblas_make_complex_double(0.1883818507194519, +0.06482727080583572), + openblas_make_complex_double(-0.32384994626045227, +0.05857187137007713), + openblas_make_complex_double(-1.8306152820587158, -1.2336910963058472), + openblas_make_complex_double(0.5096428990364075, -0.5395973920822144), + openblas_make_complex_double(-1.833838701248169, +0.7064958810806274), + openblas_make_complex_double(-1.956626057624817, +0.22825956344604492), + openblas_make_complex_double(1.706615924835205, +0.0), + openblas_make_complex_double(-0.2895336151123047, +0.17579378187656403), + openblas_make_complex_double(-0.923172116279602, -0.4530014097690582), + openblas_make_complex_double(0.5040621757507324, -0.37026339769363403), + openblas_make_complex_double(-0.2824432849884033, -1.0374568700790405), + openblas_make_complex_double(0.1399831622838974, +0.4977008104324341), + openblas_make_complex_double(0.32275113463401794, +0.015575028955936432), + openblas_make_complex_double(-0.7285097241401672, -0.10360407829284668), + openblas_make_complex_double(0.041852742433547974, -0.655687689781189), + openblas_make_complex_double(0.07081800699234009, -0.318013072013855), + openblas_make_complex_double(-0.25947219133377075, +0.4878614842891693), + openblas_make_complex_double(1.5735365152359009, +0.0), + openblas_make_complex_double(-0.2647853195667267, -0.26654252409935), + openblas_make_complex_double(-0.6190430521965027, -0.24699924886226654), + openblas_make_complex_double(-0.6288471221923828, +0.48154571652412415), + openblas_make_complex_double(0.02446540631353855, -0.2611822783946991), + openblas_make_complex_double(2.1968812942504883, +1.0640623569488525), + openblas_make_complex_double(-1.1760060787200928, -2.714695692062378), + openblas_make_complex_double(2.5673024654388428, +1.9732997417449951), + openblas_make_complex_double(0.3698374927043915, -0.54008549451828), + openblas_make_complex_double(-0.4763622283935547, -0.27821826934814453), + openblas_make_complex_double(-1.6697118282318115, +0.4017511010169983), + openblas_make_complex_double(1.2674795389175415, +0.0), + openblas_make_complex_double(0.3079095482826233, -0.07258892804384232), + openblas_make_complex_double(-0.5929520130157471, -0.038360968232154846), + openblas_make_complex_double(0.04388086497783661, -0.025549031794071198), + openblas_make_complex_double(0.27894386649131775, +0.9791183471679688), + openblas_make_complex_double(-0.42710840702056885, +0.0428999662399292), + openblas_make_complex_double(-1.1148382425308228, -0.1569381207227707), + openblas_make_complex_double(0.8068630695343018, +1.5315914154052734), + openblas_make_complex_double(-0.6160865426063538, -2.0185799598693848), + openblas_make_complex_double(-1.439787745475769, -0.7550917863845825), + openblas_make_complex_double(-0.10051321983337402, +0.24303960800170898), + openblas_make_complex_double(0.9066106081008911, +0.0), + openblas_make_complex_double(0.05315789580345154, -0.06136537343263626), + openblas_make_complex_double(-0.21304509043693542, +0.6494344472885132), + openblas_make_complex_double(3.0476584434509277, +0.1854848861694336), + openblas_make_complex_double(-1.7228562831878662, +2.8335886001586914), + openblas_make_complex_double(2.4704504013061523, -1.0389463901519775), + openblas_make_complex_double(1.564915418624878, -1.6229296922683716), + openblas_make_complex_double(-2.7767486572265625, +1.769376516342163), + openblas_make_complex_double(-0.314566969871521, -1.0403450727462769), + openblas_make_complex_double(1.4415971040725708, +0.29750674962997437), + openblas_make_complex_double(-0.5856801271438599, -1.0203559398651123), + openblas_make_complex_double(0.5668219923973083, +0.0), + openblas_make_complex_double(0.033351436257362366, -0.07832501083612442), + openblas_make_complex_double(0.3842993974685669, +0.7050991058349609), + openblas_make_complex_double(1.894256591796875, +0.6389734745025635), + openblas_make_complex_double(1.085827112197876, -1.2980060577392578), + openblas_make_complex_double(-0.11207738518714905, +1.2014245986938477), + openblas_make_complex_double(0.04810279607772827, -0.9741873741149902), + openblas_make_complex_double(-0.31978556513786316, +0.13701045513153076), + openblas_make_complex_double(1.2217860221862793, -0.856549859046936), + openblas_make_complex_double(0.7103452086448669, +0.84221351146698), + openblas_make_complex_double(-0.9617416858673096, -1.2486815452575684), + openblas_make_complex_double(0.0756804421544075, +0.0) + }; + openblas_complex_double B[20] = + { + openblas_make_complex_double(-0.21782716937787788, -0.9222220085490986), + openblas_make_complex_double(-0.7620356655676837, +0.15533508334193666), + openblas_make_complex_double(-0.905011814118756, +0.2847570854574069), + openblas_make_complex_double(-0.3451346708401685, +1.076948486041297), + openblas_make_complex_double(0.25336108035924787, +0.975317836492159), + openblas_make_complex_double(0.11192755545114, -0.1603741874112385), + openblas_make_complex_double(-0.20604111555491242, +0.10570814584017311), + openblas_make_complex_double(-1.0568488936791578, -0.06025820467086475), + openblas_make_complex_double(-0.6650468984506477, -0.5000967284800251), + openblas_make_complex_double(-1.0509472322215125, +0.5022165705328413), + openblas_make_complex_double(-0.727775859267237, +0.50638268521728), + openblas_make_complex_double(0.39947219167701153, -0.4576746001199889), + openblas_make_complex_double(-0.7122162951294634, -0.630289556702497), + openblas_make_complex_double(0.9870834574024372, -0.2825689605519449), + openblas_make_complex_double(0.0628393808469436, -0.1253397353973715), + openblas_make_complex_double(0.8439562576196216, +1.0850814110398734), + openblas_make_complex_double(0.562377322638969, -0.2578030745663871), + openblas_make_complex_double(0.12696236014017806, -0.09853584666755086), + openblas_make_complex_double(-0.023682508769195098, +0.18093440285319276), + openblas_make_complex_double(-0.7264975746431271, +0.31670415674097235) + }; char lo = 'L'; blasint nrhs = 2; BLASFUNC(zpotrs)(&lo, &n, &nrhs, (double*)(A2), &n, (double*)(B), &n, info); // note that this is exactly equal to A1 - openblas_complex_float A3[100] = {5.8525753+0.0*I, -0.79540455-0.7066077*I, 0.98274714-1.3824869*I, 2.619998-1.8532984*I, -1.8306153+1.2336911*I, 0.32275113-0.015575029*I, 2.1968813-1.0640624*I, 0.27894387-0.97911835*I, 3.0476584-0.18548489*I, 0.3842994-0.7050991*I, - -0.79540455+0.7066077*I, 8.313246+0.0*I, -1.8076122+0.8882447*I, 0.47806996-0.48494184*I, 0.5096429+0.5395974*I, -0.7285097+0.10360408*I, -1.1760061+2.7146957*I, -0.4271084-0.042899966*I, -1.7228563-2.8335886*I, 1.8942566-0.6389735*I, - 0.98274714+1.3824869*I, -1.8076122-0.8882447*I, 9.367975+0.0*I, -0.1838578-0.6468568*I, -1.8338387-0.7064959*I, 0.041852742+0.6556877*I, 2.5673025-1.9732997*I, -1.1148382+0.15693812*I, 2.4704504+1.0389464*I, 1.0858271+1.298006*I, - 2.619998+1.8532984*I, 0.47806996+0.48494184*I, -0.1838578+0.6468568*I, 3.1117508+0.0*I, -1.956626-0.22825956*I, 0.07081801+0.31801307*I, 0.3698375+0.5400855*I, 0.80686307-1.5315914*I, 1.5649154+1.6229297*I, -0.112077385-1.2014246*I, - -1.8306153-1.2336911*I, 0.5096429-0.5395974*I, -1.8338387+0.7064959*I, -1.956626+0.22825956*I, 3.6439795+0.0*I, -0.2594722-0.48786148*I, -0.47636223+0.27821827*I, -0.61608654+2.01858*I, -2.7767487-1.7693765*I, 0.048102796+0.9741874*I, - 0.32275113+0.015575029*I, -0.7285097-0.10360408*I, 0.041852742-0.6556877*I, 0.07081801-0.31801307*I, -0.2594722+0.48786148*I, 3.624376+0.0*I, -1.6697118-0.4017511*I, -1.4397877+0.7550918*I, -0.31456697+1.0403451*I, -0.31978557-0.13701046*I, - 2.1968813+1.0640624*I, -1.1760061-2.7146957*I, 2.5673025+1.9732997*I, 0.3698375-0.5400855*I, -0.47636223-0.27821827*I, -1.6697118+0.4017511*I, 6.8273163+0.0*I, -0.10051322-0.24303961*I, 1.4415971-0.29750675*I, 1.221786+0.85654986*I, - 0.27894387+0.97911835*I, -0.4271084+0.042899966*I, -1.1148382-0.15693812*I, 0.80686307+1.5315914*I, -0.61608654-2.01858*I, -1.4397877-0.7550918*I, -0.10051322+0.24303961*I, 3.4057708+0.0*I, -0.5856801+1.0203559*I, 0.7103452-0.8422135*I, - 3.0476584+0.18548489*I, -1.7228563+2.8335886*I, 2.4704504-1.0389464*I, 1.5649154-1.6229297*I, -2.7767487+1.7693765*I, -0.31456697-1.0403451*I, 1.4415971+0.29750675*I, -0.5856801-1.0203559*I, 7.005772+0.0*I, -0.9617417+1.2486815*I, - 0.3842994+0.7050991*I, 1.8942566+0.6389735*I, 1.0858271-1.298006*I, -0.112077385+1.2014246*I, 0.048102796-0.9741874*I, -0.31978557+0.13701046*I, 1.221786-0.85654986*I, 0.7103452+0.8422135*I, -0.9617417-1.2486815*I, 3.4629636+0.0*I}; - + openblas_complex_float A3[100] = + { + openblas_make_complex_float(5.8525753, +0.0), + openblas_make_complex_float(-0.79540455, -0.7066077), + openblas_make_complex_float(0.98274714, -1.3824869), + openblas_make_complex_float(2.619998, -1.8532984), + openblas_make_complex_float(-1.8306153, +1.2336911), + openblas_make_complex_float(0.32275113, -0.015575029), + openblas_make_complex_float(2.1968813, -1.0640624), + openblas_make_complex_float(0.27894387, -0.97911835), + openblas_make_complex_float(3.0476584, -0.18548489), + openblas_make_complex_float(0.3842994, -0.7050991), + openblas_make_complex_float(-0.79540455, +0.7066077), + openblas_make_complex_float(8.313246, +0.0), + openblas_make_complex_float(-1.8076122, +0.8882447), + openblas_make_complex_float(0.47806996, -0.48494184), + openblas_make_complex_float(0.5096429, +0.5395974), + openblas_make_complex_float(-0.7285097, +0.10360408), + openblas_make_complex_float(-1.1760061, +2.7146957), + openblas_make_complex_float(-0.4271084, -0.042899966), + openblas_make_complex_float(-1.7228563, -2.8335886), + openblas_make_complex_float(1.8942566, -0.6389735), + openblas_make_complex_float(0.98274714, +1.3824869), + openblas_make_complex_float(-1.8076122, -0.8882447), + openblas_make_complex_float(9.367975, +0.0), + openblas_make_complex_float(-0.1838578, -0.6468568), + openblas_make_complex_float(-1.8338387, -0.7064959), + openblas_make_complex_float(0.041852742, +0.6556877), + openblas_make_complex_float(2.5673025, -1.9732997), + openblas_make_complex_float(-1.1148382, +0.15693812), + openblas_make_complex_float(2.4704504, +1.0389464), + openblas_make_complex_float(1.0858271, +1.298006), + openblas_make_complex_float(2.619998, +1.8532984), + openblas_make_complex_float(0.47806996, +0.48494184), + openblas_make_complex_float(-0.1838578, +0.6468568), + openblas_make_complex_float(3.1117508, +0.0), + openblas_make_complex_float(-1.956626, -0.22825956), + openblas_make_complex_float(0.07081801, +0.31801307), + openblas_make_complex_float(0.3698375, +0.5400855), + openblas_make_complex_float(0.80686307, -1.5315914), + openblas_make_complex_float(1.5649154, +1.6229297), + openblas_make_complex_float(-0.112077385, -1.2014246), + openblas_make_complex_float(-1.8306153, -1.2336911), + openblas_make_complex_float(0.5096429, -0.5395974), + openblas_make_complex_float(-1.8338387, +0.7064959), + openblas_make_complex_float(-1.956626, +0.22825956), + openblas_make_complex_float(3.6439795, +0.0), + openblas_make_complex_float(-0.2594722, -0.48786148), + openblas_make_complex_float(-0.47636223, +0.27821827), + openblas_make_complex_float(-0.61608654, +2.01858), + openblas_make_complex_float(-2.7767487, -1.7693765), + openblas_make_complex_float(0.048102796, +0.9741874), + openblas_make_complex_float(0.32275113, +0.015575029), + openblas_make_complex_float(-0.7285097, -0.10360408), + openblas_make_complex_float(0.041852742, -0.6556877), + openblas_make_complex_float(0.07081801, -0.31801307), + openblas_make_complex_float(-0.2594722, +0.48786148), + openblas_make_complex_float(3.624376, +0.0), + openblas_make_complex_float(-1.6697118, -0.4017511), + openblas_make_complex_float(-1.4397877, +0.7550918), + openblas_make_complex_float(-0.31456697, +1.0403451), + openblas_make_complex_float(-0.31978557, -0.13701046), + openblas_make_complex_float(2.1968813, +1.0640624), + openblas_make_complex_float(-1.1760061, -2.7146957), + openblas_make_complex_float(2.5673025, +1.9732997), + openblas_make_complex_float(0.3698375, -0.5400855), + openblas_make_complex_float(-0.47636223, -0.27821827), + openblas_make_complex_float(-1.6697118, +0.4017511), + openblas_make_complex_float(6.8273163, +0.0), + openblas_make_complex_float(-0.10051322, -0.24303961), + openblas_make_complex_float(1.4415971, -0.29750675), + openblas_make_complex_float(1.221786, +0.85654986), + openblas_make_complex_float(0.27894387, +0.97911835), + openblas_make_complex_float(-0.4271084, +0.042899966), + openblas_make_complex_float(-1.1148382, -0.15693812), + openblas_make_complex_float(0.80686307, +1.5315914), + openblas_make_complex_float(-0.61608654, -2.01858), + openblas_make_complex_float(-1.4397877, -0.7550918), + openblas_make_complex_float(-0.10051322, +0.24303961), + openblas_make_complex_float(3.4057708, +0.0), + openblas_make_complex_float(-0.5856801, +1.0203559), + openblas_make_complex_float(0.7103452, -0.8422135), + openblas_make_complex_float(3.0476584, +0.18548489), + openblas_make_complex_float(-1.7228563, +2.8335886), + openblas_make_complex_float(2.4704504, -1.0389464), + openblas_make_complex_float(1.5649154, -1.6229297), + openblas_make_complex_float(-2.7767487, +1.7693765), + openblas_make_complex_float(-0.31456697, -1.0403451), + openblas_make_complex_float(1.4415971, +0.29750675), + openblas_make_complex_float(-0.5856801, -1.0203559), + openblas_make_complex_float(7.005772, +0.0), + openblas_make_complex_float(-0.9617417, +1.2486815), + openblas_make_complex_float(0.3842994, +0.7050991), + openblas_make_complex_float(1.8942566, +0.6389735), + openblas_make_complex_float(1.0858271, -1.298006), + openblas_make_complex_float(-0.112077385, +1.2014246), + openblas_make_complex_float(0.048102796, -0.9741874), + openblas_make_complex_float(-0.31978557, +0.13701046), + openblas_make_complex_float(1.221786, -0.85654986), + openblas_make_complex_float(0.7103452, +0.8422135), + openblas_make_complex_float(-0.9617417, -1.2486815), + openblas_make_complex_float(3.4629636, +0.0) + }; BLASFUNC(cpotrf)(&up, &n, (float*)(A3), &n, info); // printf("%g+%g*I\n", creal(A3[91]), cimag(A3[91])); if(isnan(CREAL(A3[91])) || isnan(CIMAG(A3[91]))) {